diff --git a/components/flashfiler/examples/LazCustLookup/LazCustLookup.ico b/components/flashfiler/examples/LazCustLookup/LazCustLookup.ico deleted file mode 100644 index 0341321b5..000000000 Binary files a/components/flashfiler/examples/LazCustLookup/LazCustLookup.ico and /dev/null differ diff --git a/components/flashfiler/examples/LazCustLookup/LazCustLookup.lpi b/components/flashfiler/examples/LazCustLookup/LazCustLookup.lpi deleted file mode 100644 index 6a0409795..000000000 --- a/components/flashfiler/examples/LazCustLookup/LazCustLookup.lpi +++ /dev/null @@ -1,88 +0,0 @@ - - - - - - - - - - <ResourceType Value="res"/> - <UseXPManifest Value="True"/> - <Icon Value="0"/> - </General> - <i18n> - <EnableI18N LFM="False"/> - </i18n> - <VersionInfo> - <StringTable ProductVersion=""/> - </VersionInfo> - <BuildModes Count="1"> - <Item1 Name="Default" Default="True"/> - </BuildModes> - <PublishOptions> - <Version Value="2"/> - </PublishOptions> - <RunParams> - <local> - <FormatVersion Value="1"/> - </local> - </RunParams> - <RequiredPackages Count="3"> - <Item1> - <PackageName Value="FCL"/> - </Item1> - <Item2> - <PackageName Value="lazff2"/> - </Item2> - <Item3> - <PackageName Value="LCL"/> - </Item3> - </RequiredPackages> - <Units Count="2"> - <Unit0> - <Filename Value="LazCustLookup.lpr"/> - <IsPartOfProject Value="True"/> - </Unit0> - <Unit1> - <Filename Value="lazcustlookupmain.pas"/> - <IsPartOfProject Value="True"/> - <ComponentName Value="Form1"/> - <HasResources Value="True"/> - <ResourceBaseClass Value="Form"/> - <UnitName Value="LazCustLookupMain"/> - </Unit1> - </Units> - </ProjectOptions> - <CompilerOptions> - <Version Value="11"/> - <PathDelim Value="\"/> - <Target> - <Filename Value="LazCustLookup"/> - </Target> - <SearchPaths> - <IncludeFiles Value="$(ProjOutDir)"/> - <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> - </SearchPaths> - <Linking> - <Options> - <Win32> - <GraphicApplication Value="True"/> - </Win32> - </Options> - </Linking> - </CompilerOptions> - <Debugging> - <Exceptions Count="3"> - <Item1> - <Name Value="EAbort"/> - </Item1> - <Item2> - <Name Value="ECodetoolError"/> - </Item2> - <Item3> - <Name Value="EFOpenError"/> - </Item3> - </Exceptions> - </Debugging> -</CONFIG> diff --git a/components/flashfiler/examples/LazCustLookup/LazCustLookup.lpr b/components/flashfiler/examples/LazCustLookup/LazCustLookup.lpr deleted file mode 100644 index a1804ca20..000000000 --- a/components/flashfiler/examples/LazCustLookup/LazCustLookup.lpr +++ /dev/null @@ -1,21 +0,0 @@ -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 deleted file mode 100644 index e994dfa65..000000000 Binary files a/components/flashfiler/examples/LazCustLookup/LazCustLookup.res and /dev/null differ diff --git a/components/flashfiler/examples/LazCustLookup/lazcustlookupmain.lfm b/components/flashfiler/examples/LazCustLookup/lazcustlookupmain.lfm deleted file mode 100644 index 37088084a..000000000 --- a/components/flashfiler/examples/LazCustLookup/lazcustlookupmain.lfm +++ /dev/null @@ -1,509 +0,0 @@ -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 deleted file mode 100644 index f5fc95c54..000000000 --- a/components/flashfiler/examples/LazCustLookup/lazcustlookupmain.pas +++ /dev/null @@ -1,64 +0,0 @@ -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 deleted file mode 100644 index 32354e902..000000000 Binary files a/components/flashfiler/examples/LazEmbeddedServer/FFSTRAN.CFG and /dev/null differ diff --git a/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.ico b/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.ico deleted file mode 100644 index 0341321b5..000000000 Binary files a/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.ico and /dev/null differ diff --git a/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.lpi b/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.lpi deleted file mode 100644 index f230ebcdf..000000000 --- a/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.lpi +++ /dev/null @@ -1,87 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?> -<CONFIG> - <ProjectOptions> - <Version Value="9"/> - <PathDelim Value="\"/> - <General> - <SessionStorage Value="InProjectDir"/> - <MainUnit Value="0"/> - <Title Value="LazFFEmbedded"/> - <ResourceType Value="res"/> - <UseXPManifest Value="True"/> - <Icon Value="0"/> - </General> - <i18n> - <EnableI18N LFM="False"/> - </i18n> - <VersionInfo> - <StringTable ProductVersion=""/> - </VersionInfo> - <BuildModes Count="1"> - <Item1 Name="Default" Default="True"/> - </BuildModes> - <PublishOptions> - <Version Value="2"/> - </PublishOptions> - <RunParams> - <local> - <FormatVersion Value="1"/> - </local> - </RunParams> - <RequiredPackages Count="3"> - <Item1> - <PackageName Value="FCL"/> - </Item1> - <Item2> - <PackageName Value="lazff2"/> - </Item2> - <Item3> - <PackageName Value="LCL"/> - </Item3> - </RequiredPackages> - <Units Count="2"> - <Unit0> - <Filename Value="LazFFEmbedded.lpr"/> - <IsPartOfProject Value="True"/> - </Unit0> - <Unit1> - <Filename Value="lazffembeddedmain.pas"/> - <IsPartOfProject Value="True"/> - <ComponentName Value="Form1"/> - <ResourceBaseClass Value="Form"/> - <UnitName Value="LazFFEmbeddedMain"/> - </Unit1> - </Units> - </ProjectOptions> - <CompilerOptions> - <Version Value="11"/> - <PathDelim Value="\"/> - <Target> - <Filename Value="LazFFEmbedded"/> - </Target> - <SearchPaths> - <IncludeFiles Value="$(ProjOutDir)"/> - <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> - </SearchPaths> - <Linking> - <Options> - <Win32> - <GraphicApplication Value="True"/> - </Win32> - </Options> - </Linking> - </CompilerOptions> - <Debugging> - <Exceptions Count="3"> - <Item1> - <Name Value="EAbort"/> - </Item1> - <Item2> - <Name Value="ECodetoolError"/> - </Item2> - <Item3> - <Name Value="EFOpenError"/> - </Item3> - </Exceptions> - </Debugging> -</CONFIG> diff --git a/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.lpr b/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.lpr deleted file mode 100644 index 369bfe933..000000000 --- a/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.lpr +++ /dev/null @@ -1,21 +0,0 @@ -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 deleted file mode 100644 index e994dfa65..000000000 Binary files a/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.res and /dev/null differ diff --git a/components/flashfiler/examples/LazEmbeddedServer/XXSINFO.FF2 b/components/flashfiler/examples/LazEmbeddedServer/XXSINFO.FF2 deleted file mode 100644 index d48aace6d..000000000 Binary files a/components/flashfiler/examples/LazEmbeddedServer/XXSINFO.FF2 and /dev/null differ diff --git a/components/flashfiler/examples/LazEmbeddedServer/_ReadMe.txt b/components/flashfiler/examples/LazEmbeddedServer/_ReadMe.txt deleted file mode 100644 index 049a90f10..000000000 --- a/components/flashfiler/examples/LazEmbeddedServer/_ReadMe.txt +++ /dev/null @@ -1 +0,0 @@ -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 deleted file mode 100644 index 167b6f6d8..000000000 --- a/components/flashfiler/examples/LazEmbeddedServer/lazffembeddedmain.lfm +++ /dev/null @@ -1,89 +0,0 @@ -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 deleted file mode 100644 index 0f5138264..000000000 --- a/components/flashfiler/examples/LazEmbeddedServer/lazffembeddedmain.pas +++ /dev/null @@ -1,51 +0,0 @@ -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 deleted file mode 100644 index 0341321b5..000000000 Binary files a/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.ico and /dev/null differ diff --git a/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.lpi b/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.lpi deleted file mode 100644 index 0a7cbb113..000000000 --- a/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.lpi +++ /dev/null @@ -1,89 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?> -<CONFIG> - <ProjectOptions> - <Version Value="10"/> - <PathDelim Value="\"/> - <General> - <SessionStorage Value="InProjectDir"/> - <MainUnit Value="0"/> - <Title Value="LazFFEmbedded"/> - <ResourceType Value="res"/> - <UseXPManifest Value="True"/> - <XPManifest> - <TextName Value="CompanyName.ProductName.AppName"/> - <TextDesc Value="Your application description."/> - </XPManifest> - <Icon Value="0"/> - </General> - <i18n> - <EnableI18N LFM="False"/> - </i18n> - <BuildModes Count="1"> - <Item1 Name="Default" Default="True"/> - </BuildModes> - <PublishOptions> - <Version Value="2"/> - </PublishOptions> - <RunParams> - <local> - <FormatVersion Value="1"/> - </local> - </RunParams> - <RequiredPackages Count="3"> - <Item1> - <PackageName Value="FCL"/> - </Item1> - <Item2> - <PackageName Value="lazff2"/> - </Item2> - <Item3> - <PackageName Value="LCL"/> - </Item3> - </RequiredPackages> - <Units Count="2"> - <Unit0> - <Filename Value="LazFFEmbedded.lpr"/> - <IsPartOfProject Value="True"/> - </Unit0> - <Unit1> - <Filename Value="lazffembeddedmain.pas"/> - <IsPartOfProject Value="True"/> - <ComponentName Value="Form1"/> - <HasResources Value="True"/> - <ResourceBaseClass Value="Form"/> - <UnitName Value="LazFFEmbeddedMain"/> - </Unit1> - </Units> - </ProjectOptions> - <CompilerOptions> - <Version Value="11"/> - <PathDelim Value="\"/> - <Target> - <Filename Value="LazFFEmbedded"/> - </Target> - <SearchPaths> - <IncludeFiles Value="$(ProjOutDir)"/> - <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> - </SearchPaths> - <Linking> - <Options> - <Win32> - <GraphicApplication Value="True"/> - </Win32> - </Options> - </Linking> - </CompilerOptions> - <Debugging> - <Exceptions Count="3"> - <Item1> - <Name Value="EAbort"/> - </Item1> - <Item2> - <Name Value="ECodetoolError"/> - </Item2> - <Item3> - <Name Value="EFOpenError"/> - </Item3> - </Exceptions> - </Debugging> -</CONFIG> diff --git a/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.lpr b/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.lpr deleted file mode 100644 index 369bfe933..000000000 --- a/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.lpr +++ /dev/null @@ -1,21 +0,0 @@ -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 deleted file mode 100644 index 877868cb4..000000000 Binary files a/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.res and /dev/null differ diff --git a/components/flashfiler/examples/LazEmbeddedServer_RT/_ReadMe.txt b/components/flashfiler/examples/LazEmbeddedServer_RT/_ReadMe.txt deleted file mode 100644 index 011f9ced7..000000000 --- a/components/flashfiler/examples/LazEmbeddedServer_RT/_ReadMe.txt +++ /dev/null @@ -1,3 +0,0 @@ -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 deleted file mode 100644 index e0895dc37..000000000 --- a/components/flashfiler/examples/LazEmbeddedServer_RT/lazffembeddedmain.lfm +++ /dev/null @@ -1,54 +0,0 @@ -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 deleted file mode 100644 index 47b2febc5..000000000 --- a/components/flashfiler/examples/LazEmbeddedServer_RT/lazffembeddedmain.pas +++ /dev/null @@ -1,88 +0,0 @@ -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 deleted file mode 100644 index 671308693..000000000 --- a/components/flashfiler/examples/LazExtCust/excust.dpr +++ /dev/null @@ -1,13 +0,0 @@ -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 deleted file mode 100644 index 0341321b5..000000000 Binary files a/components/flashfiler/examples/LazExtCust/excust.ico and /dev/null differ diff --git a/components/flashfiler/examples/LazExtCust/excust.lpi b/components/flashfiler/examples/LazExtCust/excust.lpi deleted file mode 100644 index 4ac9fffe1..000000000 --- a/components/flashfiler/examples/LazExtCust/excust.lpi +++ /dev/null @@ -1,78 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?> -<CONFIG> - <ProjectOptions> - <Version Value="9"/> - <PathDelim Value="\"/> - <General> - <SessionStorage Value="InProjectDir"/> - <MainUnit Value="0"/> - <Title Value="excust"/> - <ResourceType Value="res"/> - <UseXPManifest Value="True"/> - <Icon Value="0"/> - </General> - <i18n> - <EnableI18N LFM="False"/> - </i18n> - <VersionInfo> - <StringTable ProductVersion=""/> - </VersionInfo> - <BuildModes Count="1"> - <Item1 Name="Default" Default="True"/> - </BuildModes> - <PublishOptions> - <Version Value="2"/> - </PublishOptions> - <RunParams> - <local> - <FormatVersion Value="1"/> - </local> - </RunParams> - <RequiredPackages Count="2"> - <Item1> - <PackageName Value="lazff2"/> - </Item1> - <Item2> - <PackageName Value="LCL"/> - </Item2> - </RequiredPackages> - <Units Count="1"> - <Unit0> - <Filename Value="excust.dpr"/> - <IsPartOfProject Value="True"/> - <UnitName Value="ExCust"/> - </Unit0> - </Units> - </ProjectOptions> - <CompilerOptions> - <Version Value="11"/> - <PathDelim Value="\"/> - <Target> - <Filename Value="excust"/> - </Target> - <SearchPaths> - <IncludeFiles Value="$(ProjOutDir)"/> - <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> - </SearchPaths> - <Linking> - <Options> - <Win32> - <GraphicApplication Value="True"/> - </Win32> - </Options> - </Linking> - </CompilerOptions> - <Debugging> - <Exceptions Count="3"> - <Item1> - <Name Value="EAbort"/> - </Item1> - <Item2> - <Name Value="ECodetoolError"/> - </Item2> - <Item3> - <Name Value="EFOpenError"/> - </Item3> - </Exceptions> - </Debugging> -</CONFIG> diff --git a/components/flashfiler/examples/LazExtCust/excust.res b/components/flashfiler/examples/LazExtCust/excust.res deleted file mode 100644 index e994dfa65..000000000 Binary files a/components/flashfiler/examples/LazExtCust/excust.res and /dev/null differ diff --git a/components/flashfiler/examples/LazExtCust/excustu.dfm b/components/flashfiler/examples/LazExtCust/excustu.dfm deleted file mode 100644 index 8ce9d54e2..000000000 --- a/components/flashfiler/examples/LazExtCust/excustu.dfm +++ /dev/null @@ -1,144 +0,0 @@ -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 deleted file mode 100644 index 1b0de08d2..000000000 --- a/components/flashfiler/examples/LazExtCust/excustu.pas +++ /dev/null @@ -1,172 +0,0 @@ -(* ***** 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 deleted file mode 100644 index 0341321b5..000000000 Binary files a/components/flashfiler/examples/LazTffTblIndexNameError/project1.ico and /dev/null differ diff --git a/components/flashfiler/examples/LazTffTblIndexNameError/project1.lpi b/components/flashfiler/examples/LazTffTblIndexNameError/project1.lpi deleted file mode 100644 index 543991249..000000000 --- a/components/flashfiler/examples/LazTffTblIndexNameError/project1.lpi +++ /dev/null @@ -1,88 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?> -<CONFIG> - <ProjectOptions> - <Version Value="9"/> - <PathDelim Value="\"/> - <General> - <SessionStorage Value="InProjectDir"/> - <MainUnit Value="0"/> - <Title Value="project1"/> - <ResourceType Value="res"/> - <UseXPManifest Value="True"/> - <Icon Value="0"/> - </General> - <i18n> - <EnableI18N LFM="False"/> - </i18n> - <VersionInfo> - <StringTable ProductVersion=""/> - </VersionInfo> - <BuildModes Count="1"> - <Item1 Name="Default" Default="True"/> - </BuildModes> - <PublishOptions> - <Version Value="2"/> - </PublishOptions> - <RunParams> - <local> - <FormatVersion Value="1"/> - </local> - </RunParams> - <RequiredPackages Count="3"> - <Item1> - <PackageName Value="FCL"/> - </Item1> - <Item2> - <PackageName Value="lazff2"/> - </Item2> - <Item3> - <PackageName Value="LCL"/> - </Item3> - </RequiredPackages> - <Units Count="2"> - <Unit0> - <Filename Value="project1.lpr"/> - <IsPartOfProject Value="True"/> - </Unit0> - <Unit1> - <Filename Value="unit1.pas"/> - <IsPartOfProject Value="True"/> - <ComponentName Value="Form1"/> - <HasResources Value="True"/> - <ResourceBaseClass Value="Form"/> - <UnitName Value="Unit1"/> - </Unit1> - </Units> - </ProjectOptions> - <CompilerOptions> - <Version Value="11"/> - <PathDelim Value="\"/> - <Target> - <Filename Value="project1"/> - </Target> - <SearchPaths> - <IncludeFiles Value="$(ProjOutDir)"/> - <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> - </SearchPaths> - <Linking> - <Options> - <Win32> - <GraphicApplication Value="True"/> - </Win32> - </Options> - </Linking> - </CompilerOptions> - <Debugging> - <Exceptions Count="3"> - <Item1> - <Name Value="EAbort"/> - </Item1> - <Item2> - <Name Value="ECodetoolError"/> - </Item2> - <Item3> - <Name Value="EFOpenError"/> - </Item3> - </Exceptions> - </Debugging> -</CONFIG> diff --git a/components/flashfiler/examples/LazTffTblIndexNameError/project1.lpr b/components/flashfiler/examples/LazTffTblIndexNameError/project1.lpr deleted file mode 100644 index e9338d792..000000000 --- a/components/flashfiler/examples/LazTffTblIndexNameError/project1.lpr +++ /dev/null @@ -1,21 +0,0 @@ -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 deleted file mode 100644 index e994dfa65..000000000 Binary files a/components/flashfiler/examples/LazTffTblIndexNameError/project1.res and /dev/null differ diff --git a/components/flashfiler/examples/LazTffTblIndexNameError/unit1.lfm b/components/flashfiler/examples/LazTffTblIndexNameError/unit1.lfm deleted file mode 100644 index f8d914fec..000000000 --- a/components/flashfiler/examples/LazTffTblIndexNameError/unit1.lfm +++ /dev/null @@ -1,164 +0,0 @@ -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 deleted file mode 100644 index 79ee03ab4..000000000 --- a/components/flashfiler/examples/LazTffTblIndexNameError/unit1.pas +++ /dev/null @@ -1,81 +0,0 @@ -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 deleted file mode 100644 index 671308693..000000000 --- a/components/flashfiler/examples/Lazffsql/excust.dpr +++ /dev/null @@ -1,13 +0,0 @@ -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 deleted file mode 100644 index 0341321b5..000000000 Binary files a/components/flashfiler/examples/Lazffsql/excust.ico and /dev/null differ diff --git a/components/flashfiler/examples/Lazffsql/excust.lpi b/components/flashfiler/examples/Lazffsql/excust.lpi deleted file mode 100644 index 4ee3a250c..000000000 --- a/components/flashfiler/examples/Lazffsql/excust.lpi +++ /dev/null @@ -1,77 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?> -<CONFIG> - <ProjectOptions> - <Version Value="9"/> - <PathDelim Value="\"/> - <General> - <SessionStorage Value="InProjectDir"/> - <MainUnit Value="0"/> - <Title Value="excust"/> - <ResourceType Value="res"/> - <UseXPManifest Value="True"/> - <Icon Value="0"/> - </General> - <i18n> - <EnableI18N LFM="False"/> - </i18n> - <VersionInfo> - <StringTable ProductVersion=""/> - </VersionInfo> - <BuildModes Count="1"> - <Item1 Name="Default" Default="True"/> - </BuildModes> - <PublishOptions> - <Version Value="2"/> - </PublishOptions> - <RunParams> - <local> - <FormatVersion Value="1"/> - </local> - </RunParams> - <RequiredPackages Count="2"> - <Item1> - <PackageName Value="lazff2"/> - </Item1> - <Item2> - <PackageName Value="LCL"/> - </Item2> - </RequiredPackages> - <Units Count="1"> - <Unit0> - <Filename Value="excust.dpr"/> - <IsPartOfProject Value="True"/> - </Unit0> - </Units> - </ProjectOptions> - <CompilerOptions> - <Version Value="11"/> - <PathDelim Value="\"/> - <Target> - <Filename Value="excust"/> - </Target> - <SearchPaths> - <IncludeFiles Value="$(ProjOutDir)"/> - <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> - </SearchPaths> - <Linking> - <Options> - <Win32> - <GraphicApplication Value="True"/> - </Win32> - </Options> - </Linking> - </CompilerOptions> - <Debugging> - <Exceptions Count="3"> - <Item1> - <Name Value="EAbort"/> - </Item1> - <Item2> - <Name Value="ECodetoolError"/> - </Item2> - <Item3> - <Name Value="EFOpenError"/> - </Item3> - </Exceptions> - </Debugging> -</CONFIG> diff --git a/components/flashfiler/examples/Lazffsql/excust.res b/components/flashfiler/examples/Lazffsql/excust.res deleted file mode 100644 index e994dfa65..000000000 Binary files a/components/flashfiler/examples/Lazffsql/excust.res and /dev/null differ diff --git a/components/flashfiler/examples/Lazffsql/excustu.dfm b/components/flashfiler/examples/Lazffsql/excustu.dfm deleted file mode 100644 index 0b0ed8791..000000000 --- a/components/flashfiler/examples/Lazffsql/excustu.dfm +++ /dev/null @@ -1,208 +0,0 @@ -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 deleted file mode 100644 index 33ffd082e..000000000 --- a/components/flashfiler/examples/Lazffsql/excustu.lrs +++ /dev/null @@ -1,60 +0,0 @@ -{ 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 deleted file mode 100644 index 134656d96..000000000 --- a/components/flashfiler/examples/Lazffsql/excustu.pas +++ /dev/null @@ -1,194 +0,0 @@ -(* ***** 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 deleted file mode 100644 index 4074cd782..000000000 --- a/components/flashfiler/packages/lazff2.lpk +++ /dev/null @@ -1,69 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?> -<CONFIG> - <Package Version="4"> - <PathDelim Value="\"/> - <Name Value="lazff2"/> - <Type Value="RunAndDesignTime"/> - <AddToProjectUsesSection Value="True"/> - <Author Value="Soner A.(Lazarus Convert)"/> - <CompilerOptions> - <Version Value="11"/> - <PathDelim Value="\"/> - <SearchPaths> - <IncludeFiles Value="..\sourcelaz"/> - <OtherUnitFiles Value="..\sourcelaz"/> - <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> - </SearchPaths> - </CompilerOptions> - <Description Value="TurboPower FlashFiler2 for Lazarus"/> - <License Value="Same as TurboPower FlashFIler2 from SourceForge"/> - <Files Count="7"> - <Item1> - <Filename Value="..\sourcelaz\ffclreg.pas"/> - <HasRegisterProc Value="True"/> - <UnitName Value="ffclreg"/> - </Item1> - <Item2> - <Filename Value="..\sourcelaz\ffclfldg.pas"/> - <UnitName Value="ffclfldg"/> - </Item2> - <Item3> - <Filename Value="..\sourcelaz\ffabout.pas"/> - <UnitName Value="ffabout"/> - </Item3> - <Item4> - <Filename Value="..\sourcelaz\ffclexps.pas"/> - <UnitName Value="ffclexps"/> - </Item4> - <Item5> - <Filename Value="..\sourcelaz\ffllgrid.pas"/> - <UnitName Value="ffllgrid"/> - </Item5> - <Item6> - <Filename Value="..\sourcelaz\ffclsqle.pas"/> - <UnitName Value="ffclsqle"/> - </Item6> - <Item7> - <Filename Value="..\sourcelaz\ffllexcp.pas"/> - <UnitName Value="ffllexcp"/> - </Item7> - </Files> - <RequiredPkgs Count="3"> - <Item1> - <PackageName Value="IDEIntf"/> - </Item1> - <Item2> - <PackageName Value="LCL"/> - </Item2> - <Item3> - <PackageName Value="FCL"/> - </Item3> - </RequiredPkgs> - <UsageOptions> - <UnitPath Value="$(PkgOutDir)"/> - </UsageOptions> - <PublishOptions> - <Version Value="2"/> - </PublishOptions> - </Package> -</CONFIG> diff --git a/components/flashfiler/packages/lazff2.pas b/components/flashfiler/packages/lazff2.pas deleted file mode 100644 index cf5c7a7af..000000000 --- a/components/flashfiler/packages/lazff2.pas +++ /dev/null @@ -1,22 +0,0 @@ -{ 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/readme-turbopower.txt b/components/flashfiler/readme-turbopower.txt deleted file mode 100644 index a18099eb8..000000000 --- a/components/flashfiler/readme-turbopower.txt +++ /dev/null @@ -1,147 +0,0 @@ -TurboPower FlashFiler 2 - - -Table of contents - -1. Introduction -2. Package names -3. Installation -4. FlashFiler Explorer functionality -5. String resources -6. Version history -6.1 Release 2.13 - -============================================== - - -1. Introduction - -<TODO> - -This is a source-only release of TurboPower FlashFiler 2. It includes -designtime and runtime packages for Delphi 3 through 7 and C++Builder -3 through 6. - -For help files and a PDF manual, please see the tpflashfiler_docs -package on SourceForge (http://sourceforge.net/projects/tpflashfiler). - -For precompiled binaries of FlashFiler Server and the other FlashFiler -utilities, please see the tpflashfiler_bin package on SourceForge ( -http://sourceforge.net/projects/tpflashfiler). - -============================================== - -2. Package names - - -TurboPower FlashFiler 2 package names have the following form: - - FF2MKVV.* - ||| - ||+------ VV VCL version (30=Delphi 3, 35=C++Builder 3, 70=Delphi 7) - |+------- K Kind of package (R=runtime, D=designtime) - +-------- M Product-specific modifier, typically an underscore - -For example, the FlashFiler 2 runtime package files for Delphi 7 have -the filename FF2_R70.*. - -The runtime package contains the core functionality of the product and -is not installed into the IDE. The designtime package references the -runtime package, registers the components, and contains property -editors used in the IDE. - -============================================== - -3. Installation - - -To install TurboPower FlashFiler 2 into your IDE, take the following -steps: - - 1. Unzip the release files into a directory (e.g., d:\ff2). - - 2. Start Delphi or C++Builder. - - 3. Add the source subdirectory (e.g., d:\ff2\source) to the IDE's - library path. - - 4. Open & compile the runtime package specific to the IDE being - used. - - 5. Open & install the designtime package specific to the IDE being - used. The IDE should notify you the components have been - installed. - -============================================== - -4. FlashFiler Explorer functionality - -The CSV Import functionality was copyrighted by another party and -permission was given to TurboPower to use the functionality only in -the commercial version of FlashFiler 2.. That functionality has been -removed from the open source distribution of FlashFiler Explorer. - -============================================== - -5. String resources - -Most of FlashFiler's error messages are stored in string resource -files having the extension STR. If you change these files, you must -recompile them using the TurboPower String Resource Manager located at -http://sourceforge.net/projects/tpsrmgr - -============================================== - -6. Version history - - -6.1 Release 2.13 - - Please note that the following issue #s are from Bugzilla. These - bugs were not exported to SourceForge. - - - Enhancements - ------------ - - 4043 - Allow FFCheckValToString to return ref number for BLOB fields - 4112 - Restructure: Support conversion of strings to integers - - Bugs fixed - ---------- - - 3403 - Unable to change string field to blob memo field in restructure - 3870 - BDE2FF, invisible target database - 3915 - INSERT: Value of string field truncated to 255 chars - 4003 - Params do not support BLOB field type - 4025 - AutoInc field in SQL result set should be returned as type fftAutoInc - 4028 - Incorrect count() value with LEFT OUTER JOIN - 4029 - Field alias not resolved in WHERE clause - 4030 - When not waiting for a reply, Legacy transport no longer raises lost - connection event in 2.12 - 4031 - Result set does not contain values for subselect - 4032 - If TffDatabase closed before child TffQuery then AV may occur in - SQL engine - 4037 - Index count not updated if use Table.AddIndex - 4038 - '<>' operator does not take NULL values into consideration - 4039 - Query returns empty result set - 4042 - Server should not prompt for password during auto-start-up - 4046 - Table modified by INSERT/UPDATE/DELETE may be closed prior to - transaction commit - 4048 - StartTransactionWith error handling may return incorrect result - 4061 - TffClient does not use registry server name for explicit transport - components - 4070 - "select field, count(*)" returns zero for count - 4077 - Service should use recovery engine that does not require user interface - 4084 - Restored connection re-opens query before preparing the query - 4095 - INSERT should validate column types & number of source columns - 4107 - TffServerCommandHandler.nmDatabaseAddAlias has incorrect format string - 4126 - Cursors pending close may not be freed at end of transaction - 4140 - Pack incorrectly increments NextFlushPoint - 4143 - SQL engine raises 'Not found' error on nested join - 4144 - Server UI Avs if reset counters or right click on transport when server - is down - 4160 - Calling BLOBWrite followed by BLOBTruncate can eventually lead to - corupted BLOB - 4167 - Initial sorting for DISTINCT should be case-sensitive - 4168 - SQL: SUM(x)/(2) does not give same result as SUM(x)/2 diff --git a/components/flashfiler/readme.txt b/components/flashfiler/readme.txt deleted file mode 100644 index bcc89ace3..000000000 --- a/components/flashfiler/readme.txt +++ /dev/null @@ -1,75 +0,0 @@ --------------------------------------------------------------------------------- -About --------------------------------------------------------------------------------- -This is a Lazarus port of the TurboPower FlashFiler Database. -I used the version tpflashfiler_2_13 from SourceForge -(https://sourceforge.net/projects/tpflashfiler/). - -Detailed help and documentation files are located there. -More port infos are in sourcelaz\LazConvertReadMe.txt - - --------------------------------------------------------------------------------- -Preparation --------------------------------------------------------------------------------- -Download the server binaries from -https://sourceforge.net/projects/tpflashfiler/files/tpflashfiler/2.13/tpflashfiler_bin.zip/download -and store them in the folder server_files. - - --------------------------------------------------------------------------------- -Installation --------------------------------------------------------------------------------- -Use package file lazff2.lpk from folder packages. - - --------------------------------------------------------------------------------- -Usage --------------------------------------------------------------------------------- -1.) Start server_files\ffserver.exe -2.) Make 2 db-aliases in ffserver [ffserver-Menu > Config > Aliases ...] - Alias: Path: - mythicdb yourfolder\flashfiler\examples\mythicdb - Tutorial yourfolder\flashfiler\examples -3.) Open FlashFiler Server General Configuration Dialog - [ffserver-Menu > Config > General ...] -4.) In configuration dialog Enter for Server name: - local - then Click Ok. -5.) Now the server "local" appears in Servers listview. Click on it and start it. -6.) Now open any example from examples-folder and compile, run and enjoy it. - Attention: EmbeddedServer-Examples don't work! - - --------------------------------------------------------------------------------- -Changes --------------------------------------------------------------------------------- -State of the Lazarus port: -10.12.2016: Client components are Working. Server components has error so you - need server binaries compiled with delphi. - - -ToDo: -Solve server components error. The error is located in fflldict.pas-file in -procedure TffDataDictionary.ReadFromStream(S : TStream); -It is stream reading error with caused by functions ReadString and ReadInteger. -I could not solve it, maybe someone with better skills can do it. - - --------------------------------------------------------------------------------- -License --------------------------------------------------------------------------------- -Same as TurboPower FlashFiler (MPL 1.1.) - - --------------------------------------------------------------------------------- -Author --------------------------------------------------------------------------------- -Turbo Power -Lazarus Port Soner a. - - --------------------------------------------------------------------------------- -Version --------------------------------------------------------------------------------- -tpflashfiler_2_13-20161210 diff --git a/components/flashfiler/server_files/--put_server_binaries_here-- b/components/flashfiler/server_files/--put_server_binaries_here-- deleted file mode 100644 index fd273bebd..000000000 --- a/components/flashfiler/server_files/--put_server_binaries_here-- +++ /dev/null @@ -1,4 +0,0 @@ -Put the server binaries in this folder. - -The files can be downloaded from -https://sourceforge.net/projects/tpflashfiler/files/tpflashfiler/2.13/tpflashfiler_bin.zip/download \ No newline at end of file diff --git a/components/flashfiler/sourcelaz/#NotUsedMore/lazffdelphi1.pas b/components/flashfiler/sourcelaz/#NotUsedMore/lazffdelphi1.pas deleted file mode 100644 index cf8cc89d6..000000000 --- a/components/flashfiler/sourcelaz/#NotUsedMore/lazffdelphi1.pas +++ /dev/null @@ -1,2075 +0,0 @@ -{ 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 deleted file mode 100644 index 66a60c4d0..000000000 --- a/components/flashfiler/sourcelaz/#NotUsedMore/lazffdelphi2.pas +++ /dev/null @@ -1,620 +0,0 @@ -{ 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 deleted file mode 100644 index aae7fcac0..000000000 --- a/components/flashfiler/sourcelaz/#NotUsedMore/lazvclfuncs.pas +++ /dev/null @@ -1,67 +0,0 @@ -// 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 deleted file mode 100644 index 304db1d81..000000000 --- a/components/flashfiler/sourcelaz/LazConvertReadMe.txt +++ /dev/null @@ -1,125 +0,0 @@ -== 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 deleted file mode 100644 index b1565295d..000000000 --- a/components/flashfiler/sourcelaz/Rebuild210/FFRebuild210.dpr +++ /dev/null @@ -1,46 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 194f2fb21..000000000 Binary files a/components/flashfiler/sourcelaz/Rebuild210/FFRebuild210.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/Rebuild210/dmMain.dfm b/components/flashfiler/sourcelaz/Rebuild210/dmMain.dfm deleted file mode 100644 index c3bf199dd..000000000 Binary files a/components/flashfiler/sourcelaz/Rebuild210/dmMain.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/Rebuild210/dmMain.pas b/components/flashfiler/sourcelaz/Rebuild210/dmMain.pas deleted file mode 100644 index 523e1d401..000000000 --- a/components/flashfiler/sourcelaz/Rebuild210/dmMain.pas +++ /dev/null @@ -1,144 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index c35c3745b..000000000 --- a/components/flashfiler/sourcelaz/Rebuild210/ffrebuild210.ini +++ /dev/null @@ -1,5 +0,0 @@ -[Config] -AutoRun=0 -AllowChangeDirectory=1 -InitialDirectory=c:\ - diff --git a/components/flashfiler/sourcelaz/Rebuild210/ffrebuild210.rc b/components/flashfiler/sourcelaz/Rebuild210/ffrebuild210.rc deleted file mode 100644 index 487a6e87a..000000000 --- a/components/flashfiler/sourcelaz/Rebuild210/ffrebuild210.rc +++ /dev/null @@ -1,60 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index 35fc76b5e..000000000 --- a/components/flashfiler/sourcelaz/Rebuild210/uConfig.pas +++ /dev/null @@ -1,184 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 3e74e2721..000000000 Binary files a/components/flashfiler/sourcelaz/Rebuild210/umain.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/Rebuild210/umain.pas b/components/flashfiler/sourcelaz/Rebuild210/umain.pas deleted file mode 100644 index 851d15dc1..000000000 --- a/components/flashfiler/sourcelaz/Rebuild210/umain.pas +++ /dev/null @@ -1,291 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 94e4a0be1..000000000 --- a/components/flashfiler/sourcelaz/Verify/FFChain.pas +++ /dev/null @@ -1,744 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index abce5fbd7..000000000 --- a/components/flashfiler/sourcelaz/Verify/FFVerify.dpr +++ /dev/null @@ -1,47 +0,0 @@ -(* ***** 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 deleted file mode 100644 index 55f874204..000000000 Binary files a/components/flashfiler/sourcelaz/Verify/FFVerify.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/Verify/ffFileInt.pas b/components/flashfiler/sourcelaz/Verify/ffFileInt.pas deleted file mode 100644 index d94da99dd..000000000 --- a/components/flashfiler/sourcelaz/Verify/ffFileInt.pas +++ /dev/null @@ -1,1527 +0,0 @@ -{*********************************************************} -{* 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], '<null>']) - 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 deleted file mode 100644 index df6a44499..000000000 --- a/components/flashfiler/sourcelaz/Verify/ffrepair.pas +++ /dev/null @@ -1,1065 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index ad237ee07..000000000 --- a/components/flashfiler/sourcelaz/Verify/ffrepcnst.pas +++ /dev/null @@ -1,257 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 3b4f806f9..000000000 --- a/components/flashfiler/sourcelaz/Verify/ffv2file.pas +++ /dev/null @@ -1,2360 +0,0 @@ -{*********************************************************} -{* 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 := '<null>' - 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 deleted file mode 100644 index f43d0d227..000000000 Binary files a/components/flashfiler/sourcelaz/Verify/frMain.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/Verify/frMain.pas b/components/flashfiler/sourcelaz/Verify/frMain.pas deleted file mode 100644 index ebc8896b1..000000000 --- a/components/flashfiler/sourcelaz/Verify/frMain.pas +++ /dev/null @@ -1,858 +0,0 @@ -{*********************************************************} -{* 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, '<open a FlashFiler table>'); -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 deleted file mode 100644 index 951aa1c49..000000000 Binary files a/components/flashfiler/sourcelaz/Verify/frmBlock.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/Verify/frmBlock.pas b/components/flashfiler/sourcelaz/Verify/frmBlock.pas deleted file mode 100644 index 9ac93759c..000000000 --- a/components/flashfiler/sourcelaz/Verify/frmBlock.pas +++ /dev/null @@ -1,119 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 68252c780..000000000 Binary files a/components/flashfiler/sourcelaz/Verify/frmOptions.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/Verify/frmOptions.pas b/components/flashfiler/sourcelaz/Verify/frmOptions.pas deleted file mode 100644 index a01268064..000000000 --- a/components/flashfiler/sourcelaz/Verify/frmOptions.pas +++ /dev/null @@ -1,198 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index e32564811..000000000 --- a/components/flashfiler/sourcelaz/Verify/readme.txt +++ /dev/null @@ -1,9 +0,0 @@ -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 deleted file mode 100644 index 418f97bc7..000000000 --- a/components/flashfiler/sourcelaz/bde2ff/bde2ff.dpr +++ /dev/null @@ -1,54 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 047b239b8..000000000 --- a/components/flashfiler/sourcelaz/bde2ff/bde2ff.rc +++ /dev/null @@ -1,60 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index c262f353e..000000000 Binary files a/components/flashfiler/sourcelaz/bde2ff/bde2ff.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/bde2ff/dgimpdo.dfm b/components/flashfiler/sourcelaz/bde2ff/dgimpdo.dfm deleted file mode 100644 index 920e2ec73..000000000 Binary files a/components/flashfiler/sourcelaz/bde2ff/dgimpdo.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/bde2ff/dgimpdo.pas b/components/flashfiler/sourcelaz/bde2ff/dgimpdo.pas deleted file mode 100644 index 87a981ec8..000000000 --- a/components/flashfiler/sourcelaz/bde2ff/dgimpdo.pas +++ /dev/null @@ -1,575 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index e3f5f03f8..000000000 Binary files a/components/flashfiler/sourcelaz/bde2ff/fmmain.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/bde2ff/fmmain.pas b/components/flashfiler/sourcelaz/bde2ff/fmmain.pas deleted file mode 100644 index 494ff6f8d..000000000 --- a/components/flashfiler/sourcelaz/bde2ff/fmmain.pas +++ /dev/null @@ -1,830 +0,0 @@ -{*********************************************************} -{* 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('<All fields will be converted for each table>'); - 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 deleted file mode 100644 index 062380d91..000000000 --- a/components/flashfiler/sourcelaz/beta/beta.dpr +++ /dev/null @@ -1,48 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 94c2adfbc..000000000 --- a/components/flashfiler/sourcelaz/beta/beta.rc +++ /dev/null @@ -1,61 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index ba81f04fe..000000000 Binary files a/components/flashfiler/sourcelaz/beta/beta.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/beta/fmmain.dfm b/components/flashfiler/sourcelaz/beta/fmmain.dfm deleted file mode 100644 index 6771b7231..000000000 Binary files a/components/flashfiler/sourcelaz/beta/fmmain.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/beta/fmmain.pas b/components/flashfiler/sourcelaz/beta/fmmain.pas deleted file mode 100644 index 89418c4d6..000000000 --- a/components/flashfiler/sourcelaz/beta/fmmain.pas +++ /dev/null @@ -1,434 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 8ea38995d..000000000 --- a/components/flashfiler/sourcelaz/cocobase.pas +++ /dev/null @@ -1,898 +0,0 @@ -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 deleted file mode 100644 index 55f874204..000000000 Binary files a/components/flashfiler/sourcelaz/convert/ff1dataa.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/convert/ff1intfc.dpr b/components/flashfiler/sourcelaz/convert/ff1intfc.dpr deleted file mode 100644 index ada5b3774..000000000 --- a/components/flashfiler/sourcelaz/convert/ff1intfc.dpr +++ /dev/null @@ -1,59 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index fed719a8d..000000000 --- a/components/flashfiler/sourcelaz/convert/ff1intfc.rc +++ /dev/null @@ -1,60 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index 052b7fb5c..000000000 Binary files a/components/flashfiler/sourcelaz/convert/ff1intfc.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/convert/ffcnvrt.dpr b/components/flashfiler/sourcelaz/convert/ffcnvrt.dpr deleted file mode 100644 index 5b7f132ba..000000000 --- a/components/flashfiler/sourcelaz/convert/ffcnvrt.dpr +++ /dev/null @@ -1,49 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 5633fd556..000000000 --- a/components/flashfiler/sourcelaz/convert/ffcnvrt.rc +++ /dev/null @@ -1,60 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index 3939998d3..000000000 Binary files a/components/flashfiler/sourcelaz/convert/ffcnvrt.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/convert/ffcnvrtc.dpr b/components/flashfiler/sourcelaz/convert/ffcnvrtc.dpr deleted file mode 100644 index 17f755a24..000000000 --- a/components/flashfiler/sourcelaz/convert/ffcnvrtc.dpr +++ /dev/null @@ -1,396 +0,0 @@ -{*********************************************************} -{* 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<complete source path> -d<complete destination path> [-t<table name>]'); - 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 deleted file mode 100644 index 82426e55b..000000000 --- a/components/flashfiler/sourcelaz/convert/ffcnvrtc.rc +++ /dev/null @@ -1,60 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index 5e170a902..000000000 Binary files a/components/flashfiler/sourcelaz/convert/ffcnvrtc.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/convert/ffconvrt.pas b/components/flashfiler/sourcelaz/convert/ffconvrt.pas deleted file mode 100644 index 27e6b9443..000000000 --- a/components/flashfiler/sourcelaz/convert/ffconvrt.pas +++ /dev/null @@ -1,972 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 9c2bf3a67..000000000 --- a/components/flashfiler/sourcelaz/convert/ffcvcnst.inc +++ /dev/null @@ -1,35 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index d2d3e2cca..000000000 --- a/components/flashfiler/sourcelaz/convert/ffcvcnst.rc +++ /dev/null @@ -1,31 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index 82feddec1..000000000 Binary files a/components/flashfiler/sourcelaz/convert/ffcvcnst.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/convert/ffcvcnst.srm b/components/flashfiler/sourcelaz/convert/ffcvcnst.srm deleted file mode 100644 index bd0549cae..000000000 Binary files a/components/flashfiler/sourcelaz/convert/ffcvcnst.srm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/convert/ffcvcnst.str b/components/flashfiler/sourcelaz/convert/ffcvcnst.str deleted file mode 100644 index 3c8fd4721..000000000 --- a/components/flashfiler/sourcelaz/convert/ffcvcnst.str +++ /dev/null @@ -1,34 +0,0 @@ -;********************************************************* -;* 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 deleted file mode 100644 index 5439bee01..000000000 Binary files a/components/flashfiler/sourcelaz/convert/fflogo.jpg and /dev/null differ diff --git a/components/flashfiler/sourcelaz/convert/ffmemmgr.pas b/components/flashfiler/sourcelaz/convert/ffmemmgr.pas deleted file mode 100644 index e1b005c38..000000000 --- a/components/flashfiler/sourcelaz/convert/ffmemmgr.pas +++ /dev/null @@ -1,164 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index bcdef7b16..000000000 --- a/components/flashfiler/sourcelaz/convert/uff1data.pas +++ /dev/null @@ -1,430 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 94e046fb2..000000000 Binary files a/components/flashfiler/sourcelaz/convert/uff2cnv.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/convert/uff2cnv.pas b/components/flashfiler/sourcelaz/convert/uff2cnv.pas deleted file mode 100644 index c8f6f4930..000000000 --- a/components/flashfiler/sourcelaz/convert/uff2cnv.pas +++ /dev/null @@ -1,648 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index b0f337409..000000000 Binary files a/components/flashfiler/sourcelaz/convert/uffnet.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/convert/uffnet.pas b/components/flashfiler/sourcelaz/convert/uffnet.pas deleted file mode 100644 index badab9a68..000000000 --- a/components/flashfiler/sourcelaz/convert/uffnet.pas +++ /dev/null @@ -1,95 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 6affff08c..000000000 --- a/components/flashfiler/sourcelaz/crystal/ffcrdefn.inc +++ /dev/null @@ -1,42 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 90a794bd8..000000000 --- a/components/flashfiler/sourcelaz/crystal/ffcrdrvr.rc +++ /dev/null @@ -1,60 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index 2b6c75456..000000000 Binary files a/components/flashfiler/sourcelaz/crystal/ffcrdrvr.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/crystal/ffcrltyp.pas b/components/flashfiler/sourcelaz/crystal/ffcrltyp.pas deleted file mode 100644 index 6cb9a6b35..000000000 --- a/components/flashfiler/sourcelaz/crystal/ffcrltyp.pas +++ /dev/null @@ -1,130 +0,0 @@ -{*********************************************************} -(* 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 deleted file mode 100644 index 507185e1f..000000000 --- a/components/flashfiler/sourcelaz/crystal/ffcrmain.pas +++ /dev/null @@ -1,4525 +0,0 @@ -{*********************************************************} -(* 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 deleted file mode 100644 index ad01e6756..000000000 --- a/components/flashfiler/sourcelaz/crystal/ffcrptyp.pas +++ /dev/null @@ -1,354 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index daa221481..000000000 --- a/components/flashfiler/sourcelaz/crystal/ffcrtype.pas +++ /dev/null @@ -1,138 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index b551bf5b1..000000000 --- a/components/flashfiler/sourcelaz/crystal/ffcrutil.pas +++ /dev/null @@ -1,147 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 5b8eea8a9..000000000 --- a/components/flashfiler/sourcelaz/crystal/p2bff213.dpr +++ /dev/null @@ -1,121 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 540bf06ce..000000000 --- a/components/flashfiler/sourcelaz/crystal/p2bff213.rc +++ /dev/null @@ -1,60 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index 1a6d6592f..000000000 Binary files a/components/flashfiler/sourcelaz/crystal/p2bff213.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/crystal/readme.txt b/components/flashfiler/sourcelaz/crystal/readme.txt deleted file mode 100644 index 9abbe934e..000000000 --- a/components/flashfiler/sourcelaz/crystal/readme.txt +++ /dev/null @@ -1,96 +0,0 @@ -====================================================================== - 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 <xxx> 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 deleted file mode 100644 index 0ff43ccdc..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/DgCpyTbl.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/DgCpyTbl.pas b/components/flashfiler/sourcelaz/explorer/DgCpyTbl.pas deleted file mode 100644 index eb6940a0b..000000000 --- a/components/flashfiler/sourcelaz/explorer/DgCpyTbl.pas +++ /dev/null @@ -1,194 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 445263b76..000000000 --- a/components/flashfiler/sourcelaz/explorer/FFEReportEngine.dpr +++ /dev/null @@ -1,54 +0,0 @@ -(* ***** 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 deleted file mode 100644 index aae5d65b7..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/FFEReportEngine.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/FRFFEReportEngine.pas b/components/flashfiler/sourcelaz/explorer/FRFFEReportEngine.pas deleted file mode 100644 index 6836d2a66..000000000 --- a/components/flashfiler/sourcelaz/explorer/FRFFEReportEngine.pas +++ /dev/null @@ -1,259 +0,0 @@ -(* ***** 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 deleted file mode 100644 index b54a06f58..000000000 --- a/components/flashfiler/sourcelaz/explorer/TestDll.dpr +++ /dev/null @@ -1,40 +0,0 @@ -(* ***** 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 deleted file mode 100644 index 4fd998792..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/TestDllUnit.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/TestDllUnit.pas b/components/flashfiler/sourcelaz/explorer/TestDllUnit.pas deleted file mode 100644 index a4ba40262..000000000 --- a/components/flashfiler/sourcelaz/explorer/TestDllUnit.pas +++ /dev/null @@ -1,91 +0,0 @@ -(* ***** 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 deleted file mode 100644 index c6b074db6..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/dgParams.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/dgParams.pas b/components/flashfiler/sourcelaz/explorer/dgParams.pas deleted file mode 100644 index a923407b8..000000000 --- a/components/flashfiler/sourcelaz/explorer/dgParams.pas +++ /dev/null @@ -1,324 +0,0 @@ -(* ***** 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 deleted file mode 100644 index 855288fa7..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/dgServSt.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/dgServSt.pas b/components/flashfiler/sourcelaz/explorer/dgServSt.pas deleted file mode 100644 index 043b73cb6..000000000 --- a/components/flashfiler/sourcelaz/explorer/dgServSt.pas +++ /dev/null @@ -1,431 +0,0 @@ -(* ***** 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<lvTransports.Items.Count then - for TransportIdx := TransportCount to lvTransports.Items.Count-1 do - lvTransports.Items.Delete(0); - { update transports } - TransportCount := 0; - for CmdHandlerIdx := 0 to Pred(aServerStats.ssCmdHandlerCount) do begin - FSession.GetCommandHandlerStatistics(CmdHandlerIdx, aCmdHandlerStats); - for TransportIdx := 0 to Pred(aCmdHandlerStats.csTransportCount) do begin - FSession.GetTransportStatistics(CmdHandlerIdx, TransportIdx, aTransportStats); - - with lvTransports.Items[TransportCount], - aTransportStats do begin - Caption := tsName; - SubItems[0] := tsAddress; - SubItems[1] := tsState; - SubItems[2] := FFCommaizeChL(tsClientCount, ThousandSeparator); - SubItems[3] := FFCommaizeChL(tsMessageCount, ThousandSeparator); - SubItems[4] := FormatFloat('0.####', tsMessagesPerSec); - SubItems[5] := IntToStr(CmdHandlerIdx); - end; - Inc(TransportCount); - end; - end; - if ServerUp then begin - lvServers.Font.Color := clWindowText; - lvServers.Color := clWindow; - lvTransports.Font.Color := clWindowText; - lvTransports.Color := clWindow; - end - else begin - { warn user with some angry colours } - lvServers.Font.Color := clWhite; - lvServers.Color := clRed; - lvTransports.Font.Color := clWhite; - lvTransports.Color := clRed; - end; - finally - lvServers.Items.EndUpdate; - lvTransports.Items.EndUpdate; - end; -end; - - -procedure TdlgServerStats.cbAutoupdateClick(Sender: TObject); -begin - tiAutoupdate.Enabled := cbAutoupdate.Checked; - edFrequency.Enabled := cbAutoupdate.Checked; -end; - - -procedure TdlgServerStats.tiAutoupdateTimer(Sender: TObject); -begin - UpdateStats; -end; - - -procedure TdlgServerStats.btnRefreshClick(Sender: TObject); -var - aServerStats: TffServerStatistics; -begin - { attempt to reconnect? } - if not (FSession.GetServerStatistics(aServerStats)=DBIERR_NONE) then begin - FTransport.Enabled := False; - FClient.Close; - OpenSession; - end; - UpdateStats; -end; - - -procedure TdlgServerStats.FormKeyDown(Sender: TObject; var Key: Word; - Shift: TShiftState); -begin - if Key=VK_ESCAPE then - Close; -end; - -procedure TdlgServerStats.edFrequencyChange(Sender: TObject); -begin - try - tiAutoupdate.Interval := StrToInt(edFrequency.Text); - except - { swallow convert error } - end; -end; - -end. diff --git a/components/flashfiler/sourcelaz/explorer/dgSetRng.dfm b/components/flashfiler/sourcelaz/explorer/dgSetRng.dfm deleted file mode 100644 index feba189f7..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/dgSetRng.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/dgSetRng.pas b/components/flashfiler/sourcelaz/explorer/dgSetRng.pas deleted file mode 100644 index 8ea6c7ca5..000000000 --- a/components/flashfiler/sourcelaz/explorer/dgSetRng.pas +++ /dev/null @@ -1,305 +0,0 @@ -{*********************************************************} -{* Dialog to set range start and end values *} -{*********************************************************} - -(* ***** 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 dgSetRng; - -interface - -uses - Windows, - SysUtils, - Classes, - Graphics, - Forms, - Controls, - StdCtrls, - Buttons, - ExtCtrls, - ffllbase, - ffdb, - ubase, - uelement, - uentity; - -type - TdlgSetRange = class(TForm) - Panel1: TPanel; - Label1: TLabel; - Label2: TLabel; - Label3: TLabel; - paField1: TPanel; - laField1: TLabel; - edStart1: TEdit; - edEnd1: TEdit; - cbStartNull1: TCheckBox; - cbEndNull1: TCheckBox; - paField16: TPanel; - laField16: TLabel; - edStart16: TEdit; - edEnd16: TEdit; - cbStartNull16: TCheckBox; - cbEndNull16: TCheckBox; - paField15: TPanel; - laField15: TLabel; - edStart15: TEdit; - edEnd15: TEdit; - cbStartNull15: TCheckBox; - cbEndNull15: TCheckBox; - paField14: TPanel; - laField14: TLabel; - edStart14: TEdit; - edEnd14: TEdit; - cbStartNull14: TCheckBox; - cbEndNull14: TCheckBox; - paField13: TPanel; - laField13: TLabel; - edStart13: TEdit; - edEnd13: TEdit; - cbStartNull13: TCheckBox; - cbEndNull13: TCheckBox; - paField12: TPanel; - laField12: TLabel; - edStart12: TEdit; - edEnd12: TEdit; - cbStartNull12: TCheckBox; - cbEndNull12: TCheckBox; - paField11: TPanel; - laField11: TLabel; - edStart11: TEdit; - edEnd11: TEdit; - cbStartNull11: TCheckBox; - cbEndNull11: TCheckBox; - paField10: TPanel; - laField10: TLabel; - edStart10: TEdit; - edEnd10: TEdit; - cbStartNull10: TCheckBox; - cbEndNull10: TCheckBox; - paField9: TPanel; - laField9: TLabel; - edStart9: TEdit; - edEnd9: TEdit; - cbStartNull9: TCheckBox; - cbEndNull9: TCheckBox; - paField8: TPanel; - laField8: TLabel; - edStart8: TEdit; - edEnd8: TEdit; - cbStartNull8: TCheckBox; - cbEndNull8: TCheckBox; - paField7: TPanel; - laField7: TLabel; - edStart7: TEdit; - edEnd7: TEdit; - cbStartNull7: TCheckBox; - cbEndNull7: TCheckBox; - paField6: TPanel; - laField6: TLabel; - edStart6: TEdit; - edEnd6: TEdit; - cbStartNull6: TCheckBox; - cbEndNull6: TCheckBox; - paField5: TPanel; - laField5: TLabel; - edStart5: TEdit; - edEnd5: TEdit; - cbStartNull5: TCheckBox; - cbEndNull5: TCheckBox; - paField4: TPanel; - laField4: TLabel; - edStart4: TEdit; - edEnd4: TEdit; - cbStartNull4: TCheckBox; - cbEndNull4: TCheckBox; - paField3: TPanel; - laField3: TLabel; - edStart3: TEdit; - edEnd3: TEdit; - cbStartNull3: TCheckBox; - cbEndNull3: TCheckBox; - paField2: TPanel; - laField2: TLabel; - edStart2: TEdit; - edEnd2: TEdit; - cbStartNull2: TCheckBox; - cbEndNull2: TCheckBox; - paBottom: TPanel; - CancelBtn: TButton; - OKBtn: TButton; - cbRangeStartKeyExclusive: TCheckBox; - cbRangeEndKeyExclusive: TCheckBox; - Bevel1: TBevel; - procedure cbStartNull1Click(Sender: TObject); - procedure cbEndNull1Click(Sender: TObject); - private - { Private declarations } - procedure SetNumberOfFields(NumFields: Integer); - function GetStartNull(FieldIdx: Integer) : Boolean; - function GetEndNull(FieldIdx: Integer) : Boolean; - function GetStartValue(FieldIdx: Integer) : String; - function GetEndValue(FieldIdx: Integer) : String; - procedure SetStartNull(FieldIdx: Integer; IsNull: Boolean); - procedure SetEndNull(FieldIdx: Integer; IsNull: Boolean); - procedure SetStartValue(FieldIdx: Integer; Value : String); - procedure SetEndValue(FieldIdx: Integer; Value : String); - procedure SetFieldName(FieldIdx: Integer; Value : String); - public - { Public declarations } - end; - - TffRangeValuesForField = record - StartNull, - EndNull : Boolean; - StartValue, - EndValue : String[255]; - end; - - TffRangeValues = record - Field: Array [1..ffcl_MaxIndexFlds] of TffRangeValuesForField; - RangeStartKeyExclusive, - RangeEndKeyExclusive : Boolean; - end; - - -function SetRangeDlg(aTable : TffTable; var RangeValues : TffRangeValues): TModalResult; - -implementation - -{$R *.dfm} - - -function SetRangeDlg(aTable : TffTable; var RangeValues : TffRangeValues): TModalResult; -var - FieldIdx : Integer; -begin - with TdlgSetRange.Create(nil) do - try - for FieldIdx := Low(RangeValues.Field) to High(RangeValues.Field) do begin - SetStartNull(FieldIdx, RangeValues.Field[FieldIdx].StartNull); - SetEndNull(FieldIdx, RangeValues.Field[FieldIdx].EndNull); - SetStartValue(FieldIdx, RangeValues.Field[FieldIdx].StartValue); - SetEndValue(FieldIdx, RangeValues.Field[FieldIdx].EndValue); - end; - for FieldIdx := 1 to aTable.IndexFieldCount do - SetFieldName(FieldIdx, aTable.IndexFields[FieldIdx-1].DisplayName); - SetNumberOfFields(aTable.IndexFieldCount); - cbRangeStartKeyExclusive.Checked := RangeValues.RangeStartKeyExclusive; - cbRangeEndKeyExclusive.Checked := RangeValues.RangeEndKeyExclusive; - Result := ShowModal; - if Result=mrOK then begin - for FieldIdx := Low(RangeValues.Field) to High(RangeValues.Field) do begin - RangeValues.Field[FieldIdx].StartNull := GetStartNull(FieldIdx); - RangeValues.Field[FieldIdx].EndNull := GetEndNull(FieldIdx); - RangeValues.Field[FieldIdx].StartValue := GetStartValue(FieldIdx); - RangeValues.Field[FieldIdx].EndValue := GetEndValue(FieldIdx); - end; - RangeValues.RangeStartKeyExclusive := cbRangeStartKeyExclusive.Checked; - RangeValues.RangeEndKeyExclusive := cbRangeEndKeyExclusive.Checked; - end; - finally - Free; - end; -end; - - -{ TdlgSetRange } - -procedure TdlgSetRange.SetNumberOfFields(NumFields: Integer); -var - FieldIdx : Integer; -begin - for FieldIdx := ffcl_MaxIndexFlds downto NumFields+1 do - TPanel(FindComponent('paField'+IntToStr(FieldIdx))).Visible := False; - ClientHeight := paBottom.Top + paBottom.Height; -end; - -function TdlgSetRange.GetEndNull(FieldIdx: Integer): Boolean; -begin - Result := TCheckBox(FindComponent('cbEndNull'+IntToStr(FieldIdx))).Checked; -end; - -function TdlgSetRange.GetEndValue(FieldIdx: Integer): String; -begin - Result := TEdit(FindComponent('edEnd'+IntToStr(FieldIdx))).Text; -end; - -function TdlgSetRange.GetStartNull(FieldIdx: Integer): Boolean; -begin - Result := TCheckBox(FindComponent('cbStartNull'+IntToStr(FieldIdx))).Checked; -end; - -function TdlgSetRange.GetStartValue(FieldIdx: Integer): String; -begin - Result := TEdit(FindComponent('edStart'+IntToStr(FieldIdx))).Text; -end; - -procedure TdlgSetRange.SetEndNull(FieldIdx: Integer; IsNull: Boolean); -begin - TCheckBox(FindComponent('cbEndNull'+IntToStr(FieldIdx))).Checked := IsNull; -end; - -procedure TdlgSetRange.SetEndValue(FieldIdx: Integer; Value: String); -begin - TEdit(FindComponent('edEnd'+IntToStr(FieldIdx))).Text := Value; -end; - -procedure TdlgSetRange.SetStartNull(FieldIdx: Integer; IsNull: Boolean); -begin - TCheckBox(FindComponent('cbStartNull'+IntToStr(FieldIdx))).Checked := IsNull; -end; - -procedure TdlgSetRange.SetStartValue(FieldIdx: Integer; Value: String); -begin - TEdit(FindComponent('edStart'+IntToStr(FieldIdx))).Text := Value; -end; - -procedure TdlgSetRange.SetFieldName(FieldIdx: Integer; Value: String); -begin - TLabel(FindComponent('laField'+IntToStr(FieldIdx))).Caption := Value; -end; - -procedure TdlgSetRange.cbStartNull1Click(Sender: TObject); -var - FieldIdx : String; -begin - FieldIdx := Copy(TCheckBox(Sender).Name, 12, 2); - TEdit(FindComponent('edStart'+FieldIdx)).Enabled := not TCheckBox(Sender).Checked; -end; - -procedure TdlgSetRange.cbEndNull1Click(Sender: TObject); -var - FieldIdx : String; -begin - FieldIdx := Copy(TCheckBox(Sender).Name, 10, 2); - TEdit(FindComponent('edEnd'+FieldIdx)).Enabled := not TCheckBox(Sender).Checked; -end; - -end. diff --git a/components/flashfiler/sourcelaz/explorer/dgaddals.dfm b/components/flashfiler/sourcelaz/explorer/dgaddals.dfm deleted file mode 100644 index e67af696a..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/dgaddals.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/dgaddals.pas b/components/flashfiler/sourcelaz/explorer/dgaddals.pas deleted file mode 100644 index f6c1a2647..000000000 --- a/components/flashfiler/sourcelaz/explorer/dgaddals.pas +++ /dev/null @@ -1,159 +0,0 @@ -{*********************************************************} -{* Dialog to define an alias *} -{*********************************************************} - -(* ***** 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 dgaddals; - -interface - -uses - Windows, - Messages, - SysUtils, - Classes, - Graphics, - Controls, - Forms, - Dialogs, - StdCtrls, - FileCtrl, - Buttons, - ExtCtrls, - ffllbase, - ffllunc, - uconsts, - uentity, - ubase; - -type - TdlgAddAlias = class(TForm) - btnOK: TBitBtn; - btnCancel: TBitBtn; - Label1: TLabel; - Label2: TLabel; - cboDrives: TDriveComboBox; - Label3: TLabel; - Label4: TLabel; - lstFolders: TDirectoryListBox; - edtAlias: TEdit; - edtPath: TEdit; - cbCheckSpace: TCheckBox; - procedure btnOKClick(Sender: TObject); - procedure lstFoldersChange(Sender: TObject); - procedure FormCreate(Sender: TObject); - private - FDatabase : TffeDatabaseItem; - FServer : TffeServerItem; - public - end; - -function ShowAddAliasDlg(aServer: TffeServerItem; - var aDatabase : TffeDatabaseItem): TModalResult; - -var - dlgAddAlias: TdlgAddAlias; - -implementation - -{$R *.DFM} - -function ShowAddAliasDlg(aServer : TffeServerItem; - var aDatabase: TffeDatabaseItem): TModalResult; -begin - with TdlgAddAlias.Create(nil) do - try - edtAlias.MaxLength := ffcl_GeneralNameSize; {!!.10} - FServer := aServer; - Result := ShowModal; - aDatabase := FDatabase; - finally - Free; - end; -end; - -procedure TdlgAddAlias.FormCreate(Sender: TObject); -begin - FDatabase := nil; - HelpContext := hcAddDatabaseDlg; -end; - -procedure TdlgAddAlias.btnOKClick(Sender: TObject); -var - ExistingAliases: TStringList; - UNCFilename: TffFullFilename; -begin - if edtAlias.Text = '' then - raise Exception.Create('You must enter an alias name.'); - - if edtPath.Text = '' then - raise Exception.Create('You must enter a path.'); - - { Check if directory is on local machine } - UNCFilename := FFExpandUNCFileName(edtPath.Text); - if Copy(UNCFilename, 2, 1) = ':' then - if MessageDlg('This path is local to this workstation. ' + - 'Are you sure you want to locate a database here?', - mtConfirmation, [mbYes, mbNo], 0) <> 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 deleted file mode 100644 index 6c12127be..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/dgautoin.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/dgautoin.pas b/components/flashfiler/sourcelaz/explorer/dgautoin.pas deleted file mode 100644 index dcf8a90c5..000000000 --- a/components/flashfiler/sourcelaz/explorer/dgautoin.pas +++ /dev/null @@ -1,117 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index f6e449a19..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/dgimpdef.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/dgimpdef.pas b/components/flashfiler/sourcelaz/explorer/dgimpdef.pas deleted file mode 100644 index 0ff34e9ac..000000000 --- a/components/flashfiler/sourcelaz/explorer/dgimpdef.pas +++ /dev/null @@ -1,144 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 3a1872245..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/dgimpdo.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/dgimpdo.pas b/components/flashfiler/sourcelaz/explorer/dgimpdo.pas deleted file mode 100644 index 74c2e02c3..000000000 --- a/components/flashfiler/sourcelaz/explorer/dgimpdo.pas +++ /dev/null @@ -1,151 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index bdc0b6923..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/dgimport.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/dgimport.pas b/components/flashfiler/sourcelaz/explorer/dgimport.pas deleted file mode 100644 index f77183c06..000000000 --- a/components/flashfiler/sourcelaz/explorer/dgimport.pas +++ /dev/null @@ -1,377 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index adc865667..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/dgprintg.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/dgprintg.pas b/components/flashfiler/sourcelaz/explorer/dgprintg.pas deleted file mode 100644 index 8cd05eee2..000000000 --- a/components/flashfiler/sourcelaz/explorer/dgprintg.pas +++ /dev/null @@ -1,92 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 0955730ef..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/dgquery.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/dgquery.pas b/components/flashfiler/sourcelaz/explorer/dgquery.pas deleted file mode 100644 index 6f0ca881d..000000000 --- a/components/flashfiler/sourcelaz/explorer/dgquery.pas +++ /dev/null @@ -1,1179 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 4f6cea25d..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/dgregsrv.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/dgregsrv.pas b/components/flashfiler/sourcelaz/explorer/dgregsrv.pas deleted file mode 100644 index 252762962..000000000 --- a/components/flashfiler/sourcelaz/explorer/dgregsrv.pas +++ /dev/null @@ -1,179 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 001683a0a..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/dgselidx.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/dgselidx.pas b/components/flashfiler/sourcelaz/explorer/dgselidx.pas deleted file mode 100644 index c8ed737e0..000000000 --- a/components/flashfiler/sourcelaz/explorer/dgselidx.pas +++ /dev/null @@ -1,155 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 8aebd1c9e..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/dgsqlops.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/dgsqlops.pas b/components/flashfiler/sourcelaz/explorer/dgsqlops.pas deleted file mode 100644 index 47755864e..000000000 --- a/components/flashfiler/sourcelaz/explorer/dgsqlops.pas +++ /dev/null @@ -1,172 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 67ddc9aec..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/dgtable.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/dgtable.pas b/components/flashfiler/sourcelaz/explorer/dgtable.pas deleted file mode 100644 index 97f04f617..000000000 --- a/components/flashfiler/sourcelaz/explorer/dgtable.pas +++ /dev/null @@ -1,1964 +0,0 @@ -{*********************************************************} -{* 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: <ACTIVE>' - else - barStatus.Panels[1].Text := 'Filter: <Inactive>'; - - if InRange then begin - barStatus.Panels[2].Text := 'Range: <ACTIVE>'; - laRangeStart.Font.Style := [fsBold]; - laRangeEnd.Font.Style := [fsBold]; - laRangeStartDesc.Font.Style := [fsBold]; - laRangeEndDesc.Font.Style := [fsBold]; - end - else begin - barStatus.Panels[2].Text := 'Range: <Inactive>'; - 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 deleted file mode 100644 index 2bfa28ebc..000000000 --- a/components/flashfiler/sourcelaz/explorer/ffe.dpr +++ /dev/null @@ -1,71 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index d434bf8d4..000000000 --- a/components/flashfiler/sourcelaz/explorer/ffe.rc +++ /dev/null @@ -1,112 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index ae1a7cf61..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/ffe.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/fmFRFFEEngine.dfm b/components/flashfiler/sourcelaz/explorer/fmFRFFEEngine.dfm deleted file mode 100644 index 367eab176..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/fmFRFFEEngine.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/fmFRFFEEngine.pas b/components/flashfiler/sourcelaz/explorer/fmFRFFEEngine.pas deleted file mode 100644 index 3b56c8dc8..000000000 --- a/components/flashfiler/sourcelaz/explorer/fmFRFFEEngine.pas +++ /dev/null @@ -1,76 +0,0 @@ -(* ***** 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 deleted file mode 100644 index b463c5077..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/fmmain.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/fmmain.pas b/components/flashfiler/sourcelaz/explorer/fmmain.pas deleted file mode 100644 index ce55a798f..000000000 --- a/components/flashfiler/sourcelaz/explorer/fmmain.pas +++ /dev/null @@ -1,1937 +0,0 @@ -{*********************************************************} -{* 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 (Idx<Screen.FormCount) and - (Screen.ActiveForm<>Screen.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 deleted file mode 100644 index f25c3f7ab..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/fmprog.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/fmprog.pas b/components/flashfiler/sourcelaz/explorer/fmprog.pas deleted file mode 100644 index 754b151e1..000000000 --- a/components/flashfiler/sourcelaz/explorer/fmprog.pas +++ /dev/null @@ -1,99 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index a6366237c..000000000 Binary files a/components/flashfiler/sourcelaz/explorer/fmstruct.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/explorer/fmstruct.pas b/components/flashfiler/sourcelaz/explorer/fmstruct.pas deleted file mode 100644 index 20d4339c3..000000000 --- a/components/flashfiler/sourcelaz/explorer/fmstruct.pas +++ /dev/null @@ -1,3552 +0,0 @@ -{*********************************************************} -{* 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('<none>'); - 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 deleted file mode 100644 index ec55aa1af..000000000 --- a/components/flashfiler/sourcelaz/explorer/uReportEngineInterface.pas +++ /dev/null @@ -1,112 +0,0 @@ -(* ***** 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 deleted file mode 100644 index 9075822da..000000000 --- a/components/flashfiler/sourcelaz/explorer/ubase.pas +++ /dev/null @@ -1,253 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index fff1494ab..000000000 --- a/components/flashfiler/sourcelaz/explorer/uconfig.pas +++ /dev/null @@ -1,638 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index bcd4adad1..000000000 --- a/components/flashfiler/sourcelaz/explorer/uconsts.pas +++ /dev/null @@ -1,85 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 453b2669d..000000000 --- a/components/flashfiler/sourcelaz/explorer/uelement.pas +++ /dev/null @@ -1,522 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index d39ede486..000000000 --- a/components/flashfiler/sourcelaz/explorer/uentity.pas +++ /dev/null @@ -1,1177 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 171e5b48c..000000000 --- a/components/flashfiler/sourcelaz/explorer/usqlcfg.pas +++ /dev/null @@ -1,195 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index bf42ffec7..000000000 --- a/components/flashfiler/sourcelaz/ffabout.dfm +++ /dev/null @@ -1,1281 +0,0 @@ -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 deleted file mode 100644 index fda4f4ed4..000000000 --- a/components/flashfiler/sourcelaz/ffabout.lrs +++ /dev/null @@ -1,1749 +0,0 @@ -{ 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 deleted file mode 100644 index cc96666fd..000000000 --- a/components/flashfiler/sourcelaz/ffabout.pas +++ /dev/null @@ -1,132 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 6a38f862d..000000000 --- a/components/flashfiler/sourcelaz/ffclbase.pas +++ /dev/null @@ -1,78 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 178e6719d..000000000 --- a/components/flashfiler/sourcelaz/ffclbde.pas +++ /dev/null @@ -1,287 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index b352a49fd..000000000 --- a/components/flashfiler/sourcelaz/ffclcfg.inc +++ /dev/null @@ -1,57 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index b4106ca70..000000000 --- a/components/flashfiler/sourcelaz/ffclcfg.pas +++ /dev/null @@ -1,338 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index cf029b211..000000000 --- a/components/flashfiler/sourcelaz/ffclcnst.rc +++ /dev/null @@ -1,31 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index 82fdb94a2..000000000 Binary files a/components/flashfiler/sourcelaz/ffclcnst.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffclcnst.srm b/components/flashfiler/sourcelaz/ffclcnst.srm deleted file mode 100644 index 11ffc6a78..000000000 Binary files a/components/flashfiler/sourcelaz/ffclcnst.srm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffclcnst.str b/components/flashfiler/sourcelaz/ffclcnst.str deleted file mode 100644 index e23f6f4e4..000000000 --- a/components/flashfiler/sourcelaz/ffclcnst.str +++ /dev/null @@ -1,56 +0,0 @@ -;********************************************************* -;* 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 deleted file mode 100644 index 13b4d8aa7..000000000 --- a/components/flashfiler/sourcelaz/ffclcoln.dfm +++ /dev/null @@ -1,30 +0,0 @@ -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 deleted file mode 100644 index f398628b9..000000000 --- a/components/flashfiler/sourcelaz/ffclcoln.pas +++ /dev/null @@ -1,346 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index ecdb3c1d2..000000000 --- a/components/flashfiler/sourcelaz/ffclconv.pas +++ /dev/null @@ -1,1072 +0,0 @@ -{*********************************************************} -{* 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: - <days>.<timefraction>; 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: - <days>.<timefraction>; 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 deleted file mode 100644 index 29f4ed93e..000000000 --- a/components/flashfiler/sourcelaz/ffclexps.dfm +++ /dev/null @@ -1,61 +0,0 @@ -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 deleted file mode 100644 index 0773906c1..000000000 --- a/components/flashfiler/sourcelaz/ffclexps.pas +++ /dev/null @@ -1,79 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index a0f3158f2..000000000 --- a/components/flashfiler/sourcelaz/ffclexpt.pas +++ /dev/null @@ -1,1058 +0,0 @@ -{*********************************************************} -{* 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 <Classes.hpp>'); - WriteLn('#include <Controls.hpp>'); - WriteLn('#include <StdCtrls.hpp>'); - WriteLn('#include <Forms.hpp>'); - 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 <vcl.h>'); - 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<TffBaseServerEngine*>(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<TffLoggableComponent*>(Components[Inx]);'); - WriteLn(' aTransport = dynamic_cast<TffBaseTransport*>(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<TffServerEngine*>(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<TffBaseServerEngine*>(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<TffBaseServerEngine*>(Components[Inx]);'); - WriteLn(' aPlugin = dynamic_cast<TffBasePluginEngine*>(Components[Inx]);'); - WriteLn(' aStateCmp = dynamic_cast<TffStateComponent*>(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<TffBaseServerEngine*>(Components[Inx]);'); - WriteLn(' aPlugin = dynamic_cast<TffBasePluginEngine*>(Components[Inx]);'); - WriteLn(' aStateCmp = dynamic_cast<TffStateComponent*>(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<TffBaseServerEngine*>(Components[Inx]);'); - WriteLn(' aPlugin = dynamic_cast<TffBasePluginEngine*>(Components[Inx]);'); - WriteLn(' aStateCmp = dynamic_cast<TffStateComponent*>(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 deleted file mode 100644 index 69fbdd69c..000000000 --- a/components/flashfiler/sourcelaz/ffclfldg.dfm +++ /dev/null @@ -1,144 +0,0 @@ -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 deleted file mode 100644 index 2bbe69a1b..000000000 --- a/components/flashfiler/sourcelaz/ffclfldg.pas +++ /dev/null @@ -1,340 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index dbf31bce3..000000000 --- a/components/flashfiler/sourcelaz/ffclimex.pas +++ /dev/null @@ -1,1603 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 3e5a8f8df..000000000 --- a/components/flashfiler/sourcelaz/ffclintf.pas +++ /dev/null @@ -1,349 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 462208ab4..000000000 --- a/components/flashfiler/sourcelaz/ffclplug.pas +++ /dev/null @@ -1,171 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 2b605b766..000000000 Binary files a/components/flashfiler/sourcelaz/ffclreg.dcr and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffclreg.pas b/components/flashfiler/sourcelaz/ffclreg.pas deleted file mode 100644 index 09231f0a1..000000000 --- a/components/flashfiler/sourcelaz/ffclreg.pas +++ /dev/null @@ -1,832 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 095d07d58..000000000 Binary files a/components/flashfiler/sourcelaz/ffclreg_original.dcr and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffclreng.pas b/components/flashfiler/sourcelaz/ffclreng.pas deleted file mode 100644 index 517d9ca0c..000000000 --- a/components/flashfiler/sourcelaz/ffclreng.pas +++ /dev/null @@ -1,6751 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 9328a60b6..000000000 --- a/components/flashfiler/sourcelaz/ffclsqle.dfm +++ /dev/null @@ -1,335 +0,0 @@ -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 deleted file mode 100644 index 74ef53be0..000000000 --- a/components/flashfiler/sourcelaz/ffclsqle.pas +++ /dev/null @@ -1,178 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index bec9adebb..000000000 --- a/components/flashfiler/sourcelaz/ffcltbrg.pas +++ /dev/null @@ -1,227 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index b1be00117..000000000 --- a/components/flashfiler/sourcelaz/ffclver.pas +++ /dev/null @@ -1,81 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 97142b96b..000000000 --- a/components/flashfiler/sourcelaz/ffcomms/ffcomms.dpr +++ /dev/null @@ -1,46 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 62701ce3e..000000000 --- a/components/flashfiler/sourcelaz/ffcomms/ffcomms.rc +++ /dev/null @@ -1,112 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index 043426327..000000000 Binary files a/components/flashfiler/sourcelaz/ffcomms/ffcomms.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffcomms/uffcomms.dfm b/components/flashfiler/sourcelaz/ffcomms/uffcomms.dfm deleted file mode 100644 index 4b2d84a9c..000000000 Binary files a/components/flashfiler/sourcelaz/ffcomms/uffcomms.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffcomms/uffcomms.pas b/components/flashfiler/sourcelaz/ffcomms/uffcomms.pas deleted file mode 100644 index 5e5f4bbfb..000000000 --- a/components/flashfiler/sourcelaz/ffcomms/uffcomms.pas +++ /dev/null @@ -1,272 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 6006d64b5..000000000 --- a/components/flashfiler/sourcelaz/ffconst.inc +++ /dev/null @@ -1,429 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 582cd71c5..000000000 --- a/components/flashfiler/sourcelaz/ffconst.pas +++ /dev/null @@ -1,40 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 1bcd6b6ca..000000000 --- a/components/flashfiler/sourcelaz/ffconvff.pas +++ /dev/null @@ -1,959 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index f87b70f3f..000000000 --- a/components/flashfiler/sourcelaz/ffdb.pas +++ /dev/null @@ -1,10350 +0,0 @@ -{*********************************************************} -{* 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: - :<contiguous text> - :"<text>" (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 deleted file mode 100644 index ee69704b8..000000000 --- a/components/flashfiler/sourcelaz/ffdbbase.pas +++ /dev/null @@ -1,1151 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index c92837014..000000000 --- a/components/flashfiler/sourcelaz/ffdbcnst.rc +++ /dev/null @@ -1,31 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index 7aa7a5492..000000000 Binary files a/components/flashfiler/sourcelaz/ffdbcnst.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffdbcnst.srm b/components/flashfiler/sourcelaz/ffdbcnst.srm deleted file mode 100644 index 6578bba2c..000000000 Binary files a/components/flashfiler/sourcelaz/ffdbcnst.srm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffdbcnst.str b/components/flashfiler/sourcelaz/ffdbcnst.str deleted file mode 100644 index d09024530..000000000 --- a/components/flashfiler/sourcelaz/ffdbcnst.str +++ /dev/null @@ -1,578 +0,0 @@ -;********************************************************* -;* 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 deleted file mode 100644 index a00e0c4d9..000000000 --- a/components/flashfiler/sourcelaz/ffdefine.inc +++ /dev/null @@ -1,347 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 632b20860..000000000 --- a/components/flashfiler/sourcelaz/ffdscnst.inc +++ /dev/null @@ -1,96 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 1a05fafbf..000000000 --- a/components/flashfiler/sourcelaz/ffdscnst.rc +++ /dev/null @@ -1,31 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index 95bb4c6ca..000000000 Binary files a/components/flashfiler/sourcelaz/ffdscnst.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffdscnst.srm b/components/flashfiler/sourcelaz/ffdscnst.srm deleted file mode 100644 index 54e762834..000000000 Binary files a/components/flashfiler/sourcelaz/ffdscnst.srm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffdscnst.str b/components/flashfiler/sourcelaz/ffdscnst.str deleted file mode 100644 index c2a63b7f3..000000000 --- a/components/flashfiler/sourcelaz/ffdscnst.str +++ /dev/null @@ -1,92 +0,0 @@ -;********************************************************* -;* 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, "<nil pointer>" -ffdse_UnnamedInst, "<unnamed %s instance>" -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 deleted file mode 100644 index 4d0ef330a..000000000 --- a/components/flashfiler/sourcelaz/ffdtmsgq.pas +++ /dev/null @@ -1,589 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index a94e5c2e0..000000000 --- a/components/flashfiler/sourcelaz/fffile.inc +++ /dev/null @@ -1,300 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 8be8b80cf..000000000 --- a/components/flashfiler/sourcelaz/fffile.pas +++ /dev/null @@ -1,415 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 87664ea50..000000000 --- a/components/flashfiler/sourcelaz/ffhash.pas +++ /dev/null @@ -1,985 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index ff68c6431..000000000 --- a/components/flashfiler/sourcelaz/ffllbase.pas +++ /dev/null @@ -1,7094 +0,0 @@ -{*********************************************************} -{* 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 a<b, 0 if equal, +ve number if a>b; a,b unsigned 8-bit} -function FFCmpDW(const a, b : TffWord32) : integer; - {-return -ve number if a<b, 0 if equal, +ve number if a>b; a,b unsigned 32-bit} -function FFCmpI(a, b : integer) : integer; - {-return -ve number if a<b, 0 if equal, +ve number if a>b; a,b signed integers} -function FFCmpI16(a, b : smallint) : integer; - {-return -ve number if a<b, 0 if equal, +ve number if a>b; a,b signed 16-bit} -function FFCmpI32(a, b : Longint) : integer; - {-return -ve number if a<b, 0 if equal, +ve number if a>b; a,b signed 32-bit} -function FFCmpI8(a, b : shortint) : integer; - {-return -ve number if a<b, 0 if equal, +ve number if a>b; a,b signed 8-bit} -function FFCmpW(a, b : TffWord16) : integer; - {-return -ve number if a<b, 0 if equal, +ve number if a>b; a,b unsigned 16-bit} -function FFCmpBytes(const a, b : PffByteArray; MaxLen : integer) : integer; - {-return -ve number if a<b, 0 if equal, +ve number if a>b; a,b byte arrays} - { At most MaxLen bytes are compared} -function FFCmpShStr(const a, b : TffShStr; MaxLen : byte) : integer; - {-return -ve number if a<b, 0 if equal, +ve number if a>b; a,b short strings} - { At most MaxLen characters are compared} -function FFCmpShStrUC(const a, b : TffShStr; MaxLen : byte) : integer; - {-return -ve number if a<b, 0 if equal, +ve number if a>b; a,b short strings, case insensitive} - { At most MaxLen characters are compared} -function FFCmpI64(const a, b : TffInt64) : integer; - {-return -ve number if a<b, 0 if equal, +ve number if a>b; 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[<pool index>] * 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 + (<pool index> - 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 deleted file mode 100644 index 32af5d054..000000000 --- a/components/flashfiler/sourcelaz/ffllcnst.rc +++ /dev/null @@ -1,32 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index e5702a129..000000000 Binary files a/components/flashfiler/sourcelaz/ffllcnst.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffllcnst.srm b/components/flashfiler/sourcelaz/ffllcnst.srm deleted file mode 100644 index 7b3c3027a..000000000 Binary files a/components/flashfiler/sourcelaz/ffllcnst.srm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffllcnst.str b/components/flashfiler/sourcelaz/ffllcnst.str deleted file mode 100644 index 516b40e30..000000000 --- a/components/flashfiler/sourcelaz/ffllcnst.str +++ /dev/null @@ -1,96 +0,0 @@ -;********************************************************* -;* 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 deleted file mode 100644 index dd23db9de..000000000 --- a/components/flashfiler/sourcelaz/ffllcoll.pas +++ /dev/null @@ -1,265 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 98435cc48..000000000 --- a/components/flashfiler/sourcelaz/ffllcomm.pas +++ /dev/null @@ -1,1946 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index e77620a07..000000000 --- a/components/flashfiler/sourcelaz/ffllcomp.pas +++ /dev/null @@ -1,559 +0,0 @@ -{*********************************************************} -{* 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[<current state>, <target state>]; - } - 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 deleted file mode 100644 index 63cbe8173..000000000 --- a/components/flashfiler/sourcelaz/fflldate.pas +++ /dev/null @@ -1,295 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 95d7572ea..000000000 --- a/components/flashfiler/sourcelaz/fflldict.pas +++ /dev/null @@ -1,2205 +0,0 @@ -{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 deleted file mode 100644 index 4d8c681ae..000000000 --- a/components/flashfiler/sourcelaz/fflleng.pas +++ /dev/null @@ -1,1223 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index b4e2f2c95..000000000 --- a/components/flashfiler/sourcelaz/ffllexcp.pas +++ /dev/null @@ -1,148 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 09acc4065..000000000 --- a/components/flashfiler/sourcelaz/ffllgrid.pas +++ /dev/null @@ -1,358 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 10bb5eea5..000000000 --- a/components/flashfiler/sourcelaz/fflllgcy.pas +++ /dev/null @@ -1,1809 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 3a34938e6..000000000 --- a/components/flashfiler/sourcelaz/fflllog.pas +++ /dev/null @@ -1,544 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 14ab54fdf..000000000 --- a/components/flashfiler/sourcelaz/ffllprot.pas +++ /dev/null @@ -1,2993 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 9f799d26b..000000000 --- a/components/flashfiler/sourcelaz/ffllreq.pas +++ /dev/null @@ -1,355 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index fe37b7b39..000000000 --- a/components/flashfiler/sourcelaz/ffllscst.inc +++ /dev/null @@ -1,46 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index d34281cc3..000000000 --- a/components/flashfiler/sourcelaz/ffllscst.rc +++ /dev/null @@ -1,30 +0,0 @@ -/********************************************************* - * 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 deleted file mode 100644 index 7079baafd..000000000 Binary files a/components/flashfiler/sourcelaz/ffllscst.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffllscst.srm b/components/flashfiler/sourcelaz/ffllscst.srm deleted file mode 100644 index 60a098be7..000000000 Binary files a/components/flashfiler/sourcelaz/ffllscst.srm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffllscst.str b/components/flashfiler/sourcelaz/ffllscst.str deleted file mode 100644 index 5473581ac..000000000 --- a/components/flashfiler/sourcelaz/ffllscst.str +++ /dev/null @@ -1,42 +0,0 @@ -;********************************************************* -;* 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, "<nil pointer>" -ffsce_UnnamedInst, "<unnamed %s instance>" -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 deleted file mode 100644 index 79eea56bf..000000000 --- a/components/flashfiler/sourcelaz/fflltemp.pas +++ /dev/null @@ -1,828 +0,0 @@ -{*********************************************************} -{* 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 = <file size> div <block size> - # 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 = <file size> div <block size> - # 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 deleted file mode 100644 index 38d09e0eb..000000000 --- a/components/flashfiler/sourcelaz/ffllthrd.pas +++ /dev/null @@ -1,766 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 0458e6e78..000000000 --- a/components/flashfiler/sourcelaz/ffllunc.pas +++ /dev/null @@ -1,150 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index f1f08c035..000000000 --- a/components/flashfiler/sourcelaz/ffllwsck.pas +++ /dev/null @@ -1,1383 +0,0 @@ -{*********************************************************} -{* 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('<ALL INTERFACES>'); - 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 deleted file mode 100644 index a67160615..000000000 --- a/components/flashfiler/sourcelaz/ffllwsct.inc +++ /dev/null @@ -1,107 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index d58a9bcfc..000000000 --- a/components/flashfiler/sourcelaz/ffllwsct.pas +++ /dev/null @@ -1,86 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 1186b300e..000000000 --- a/components/flashfiler/sourcelaz/fflogdlg.dfm +++ /dev/null @@ -1,71 +0,0 @@ -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 deleted file mode 100644 index fad91437a..000000000 --- a/components/flashfiler/sourcelaz/fflogdlg.pas +++ /dev/null @@ -1,129 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 335225db0..000000000 --- a/components/flashfiler/sourcelaz/ffnetmsg.pas +++ /dev/null @@ -1,1215 +0,0 @@ -{*********************************************************} -{* 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 deleted file mode 100644 index 315a5efd1..000000000 --- a/components/flashfiler/sourcelaz/ffsql.atg +++ /dev/null @@ -1,1524 +0,0 @@ -$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> - (. fRootNode.TableExp := TableExp; .) - END - | - InsertStatement <fRootNode, InsertSt> - (. fRootNode.Insert := InsertSt; .) - | - UpdateStatement <fRootNode, UpdateSt> - (. fRootNode.Update := UpdateSt; .) - | - DeleteStatement <fRootNode, DeleteSt> - (. fRootNode.Delete := DeleteSt; .) - ) - - [ ";" ] - (. if fCurrentInputSymbol <> EOFSYMB then - SynError(200); - Final; .) - . - -SelectStatement <Parent: TFFSqlNode; - var Select : TFFSqlSELECT> - (. 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> - (. Select.SelectionList := SelectionList; .) - ) - "FROM" TableRefList <Select, TableRefList> - (. Select.TableRefList := TableRefList; .) - [ "WHERE" - (. Select.InWhere := True; .) - CondExp <Select, CondExp> - (. Select.CondExpWhere := CondExp; .) - (. Select.InWhere := False; .) - ] - ["GROUP" "BY" - GroupColumnList <Select, GroupColumnList> - (. Select.GroupColumnList := GroupColumnList; .) - ] - ["HAVING" CondExp <Select, CondExp> - (. Select.CondExpHaving := CondExp; .) - ] - ["ORDER" "BY" OrderList - <Select, OrderList> (.Select.OrderList := OrderList; .) - ] - . - -InsertStatement <Parent: TFFSqlNode; - var InsertSt : TFFSqlINSERT> - (. var aSQLName: string; - var InsertColumnList: TffSqlInsertColumnList; - var TableExp: TffSqlTableExp; - .) - = - "INSERT" "INTO" (. InsertSt := TFFSqlINSERT.Create(Parent); .) - SQLName<aSQLName> (. InsertSt.TableName := aSQLName; .) - ( "DEFAULT" "VALUES" (. InsertSt.DefaultValues := True; .) - | - IF IsColumnList THEN - BEGIN - '(' - InsertColumnList<InsertSt, InsertColumnList> - (. InsertSt.InsertColumnList := InsertColumnList; .) - ')' - TableExp<InsertSt, TableExp> (. InsertSt.TableExp := TableExp; .) - END - | - TableExp<InsertSt, TableExp> (. InsertSt.TableExp := TableExp; .) - ) - . - -TableExp<Parent:TffSqlNode; var TableExp: TffSqlTableExp> - (. 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, TableRef> - (. JoinTableExp.TableRef1 := TableRef; .) - - JoinTableExp<TableExp, 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<TableExp, JoinTableExp> - END_REPEAT - END - - | - NonJoinTableExp<TableExp, NonJoinTableExp> - (. TableExp.NonJoinTableExp := NonJoinTableExp; .) - | - '(' - TableExp<TableExp, NestedTableExp> - (. TableExp.NestedTableExp := NestedTableExp; .) - ')' - ) - . - -JoinTableExp<Parent:TffSqlNode; const JoinTableExp: TffSqlJoinTableExp> - (. - var TableRef: TffSqlTableRef; - var CondExp: TFFSqlCondExp; - var UsingList : TFFSqlUsingList; - .) - = - ( - ( - "CROSS" "JOIN" TableRef<JoinTableExp, 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, TableRef> - (. JoinTableExp.TableRef2 := TableRef; .) - [ ( - ("ON" CondExp<JoinTableExp, CondExp> - (. JoinTableExp.CondExp := CondExp; .) - ) - | ("USING" "(" UsingList<JoinTableExp, UsingList> - ")" (. JoinTableExp.UsingList := UsingList; .) - ) - ) - ] - ) - ) - . - -UsingList <Parent: TFFSqlNode; - var UsingList : TFFSqlUsingList> - (. var UsingItem : TFFSqlUsingItem; .) - = (. UsingList := TFFSqlUsingList.Create(Parent); .) - UsingItem <UsingList, UsingItem> - (. UsingList.AddItem(UsingItem); .) - { "," UsingItem<UsingList, UsingItem> - (. UsingList.AddItem(UsingItem); .) - } - . - -UsingItem <Parent: TFFSqlNode; - var UsingItem : TFFSqlUsingItem> - (. var aSQLName: string; .) - = (. UsingItem := TFFSqlUsingItem.Create(Parent); .) - SQLName <aSQLName> - (. UsingItem.ColumnName := aSQLName; .) - . - -NonJoinTableExp<Parent:TffSqlNode; var NonJoinTableExp: TffSqlNonJoinTableExp> - (. var NonJoinTableTerm: TffSqlNonJoinTableTerm; .) - = (. NonJoinTableExp := TffSqlNonJoinTableExp.Create(Parent); .) - NonJoinTableTerm<NonJoinTableExp, NonJoinTableTerm> - (. NonJoinTableExp.NonJoinTableTerm := NonJoinTableTerm; .) - . - -NonJoinTableTerm<Parent:TffSqlNode; var NonJoinTableTerm: TffSqlNonJoinTableTerm> - (. var NonJoinTablePrimary: TffSqlNonJoinTablePrimary; .) - = (. NonJoinTableTerm := TffSqlNonJoinTableTerm.Create(Parent); .) - NonJoinTablePrimary<NonJoinTableTerm, NonJoinTablePrimary> - (. NonJoinTableTerm.NonJoinTablePrimary := NonJoinTablePrimary; .) - . - -NonJoinTablePrimary<Parent: TffSqlNode; var NonJoinTablePrimary: TffSqlNonJoinTablePrimary> - (. var ValueList: TffSqlValueList; - var NonJoinTableExp: TffSqlNonJoinTableExp; - var TableRef: TffSqlTableRef; - var SelectSt: TFFSqlSELECT; .) - = - (. NonJoinTablePrimary := TffSqlNonJoinTablePrimary.Create(Parent); .) - ( - IF IsParenNonJoinTableExp THEN - BEGIN - "(" NonJoinTableExp<NonJoinTablePrimary, NonJoinTableExp> - (. NonJoinTablePrimary.NonJoinTableExp := NonJoinTableExp; .) - ")" - END - | - SelectStatement<NonJoinTablePrimary, SelectSt> (. NonJoinTablePrimary.SelectSt := SelectSt; .) - | - "TABLE" TableRef<NonJoinTablePrimary, TableRef> (. NonJoinTablePrimary.TableRef := TableRef; .) - | - TableConstructor<NonJoinTablePrimary, ValueList> (. NonJoinTablePrimary.ValueList := ValueList; .) - ) - . - -TableConstructor<Parent: TFFSqlNode; var ValueList: TffSqlValueList> - = - "VALUES" "(" ValueList<Parent, ValueList> ")" - . - -InsertColumnList<Parent: TFFSqlNode; - var InsertColumnList : TFFSqlInsertColumnList> - (. var InsertItem : TFFSqlInsertItem; .) - = (. InsertColumnList := TFFSqlInsertColumnList.Create(Parent); .) - InsertItem <InsertColumnList, InsertItem> - (. InsertColumnList.AddItem(InsertItem); .) - { "," InsertItem <InsertColumnList, InsertItem> - (. InsertColumnList.AddItem(InsertItem); .) - } - . - -InsertItem <Parent: TFFSqlNode; - var InsertItem : TFFSqlInsertItem> - (. var aSQLName: string; .) - = (. InsertItem := TFFSqlInsertItem.Create(Parent); .) - SQLName <aSQLName> (. InsertItem.ColumnName := aSQLName; .) - . - -ValueList<Parent: TFFSqlNode; - var ValueList : TFFSqlValueList> - (. var ValueItem : TFFSqlValueItem; .) - = (. ValueList := TFFSqlValueList.Create(Parent); .) - ValueItem <ValueList, ValueItem> - (. ValueList.AddItem(ValueItem); .) - { "," ValueItem <ValueList, ValueItem> - (. ValueList.AddItem(ValueItem); .) - } - . - -ValueItem <Parent: TFFSqlNode; - var ValueItem : TFFSqlValueItem> - (. - var Simplex : TFFSqlSimpleExpression; .) - = (. ValueItem := TFFSqlValueItem.Create(Parent); .) - ( - "DEFAULT" (. ValueItem.Default := True; .) - | - "NULL" - | - SimpleExpression<ValueItem, Simplex> (. ValueItem.Simplex := Simplex; .) - ) - . - - -DeleteStatement <Parent: TFFSqlNode; - var DeleteSt : TFFSqlDELETE> - (. var TableRef: TffSqlTableRef; - var CondExp: TFFSqlCondExp; .) - = - "DELETE" "FROM" (. DeleteSt := TFFSqlDELETE.Create(Parent); .) - SimpleTableRef<DeleteSt, TableRef> (. DeleteSt.TableRef := TableRef; .) - [ "WHERE" - CondExp <DeleteSt, CondExp> - (. DeleteSt.CondExpWhere := CondExp; .) - ] - . - -UpdateStatement <Parent: TFFSqlNode; - var UpdateSt : TFFSqlUPDATE> - (. var TableRef: TffSqlTableRef; - var CondExp: TFFSqlCondExp; - var UpdateList: TFFSqlUpdateList; .) - = - "UPDATE" (. UpdateSt := TFFSqlUPDATE.Create(Parent); .) - SimpleTableRef<UpdateSt, TableRef> (. UpdateSt.TableRef := TableRef; .) - "SET" UpdateList<UpdateSt, UpdateList> - (. UpdateSt.UpdateList := UpdateList; .) - [ "WHERE" - CondExp <UpdateSt, CondExp> - (. UpdateSt.CondExpWhere := CondExp; .) - ] - . - -UpdateList <Parent: TFFSqlNode; - var UpdateList : TFFSqlUpdateList> - (. var UpdateItem : TFFSqlUpdateItem; .) - = (. UpdateList := TFFSqlUpdateList.Create(Parent); .) - UpdateItem <UpdateList, UpdateItem> - (. UpdateList.AddItem(UpdateItem); .) - { "," UpdateItem <UpdateList, UpdateItem> - (. UpdateList.AddItem(UpdateItem); .) - } - . - -UpdateItem <Parent: TFFSqlNode; - var UpdateItem : TFFSqlUpdateItem> - (. var Simplex : TFFSqlSimpleExpression; - var aSQLName : string; .) - = (. UpdateItem := TFFSqlUpdateItem.Create(Parent); .) - SQLName <aSQLName> (. UpdateItem.ColumnName := aSQLName; .) - "=" - ( "DEFAULT" (. UpdateItem.Default := True; .) - | "NULL" - | SimpleExpression<UpdateItem, Simplex> (. UpdateItem.Simplex := Simplex; .) - ) - . - -OrderList <Parent: TFFSqlNode; - var OrderList : TFFSqlOrderList> - (. var OrderItem : TFFSqlOrderItem; .) - = (. OrderList := TFFSqlOrderList.Create(Parent); .) - OrderItem <OrderList, OrderItem> - (. OrderList.AddOrderItem(OrderItem); .) - { "," OrderItem <OrderList, OrderItem> - (. OrderList.AddOrderItem(OrderItem); .) - } - . - -OrderItem <Parent: TFFSqlNode; - var OrderItem : TFFSqlOrderItem> - (. var OrderColumn : TFFSqlOrderColumn; .) - = (. OrderItem := TFFSqlOrderItem.Create(Parent); .) - ( OrderColumn <OrderItem, OrderColumn> - (. OrderItem.Column := OrderColumn; .) - | integer_ (. OrderItem.Index := LexString; .) - ) - [ "ASC" - | "DESC" (. OrderItem.Descending := True; .) - ] - . - -OrderColumn <Parent: TFFSqlNode; var Col : TFFSqlOrderColumn> - (. var - aSQLName : string; .) - = - (. Col := TFFSqlOrderColumn.Create(Parent); - aSQLName := ''; .) - ( SQLName <aSQLName> - - [ "." (. Col.TableName := aSQLName; - aSQLName := ''; .) - SQLName <aSQLName> - ] - ) (. Col.FieldName := aSQLName; .) - . - -SelectionList <Parent: TFFSqlSELECT; var SelectionList: TFFSqlSelectionList> - = - (. SelectionList := TFFSqlSelectionList.Create(Parent); .) - Selection <SelectionList> - {"," Selection<SelectionList> } - . - -Selection <SelectionList: TFFSqlSelectionList> - (. 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, Exp> - (. Selection.SimpleExpression := Exp; .) - [ ColumnAlias<Selection> - ] - ) - (. SelectionList.AddSelection(Selection); .) - . - -ColumnAlias<var Selection : TFFSqlSelection> - (. var Col : TFFSqlColumn;.) = - ["AS"] - Column <Selection, Col> - (. Selection.Column := Col; .) - . - -Aggregate <Parent: TFFSqlNode; var Aggregate : TFFSqlAggregate> - (. 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> - (.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> - (. Aggregate.SimpleExpression := SimpleExpression; - if Aggregate.SimpleExpression.IsAggregateExpression then - SynError(201); .) - ")" - ) - ) - - . - -FieldRef <Parent: TFFSqlNode; var FieldRef: TFFSqlFieldRef> - (. var - aSQLName : string; .) - = - (. FieldRef := TFFSqlFieldRef.Create(Parent); - aSQLName := ''; .) - ( - ( SQLName <aSQLName> - [ "." (. FieldRef.TableName := aSQLName; .) - ( SQLName <aSQLName> - | "*" (. aSQLName := ''; .) - ) - ] - ) - ) (. FieldRef.FieldName := aSQLName; .) - . - -GroupColumnList <Parent: TFFSqlNode; - var ColumnList : TFFSqlGroupColumnList> - (. var Col : TFFSqlGroupColumn; .) - = (. ColumnList := TFFSqlGroupColumnList.Create(Parent); .) - GroupColumn <Parent, Col> - (. ColumnList.AddColumn(Col); .) - { "," - GroupColumn <Parent, Col> - (. ColumnList.AddColumn(Col); .) - } - . - - -Column <Parent: TFFSqlNode; - var Col : TFFSqlColumn> - (. var ColumnName : string; .) - = - (. Col := TFFSqlColumn.Create(Parent); .) - // allow for quoted strings with spaces - SQLName<ColumnName> (. Col.ColumnName := ColumnName; .) - . - - -GroupColumn <Parent: TFFSqlNode; - var Col : TFFSqlGroupColumn> - (. var - aSQLName : string; .) - = (. Col := TFFSqlGroupColumn.Create(Parent); - aSQLName := ''; .) - ( SQLName <aSQLName> - - [ "." (. Col.TableName := aSQLName; .) - ( SQLName <aSQLName> ) - ] - ) (. Col.FieldName := aSQLName; .) - . - -CondExp <Parent: TFFSqlNode; - var CondExp: TFFSqlCondExp> - (. var CondTerm : TFFSqlCondTerm; .) - = (. CondExp := TFFSqlCondExp.Create(Parent); .) - CondTerm <CondExp, CondTerm> (. CondExp.AddCondTerm(CondTerm); .) - { "OR" - CondTerm <CondExp, CondTerm> (. CondExp.AddCondTerm(CondTerm); .) - } - . - -CondTerm <Parent: TFFSqlNode; - var CondTerm : TFFSqlCondTerm> - (. var CondFactor : TFFSqlCondFactor; .) - = (. CondTerm := TFFSqlCondTerm.Create(Parent); .) - CondFactor <CondTerm, CondFactor> - (. CondTerm.AddCondFactor(CondFactor); .) - { "AND" - CondFactor <CondTerm, CondFactor> - (. CondTerm.AddCondFactor(CondFactor); .) - } - . - -CondFactor <Parent: TFFSqlNode; - var CondFactor: TFFSqlCondFactor> - (. var CondPrimary : TFFSqlCondPrimary; .) - = (. CondFactor := TFFSqlCondFactor.Create(Parent); .) - ["NOT" (. CondFactor.UnaryNot := True; .) - ] - CondPrimary <CondFactor, CondPrimary> - (. CondFactor.CondPrimary := CondPrimary; .) - . - -CondPrimary <Parent: TFFSqlNode; - var CondPrimary : TFFSqlCondPrimary> - (. 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> - (. CondPrimary.ExistsClause := ExistsClause; .) - | - UniqueClause <CondPrimary, UniqueClause> - (. CondPrimary.UniqueClause := UniqueClause; .) - | - ( - SimpleExpression <CondPrimary, SimpleExpression> - (. CondPrimary.SimpleExp1 := SimpleExpression; .) - [ - ( - ("=" (. RelOp := roEQ; .) - | "<=" (. RelOp := roLE; .) - | "<" (. RelOp := roL; .) - | ">" (. RelOp := roG; .) - | ">=" (. RelOp := roGE; .) - | "<>" (. RelOp := roNE; .) - ) (. CondPrimary.RelOp := RelOp; .) - (AllOrAnyClause <CondPrimary, AllOrAny> - (. CondPrimary.AllOrAnyClause := AllOrAny; .) - | SimpleExpression<CondPrimary, SimpleExpression> - (. CondPrimary.SimpleExp2 := SimpleExpression; .) - ) - | BetweenClause <CondPrimary, BetweenClause, False> - (. CondPrimary.BetweenClause := BetweenClause; .) - | LikeClause <CondPrimary, LikeClause, False> - (. CondPrimary.LikeClause := LikeClause; .) - | InClause <CondPrimary, InClause, False> - (. CondPrimary.InClause := InClause; .) - | MatchClause <CondPrimary, MatchClause> - (. CondPrimary.MatchClause := MatchClause; .) - | "NOT" - ( - BetweenClause <CondPrimary, BetweenClause, True> - (. CondPrimary.BetweenClause := BetweenClause; .) - | LikeClause <CondPrimary, LikeClause, True> - (. CondPrimary.LikeClause := LikeClause; .) - | InClause <CondPrimary, InClause, True> - (. CondPrimary.InClause := InClause; .) - ) - ) - | IsTest<CondPrimary, IsTest> - (. CondPrimary.IsTest := IsTest; - CondPrimary.RelOp := RoNone; .) - ] - ) - ) - . - -AllOrAnyClause <Parent: TFFSqlNode; - var AllOrAny: TFFSqlAllOrAnyClause> - (. var Select : TFFSqlSelect; .) - = (. AllOrAny := TFFSqlAllOrAnyClause.Create(Parent); .) - ( "ALL" (. AllOrAny.All := True; .) - | "ANY" | "SOME" ) - - "(" - - SelectStatement <AllOrAny, Select> - (. AllOrAny.SubQuery := Select; .) - - ")" - . - -ExistsClause <Parent: TFFSqlNode; - var Exists: TFFSqlExistsClause> - (. var Select : TFFSqlSelect; .) - = (. Exists := TFFSqlExistsClause.Create(Parent); .) - "EXISTS" - "(" - SelectStatement <Exists, Select> - (. Exists.SubQuery := Select; .) - ")" - . - -UniqueClause <Parent: TFFSqlNode; - var Unique: TFFSqlUniqueClause> - //(. var Select : TFFSqlSelect; .) - (. var TableExp : TFFSqlTableExp; .) - = (. Unique := TFFSqlUniqueClause.Create(Parent); .) - "UNIQUE" "(" - TableExp<Unique, TableExp> - (. Unique.SubQuery := TableExp; .) - ")" - . - -IsTest <Parent: TFFSqlNode; - var IsTest: TFFSqlIsTest> - = - "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 <Parent: TFFSqlNode; - var BetweenClause: TFFSqlBetweenClause; - Negated: Boolean> - (. var SimpleExpression : TFFSqlSimpleExpression; .) - = (. BetweenClause := TFFSqlBetweenClause.Create(Parent); - BetweenClause.Negated := Negated; .) - "BETWEEN" SimpleExpression <BetweenClause, SimpleExpression> - (. BetweenClause.SimpleLow := SimpleExpression; .) - "AND" SimpleExpression <BetweenClause, SimpleExpression> - (. BetweenClause.SimpleHigh := SimpleExpression; .) - . - -LikeClause <Parent: TFFSqlNode; - var LikeClause: TFFSqlLikeClause; - Negated: Boolean> - (. var SimpleExpression : TFFSqlSimpleExpression; .) - = (. LikeClause := TFFSqlLikeClause.Create(Parent); .) - (. LikeClause.Negated := Negated; .) - "LIKE" SimpleExpression <LikeClause, SimpleExpression> - (. LikeClause.SimpleExp := SimpleExpression; .) - ["ESCAPE" SimpleExpression <LikeClause, SimpleExpression> - (. LikeClause.EscapeExp := SimpleExpression; .) - ] - ["IGNORE" "CASE" (. LikeClause.IgnoreCase := True; .) // !!.13 - ] - . - -InClause <Parent: TFFSqlNode; - var InClause: TFFSqlInClause; - Negated: Boolean> - (. var SimpleExpressionList : TFFSqlSimpleExpressionList; - var Select : TFFSqlSelect; .) - //var TableExp : TFFSqlTableExp; .) - = (. InClause := TFFSqlInClause.Create(Parent); .) - (. InClause.Negated := Negated; .) - "IN" "(" - ( - SelectStatement <InClause, Select> - (. InClause.SubQuery := Select; .) - | SimpleExpressionList <InClause, SimpleExpressionList> - (. Inclause.SimpleExpList := SimpleExpressionList; .) - ) - ")" - . - -MatchClause <Parent: TFFSqlNode; - var MatchClause: TFFSqlMatchClause> - (. 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, Select> - (. MatchClause.SubQuery := Select; .) - ")" - . - -SimpleExpressionList <Parent: TFFSqlNode; - var SimpleExpressionList: TFFSqlSimpleExpressionList> - (. var SimpleExpression : TFFSqlSimpleExpression; .) - = (. SimpleExpressionList := TFFSqlSimpleExpressionList.Create(Parent); .) - SimpleExpression <SimpleExpressionList, SimpleExpression> - (. SimpleExpressionList.AddExpression(SimpleExpression); .) - { "," - SimpleExpression <SimpleExpressionList, SimpleExpression> - (. SimpleExpressionList.AddExpression(SimpleExpression); .) - } - . - -SimpleExpression <Parent: TFFSqlNode; - var SimpleExpression : TFFSqlSimpleExpression> - (. var Term : TFFSqlTerm; - var AO : TFFSqlAddOp; .) - = (. SimpleExpression := TFFSqlSimpleExpression.Create(Parent); .) - Term <SimpleExpression, Term, aoPlus> - (. SimpleExpression.AddTerm(Term); .) - { - ("+" (. AO := aoPlus; .) - | - "-" (. AO := aoMinus; .) - | - "||" (. AO := aoConcat; .) - ) - Term <SimpleExpression, Term, AO> - (. SimpleExpression.AddTerm(Term); .) - } - . - -Term <Parent: TFFSqlNode; var Term : TFFSqlTerm; AddOp : TFFSqlAddOp> - (. var Factor : TFFSqlFactor; - var MO : TFFSqlMulOp; .) - = - (. Term := TFFSqlTerm.Create(Parent); - Term.AddOp := AddOp; .) - - Factor <Term, Factor, moMul> (. Term.AddFactor(Factor); .) - { ("*" (. MO := moMul; .) - | "/" (. MO := moDiv; .) - ) - Factor <Term, Factor, MO> (. Term.AddFactor(Factor); .) - } - . - -Factor <Parent: TFFSqlNode; - var Factor : TFFSqlFactor; - MulOp: TFFSqlMulOp> - (. 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> (. Factor.CondExp := CondExp; .) - | - SelectStatement <Factor, Select> - (. Factor.SubQuery := Select; .) - ) - ")" - ) - | FieldRef <Factor, FieldRef> - (. Factor.FieldRef := FieldRef; .) - | Literal <Factor, Literal> - (. Factor.Literal := Literal; .) - | Param <Factor, Param> (. Factor.Param := Param; .) - | Aggregate <Factor, Agg> - (. Factor.Aggregate := Agg; .) - | ScalarFunction <Factor, Func> - (. Factor.ScalarFunc := Func; .) - ) - . - -ScalarFunction <Parent: TFFSqlNode; - var Func: TFFSqlScalarFunc> - (. var Exp : TFFSqlSimpleExpression; - var CaseExp : TFFSqlCaseExpression; - var CoalesceExp : TFFSqlCoalesceExpression; .) - = (. Func := TFFSqlScalarFunc.Create(Parent); .) - ( - "CASE" - CaseExpression <Func, CaseExp> - (. Func.CaseExp := CaseExp; .) - (. Func.SQLFunction := sfCase; .) - | ("CHARACTER_LENGTH" - | "CHAR_LENGTH") - "(" SimpleExpression <Func, Exp> ")" - (. Func.SQLFunction := sfCharLen; .) - (. Func.Arg1 := Exp; .) - | "COALESCE" - CoalesceExpression <Func, CoalesceExp> - (. 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, Exp> ")" - (. Func.SQLFunction := sfLower; .) - (. Func.Arg1 := Exp .) - | "UPPER" - "(" - SimpleExpression <Func, Exp> ")" - (. Func.SQLFunction := sfUpper; - Func.Arg1 := Exp; .) - | "POSITION" - "(" - SimpleExpression <Func, Exp> - (. Func.SQLFunction := sfPosition; - Func.Arg1 := Exp; .) - ("," | "IN" ) - - SimpleExpression <Func, Exp> - (. Func.Arg2 := Exp; .) - ")" - | "SESSION_USER" (. Func.SQLFunction := sfSessionUser; .) - | "SUBSTRING" - "(" - SimpleExpression <Func, Exp> - (. Func.SQLFunction := sfSubstring; - Func.Arg1 := Exp; .) - "FROM" - SimpleExpression <Func, Exp> - (. Func.Arg2 := Exp; .) - [ "FOR" - SimpleExpression <Func, Exp> - (. 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, Exp> - (. Func.Arg1 := Exp; .)] - [ "FROM" - SimpleExpression <Func, Exp> - (. 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, Exp> - (. Func.Arg1 := Exp; .) - ")" - | "NULLIF" "(" (. Func.SQLFunction := sfNullIf; .) - SimpleExpression <Func, Exp> - (. Func.Arg1 := Exp; .) - "," SimpleExpression <Func, Exp> - (. Func.Arg2 := Exp; .) - ")" - | "ABS" "(" (. Func.SQLFunction := sfAbs; .) - SimpleExpression <Func, Exp> - (. Func.Arg1 := Exp; .) - ")" - | "CEILING" "(" (. Func.SQLFunction := sfCeil; .) - SimpleExpression <Func, Exp> - (. Func.Arg1 := Exp; .) - ")" - | "FLOOR" "(" (. Func.SQLFunction := sfFloor; .) - SimpleExpression <Func, Exp> - (. Func.Arg1 := Exp; .) - ")" - | "EXP" "(" (. Func.SQLFunction := sfExp; .) - SimpleExpression <Func, Exp> - (. Func.Arg1 := Exp; .) - ")" - | "LOG" "(" (. Func.SQLFunction := sfLog; .) - SimpleExpression <Func, Exp> - (. Func.Arg1 := Exp; .) - ")" - | "POWER" "(" (. Func.SQLFunction := sfPower; .) - SimpleExpression <Func, Exp> - (. Func.Arg1 := Exp; .) - "," SimpleExpression <Func, Exp> - (. Func.Arg2 := Exp; .) - ")" - | "RAND" (. Func.SQLFunction := sfRand; .) - | "ROUND" "(" (. Func.SQLFunction := sfRound; .) - SimpleExpression <Func, Exp> - (. Func.Arg1 := Exp; .) - ")" - ) - . - -CoalesceExpression <Parent: TFFSqlNode; - var CoalesceExp: TFFSqlCoalesceExpression> - (. var Exp : TFFSqlSimpleExpression; .) - = (. CoalesceExp := TFFSqlCoalesceExpression.Create(Parent); .) - "(" - SimpleExpression <CoalesceExp, Exp> - (. CoalesceExp.AddArg(Exp); .) - { "," SimpleExpression <CoalesceExp, Exp> - (. CoalesceExp.AddArg(Exp); .) - } - ")" - . - -CaseExpression <Parent: TFFSqlNode; - var CaseExp: TFFSqlCaseExpression> - (. var WhenClauseList : TFFSqlWhenClauseList; - var Exp : TFFSqlSimpleExpression; .) - = - (. CaseExp := TFFSqlCaseExpression.Create(Parent); .) - WhenClauseList <CaseExp, WhenClauseList> - (. CaseExp.WhenClauseList := WhenClauseList; .) - ["ELSE" - ("NULL" - | SimpleExpression <CaseExp, Exp> - (. CaseExp.ElseExp := Exp; .) - ) - ] - "END" - . - -WhenClauseList <Parent: TFFSqlNode; - var WhenClauseList : TFFSqlWhenClauseList> - (. var WhenClause : TFFSqlWhenClause; .) - = - (. WhenClauseList := TFFSqlWhenClauseList.Create(Parent); .) - WhenClause <WhenClauseList, WhenClause> - (. WhenClauseList.AddWhenClause(WhenClause); .) - { WhenClause <WhenClauseList, WhenClause> - (. WhenClauseList.AddWhenClause(WhenClause); .) } - . - -WhenClause <Parent : TFFSqlNode; - var WhenClause : TFFSqlWhenClause> - (. var CondExp : TFFSqlCondExp; - Exp : TFFSqlSimpleExpression; .) - = - (. WhenClause := TFFSqlWhenClause.Create(Parent); .) - "WHEN" CondExp <WhenClause, CondExp> - (. WhenClause.WhenExp := CondExp; .) - "THEN" - ("NULL" - | SimpleExpression <WhenClause, Exp> - (. WhenClause.ThenExp := Exp; .) - ) - . - -Param <Parent: TFFSqlNode; - var Param: TFFSqlParam> = - (. Param := TFFSqlParam.Create(Parent); .) - "?" - . - -Literal <Parent: TFFSqlNode; - var Literal: TFFSqlLiteral> - (. var FloatLiteral : TFFSqlFloatLiteral; - var IntegerLiteral : TFFSqlIntegerLiteral; - var StringLiteral : TFFSqlStringLiteral; - var DateLiteral : TFFSqlDateLiteral; - var TimeLiteral : TFFSqlTimeLiteral; - var TimestampLiteral : TFFSqlTimestampLiteral; - var IntervalLiteral : TFFSqlIntervalLiteral; - var BooleanLiteral : TFFSqlBooleanLiteral; .) - = (. Literal := TFFSqlLiteral.Create(Parent); .) - ( - FloatLiteral <Literal, FloatLiteral> - (. Literal.FloatLiteral := FloatLiteral; .) - | IntegerLiteral <Literal, IntegerLiteral> - (. Literal.IntegerLiteral := IntegerLiteral; .) - | StringLiteral <Literal, StringLiteral> - (. Literal.StringLiteral := StringLiteral; .) - | DateLiteral <Literal, DateLiteral> - (. Literal.DateLiteral := DateLiteral; .) - | TimeLiteral <Literal, TimeLiteral> - (. Literal.TimeLiteral := TimeLiteral; .) - | TimestampLiteral <Literal, TimestampLiteral> - (. Literal.TimestampLiteral := TimestampLiteral; .) - | IntervalLiteral <Literal, IntervalLiteral> - (. Literal.IntervalLiteral := IntervalLiteral; .) - | BooleanLiteral <Literal, BooleanLiteral> - (. Literal.BooleanLiteral := BooleanLiteral; .) - ) - . - -BooleanLiteral<Parent: TFFSqlNode; var BooleanLiteral: TFFSqlBooleanLiteral> - = (. BooleanLiteral := TFFSqlBooleanLiteral.Create(Parent); .) - ( - 'TRUE' (. BooleanLiteral.Value := True; .) - | - 'FALSE' - ) - . - -FloatLiteral <Parent: TFFSqlNode; - var FloatLiteral: TFFSqlFloatLiteral> - = (. FloatLiteral := TFFSqlFloatLiteral.Create(Parent); .) - float (. FloatLiteral.Value := LexString; .) - . - -IntegerLiteral <Parent: TFFSqlNode; - var IntegerLiteral: TFFSqlIntegerLiteral> - = (. IntegerLiteral := TFFSqlIntegerLiteral.Create(Parent); .) - integer_ (. IntegerLiteral.Value := LexString; .) - . - -StringLiteral <Parent: TFFSqlNode; - var StringLiteral: TFFSqlStringLiteral> - = (. StringLiteral := TFFSqlStringLiteral.Create(Parent); .) - SQLString (. StringLiteral.Value := LexString; .) - . - -DateLiteral <Parent: TFFSqlNode; - var DateLiteral: TFFSqlDateLiteral> - = (. DateLiteral := TFFSqlDateLiteral.Create(Parent); .) - "DATE" - SQLString (. DateLiteral.Value := LexString; .) - . - -TimeLiteral <Parent: TFFSqlNode; - var TimeLiteral: TFFSqlTimeLiteral> - = (. TimeLiteral := TFFSqlTimeLiteral.Create(Parent); .) - "TIME" - SQLString (. TimeLiteral.Value := LexString; .) - . - -TimestampLiteral <Parent: TFFSqlNode; - var TimestampLiteral: TFFSqlTimestampLiteral> - = (. TimestampLiteral := TFFSqlTimestampLiteral.Create(Parent); .) - "TIMESTAMP" - SQLString (. TimestampLiteral.Value := LexString; .) - . - -IntervalLiteral <Parent: TFFSqlNode; - var IntervalLiteral: TFFSqlIntervalLiteral> - = (. IntervalLiteral := TFFSqlIntervalLiteral.Create(Parent); .) - "INTERVAL" (. IntervalLiteral.StartDef := iUnspec; .) - SQLString (. IntervalLiteral.Value := LexString; .) - ("YEAR" (. IntervalLiteral.StartDef := iYear; .) - | "MONTH" (. IntervalLiteral.StartDef := iMonth; .) - | "DAY" (. IntervalLiteral.StartDef := iDay; .) - | "HOUR" (. IntervalLiteral.StartDef := iHour; .) - | "MINUTE" (. IntervalLiteral.StartDef := iMinute; .) - | "SECOND" (. IntervalLiteral.StartDef := iSecond; .) - ) - (. IntervalLiteral.EndDef := iUnspec; .) - ["TO" - ("YEAR" (. IntervalLiteral.EndDef := iYear; .) - | "MONTH" (. IntervalLiteral.EndDef := iMonth; .) - | "DAY" (. IntervalLiteral.EndDef := iDay; .) - | "HOUR" (. IntervalLiteral.EndDef := iHour; .) - | "MINUTE" (. IntervalLiteral.EndDef := iMinute; .) - | "SECOND" (. IntervalLiteral.EndDef := iSecond; .) - ) - ] - . - -TableRefList <Parent: TFFSqlNode; - var TableRefList: TFFSqlTableRefList> - (. var TableRef: TffSqlTableRef; .) - = (. TableRefList := TFFSqlTableRefList.Create(Parent); .) - TableRef <TableRefList, TableRef> (. TableRefList.AddTableRef(TableRef); .) - { "," TableRef <TableRefList, TableRef> (. TableRefList.AddTableRef(TableRef); .) - } - . - -SimpleTableRef<Parent: TFFSqlNode; var TableRef: TffSqlTableRef> - (. var aSQLName : string; .) - = (. TableRef := TFFSqlTableRef.Create(Parent); .) - SQLName <aSQLName> (. TableRef.TableName := aSQLName; .) - [ - "." SQLName <aSQLName> - // previous ident was really a database name - (. TableRef.DatabaseName := TableRef.TableName; TableRef.TableName := aSQLName; .) - ] - [ SimpleAlias<TableRef> - ] - . - -SimpleTableRefOrParenTableExp<Parent: TFFSqlNode; var TableRef: TffSqlTableRef> - (. var TableExp: TffSqlTableExp; - var aSQLName : string; .) - = (. TableRef := TFFSqlTableRef.Create(Parent); .) - ( - SQLName <aSQLName> (. TableRef.TableName := aSQLName; .) - [ - "." SQLName <aSQLName> - // previous ident was really a database name - (. TableRef.DatabaseName := TableRef.TableName; TableRef.TableName := aSQLName; .) - ] - [ SimpleAlias<TableRef> - ] - | - "(" - TableExp<TableRef, TableExp> - (. TableRef.TableExp := TableExp; .) - ")" - [ SimpleAlias<TableRef> - ] - ) - . - -TableRef<Parent: TFFSqlNode; var TableRef: TffSqlTableRef> - (. var aSQLName : string; - var TableExp: TffSqlTableExp; - var ColumnList : TFFSqlInsertColumnList; .) - = (. TableRef := TFFSqlTableRef.Create(Parent); .) - - IF IsTableExp THEN - BEGIN - TableExp<TableRef, TableExp> - (. TableRef.TableExp := TableExp; .) - [ SimpleAlias<TableRef> - ] - [ "(" InsertColumnList<TableRef, ColumnList> ")" - (. TableRef.ColumnList := ColumnList; .) - ] - END - ELSE - BEGIN - SQLName <aSQLName> (. TableRef.TableName := aSQLName; .) - [ - "." SQLName <aSQLName> - // previous ident was really a database name - (. TableRef.DatabaseName := TableRef.TableName; TableRef.TableName := aSQLName; .) - ] - [ SimpleAlias<TableRef> - ] - END - . - -SimpleAlias<var TableRef: TffSqlTableRef> - (. var aSQLName: string; .) - = - [ "AS" ] SQLName<aSQLName> (. TableRef.Alias := aSQLName; .) . - -SQLName <var aName : string> - = - ident (. aName := LexString; .) - | SQLNameString (. aName := CheckSQLName(LexString); .) - . - -END FFSQL. - diff --git a/components/flashfiler/sourcelaz/ffsql.pas b/components/flashfiler/sourcelaz/ffsql.pas deleted file mode 100644 index 061ed4373..000000000 --- a/components/flashfiler/sourcelaz/ffsql.pas +++ /dev/null @@ -1,3578 +0,0 @@ -{$I ffdefine.inc} //<-- soner added - -unit FFSQL; - - - - -{============================================================================== -FFSQL -0.0.0.102 -Date of Generation: 11/19/2002 2:45 PM -Comment: -Author: -Copyright: - -This unit was generated by Coco/R for Delphi (www.tetzel.com) Any code in -this file that you edit manually will be over-written when the file is -regenerated. -==============================================================================} - -interface -uses SysUtils,Classes,CocoBase,FFSQLDef,FFSQLDB,Dialogs; - - - -const -maxT = 125; -type - SymbolSet = array[0..maxT div setsize] of TBitSet; - - EFFSQL = class(Exception); - TFFSQL = class; - - TFFSQLScanner = class(TCocoRScanner) - private - FOwner : TFFSQL; -function CharInIgnoreSet(const Ch : char) : boolean; -procedure CheckLiteral(var Sym : integer); -function Equal(s : string) : boolean; - function Comment : boolean; - protected - procedure NextCh; override; - public - constructor Create; - - procedure Get(var sym : integer); override; // Gets next symbol from source file - - property CurrentSymbol; - property NextSymbol; - property OnStatusUpdate; - property Owner : TFFSQL read fOwner write fOwner; - property ScannerError; - property SrcStream; - end; { TFFSQLScanner } - - TFFSQL = class(TCocoRGrammar) - private - { strictly internal variables } - symSet : array[0..7] of SymbolSet; // symSet[0] = allSyncSyms - - function GetBuildDate : TDateTime; - function GetVersion : string; - function GetVersionStr : string; - procedure SetVersion(const Value : string); - function GetVersionInfo : string; - function _In(var s : SymbolSet; x : integer) : boolean; - procedure InitSymSet; - - {Production methods} - procedure _SimpleAlias (var TableRef: TffSqlTableRef); - procedure _BooleanLiteral (Parent: TFFSqlNode; var BooleanLiteral: TFFSqlBooleanLiteral); - procedure _IntervalLiteral (Parent: TFFSqlNode; - var IntervalLiteral: TFFSqlIntervalLiteral); - procedure _TimestampLiteral (Parent: TFFSqlNode; - var TimestampLiteral: TFFSqlTimestampLiteral); - procedure _TimeLiteral (Parent: TFFSqlNode; - var TimeLiteral: TFFSqlTimeLiteral); - procedure _DateLiteral (Parent: TFFSqlNode; - var DateLiteral: TFFSqlDateLiteral); - procedure _StringLiteral (Parent: TFFSqlNode; - var StringLiteral: TFFSqlStringLiteral); - procedure _IntegerLiteral (Parent: TFFSqlNode; - var IntegerLiteral: TFFSqlIntegerLiteral); - procedure _FloatLiteral (Parent: TFFSqlNode; - var FloatLiteral: TFFSqlFloatLiteral); - procedure _WhenClause (Parent : TFFSqlNode; - var WhenClause : TFFSqlWhenClause); - procedure _WhenClauseList (Parent: TFFSqlNode; - var WhenClauseList : TFFSqlWhenClauseList); - procedure _CoalesceExpression (Parent: TFFSqlNode; - var CoalesceExp: TFFSqlCoalesceExpression); - procedure _CaseExpression (Parent: TFFSqlNode; - var CaseExp: TFFSqlCaseExpression); - procedure _ScalarFunction (Parent: TFFSqlNode; - var Func: TFFSqlScalarFunc); - procedure _Param (Parent: TFFSqlNode; - var Param: TFFSqlParam); - procedure _Literal (Parent: TFFSqlNode; - var Literal: TFFSqlLiteral); - procedure _Factor (Parent: TFFSqlNode; - var Factor : TFFSqlFactor; - MulOp: TFFSqlMulOp); - procedure _Term (Parent: TFFSqlNode; var Term : TFFSqlTerm; AddOp : TFFSqlAddOp); - procedure _SimpleExpressionList (Parent: TFFSqlNode; - var SimpleExpressionList: TFFSqlSimpleExpressionList); - procedure _IsTest (Parent: TFFSqlNode; - var IsTest: TFFSqlIsTest); - procedure _MatchClause (Parent: TFFSqlNode; - var MatchClause: TFFSqlMatchClause); - procedure _InClause (Parent: TFFSqlNode; - var InClause: TFFSqlInClause; - Negated: Boolean); - procedure _LikeClause (Parent: TFFSqlNode; - var LikeClause: TFFSqlLikeClause; - Negated: Boolean); - procedure _BetweenClause (Parent: TFFSqlNode; - var BetweenClause: TFFSqlBetweenClause; - Negated: Boolean); - procedure _AllOrAnyClause (Parent: TFFSqlNode; - var AllOrAny: TFFSqlAllOrAnyClause); - procedure _UniqueClause (Parent: TFFSqlNode; - var Unique: TFFSqlUniqueClause); - procedure _ExistsClause (Parent: TFFSqlNode; - var Exists: TFFSqlExistsClause); - procedure _CondPrimary (Parent: TFFSqlNode; - var CondPrimary : TFFSqlCondPrimary); - procedure _CondFactor (Parent: TFFSqlNode; - var CondFactor: TFFSqlCondFactor); - procedure _CondTerm (Parent: TFFSqlNode; - var CondTerm : TFFSqlCondTerm); - procedure _GroupColumn (Parent: TFFSqlNode; - var Col : TFFSqlGroupColumn); - procedure _FieldRef (Parent: TFFSqlNode; var FieldRef: TFFSqlFieldRef); - procedure _Aggregate (Parent: TFFSqlNode; var Aggregate : TFFSqlAggregate); - procedure _Column (Parent: TFFSqlNode; - var Col : TFFSqlColumn); - procedure _ColumnAlias (var Selection : TFFSqlSelection); - procedure _Selection (SelectionList: TFFSqlSelectionList); - procedure _OrderColumn (Parent: TFFSqlNode; var Col : TFFSqlOrderColumn); - procedure _OrderItem (Parent: TFFSqlNode; - var OrderItem : TFFSqlOrderItem); - procedure _UpdateItem (Parent: TFFSqlNode; - var UpdateItem : TFFSqlUpdateItem); - procedure _UpdateList (Parent: TFFSqlNode; - var UpdateList : TFFSqlUpdateList); - procedure _SimpleTableRef (Parent: TFFSqlNode; var TableRef: TffSqlTableRef); - procedure _SimpleExpression (Parent: TFFSqlNode; - var SimpleExpression : TFFSqlSimpleExpression); - procedure _ValueItem (Parent: TFFSqlNode; - var ValueItem : TFFSqlValueItem); - procedure _InsertItem (Parent: TFFSqlNode; - var InsertItem : TFFSqlInsertItem); - procedure _ValueList (Parent: TFFSqlNode; - var ValueList : TFFSqlValueList); - procedure _TableConstructor (Parent: TFFSqlNode; var ValueList: TffSqlValueList); - procedure _NonJoinTablePrimary (Parent: TffSqlNode; var NonJoinTablePrimary: TffSqlNonJoinTablePrimary); - procedure _NonJoinTableTerm (Parent:TffSqlNode; var NonJoinTableTerm: TffSqlNonJoinTableTerm); - procedure _UsingItem (Parent: TFFSqlNode; - var UsingItem : TFFSqlUsingItem); - procedure _UsingList (Parent: TFFSqlNode; - var UsingList : TFFSqlUsingList); - procedure _TableRef (Parent: TFFSqlNode; var TableRef: TffSqlTableRef); - procedure _NonJoinTableExp (Parent:TffSqlNode; var NonJoinTableExp: TffSqlNonJoinTableExp); - procedure _JoinTableExp (Parent:TffSqlNode; const JoinTableExp: TffSqlJoinTableExp); - procedure _SimpleTableRefOrParenTableExp (Parent: TFFSqlNode; var TableRef: TffSqlTableRef); - procedure _InsertColumnList (Parent: TFFSqlNode; - var InsertColumnList : TFFSqlInsertColumnList); - procedure _SQLName (var aName : string); - procedure _OrderList (Parent: TFFSqlNode; - var OrderList : TFFSqlOrderList); - procedure _GroupColumnList (Parent: TFFSqlNode; - var ColumnList : TFFSqlGroupColumnList); - procedure _CondExp (Parent: TFFSqlNode; - var CondExp: TFFSqlCondExp); - procedure _TableRefList (Parent: TFFSqlNode; - var TableRefList: TFFSqlTableRefList); - procedure _SelectionList (Parent: TFFSqlSELECT; var SelectionList: TFFSqlSelectionList); - procedure _SelectStatement (Parent: TFFSqlNode; - var Select : TFFSqlSELECT); - procedure _DeleteStatement (Parent: TFFSqlNode; - var DeleteSt : TFFSqlDELETE); - procedure _UpdateStatement (Parent: TFFSqlNode; - var UpdateSt : TFFSqlUPDATE); - procedure _InsertStatement (Parent: TFFSqlNode; - var InsertSt : TFFSqlINSERT); - procedure _TableExp (Parent:TffSqlNode; var TableExp: TffSqlTableExp); - procedure _FFSQL; - - 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; - - - protected - { Protected Declarations } - procedure Get; override; - public - { Public Declarations } - constructor Create(AOwner : TComponent); override; - destructor Destroy; override; - - function ErrorStr(const ErrorCode : integer; const Data : string) : string; override; - procedure Execute; - function GetScanner : TFFSQLScanner; - procedure Parse; - - property ErrorList; - property ListStream; - property SourceStream; - property Successful; - property BuildDate : TDateTime read GetBuildDate; - property VersionStr : string read GetVersionStr; - property VersionInfo : string read GetVersionInfo; - - public - property RootNode : TFFSqlStatement read FRootNode write FRootNode; - property AllowReservedWordNames : boolean read FAllowReservedWordNames write FAllowReservedWordNames; - - published - { Published Declarations } - property AfterGet; - property AfterParse; - property AfterGenList; - property BeforeGenList; - property BeforeParse; - property ClearSourceStream; - property GenListWhen; - property SourceFileName; -property Version : string read GetVersion write SetVersion; - - property OnCustomError; - property OnError; - property OnFailure; - property OnStatusUpdate; - property OnSuccess; - end; { TFFSQL } - -implementation - - - -const - - EOFSYMB = 0; identSym = 1; integer_Sym = 2; floatSym = 3; - SQLStringSym = 4; SQLNameStringSym = 5; NOINDEXSym = 6; NOREDUCESym = 7; - _semicolonSym = 8; SELECTSym = 9; ALLSym = 10; DISTINCTSym = 11; - FROMSym = 12; WHERESym = 13; GROUPSym = 14; BYSym = 15; HAVINGSym = 16; - ORDERSym = 17; INSERTSym = 18; INTOSym = 19; DEFAULTSym = 20; - VALUESSym = 21; _lparenSym = 22; _rparenSym = 23; CROSSSym = 24; - JOINSym = 25; NATURALSym = 26; INNERSym = 27; LEFTSym = 28; OUTERSym = 29; - RIGHTSym = 30; FULLSym = 31; UNIONSym = 32; ONSym = 33; USINGSym = 34; - _commaSym = 35; TABLESym = 36; NULLSym = 37; DELETESym = 38; - UPDATESym = 39; SETSym = 40; _equalSym = 41; ASCSym = 42; DESCSym = 43; - _pointSym = 44; _starSym = 45; ASSym = 46; COUNTSym = 47; MINSym = 48; - MAXSym = 49; SUMSym = 50; AVGSym = 51; ORSym = 52; ANDSym = 53; - NOTSym = 54; _less_equalSym = 55; _lessSym = 56; _greaterSym = 57; - _greater_equalSym = 58; _less_greaterSym = 59; ANYSym = 60; SOMESym = 61; - EXISTSSym = 62; UNIQUESym = 63; ISSym = 64; TRUESym = 65; FALSESym = 66; - UNKNOWNSym = 67; BETWEENSym = 68; LIKESym = 69; ESCAPESym = 70; - IGNORESym = 71; CASESym = 72; INSym = 73; MATCHSym = 74; PARTIALSym = 75; - _plusSym = 76; _minusSym = 77; _bar_barSym = 78; _slashSym = 79; - CHARACTER_underscoreLENGTHSym = 80; CHAR_underscoreLENGTHSym = 81; - COALESCESym = 82; CURRENT_underscoreDATESym = 83; - CURRENT_underscoreTIMESym = 84; CURRENT_underscoreTIMESTAMPSym = 85; - CURRENT_underscoreUSERSym = 86; USERSym = 87; LOWERSym = 88; UPPERSym = 89; - POSITIONSym = 90; SESSION_underscoreUSERSym = 91; SUBSTRINGSym = 92; - FORSym = 93; SYSTEM_underscoreUSERSym = 94; TRIMSym = 95; LEADINGSym = 96; - TRAILINGSym = 97; BOTHSym = 98; EXTRACTSym = 99; YEARSym = 100; - MONTHSym = 101; DAYSym = 102; HOURSym = 103; MINUTESym = 104; - SECONDSym = 105; NULLIFSym = 106; ABSSym = 107; CEILINGSym = 108; - FLOORSym = 109; EXPSym = 110; LOGSym = 111; POWERSym = 112; RANDSym = 113; - ROUNDSym = 114; ELSESym = 115; ENDSym = 116; WHENSym = 117; THENSym = 118; - _querySym = 119; DATESym = 120; TIMESym = 121; TIMESTAMPSym = 122; - INTERVALSym = 123; TOSym = 124; NOSYMB = 125; _noSym = NOSYMB; {error token code} - -{ --------------------------------------------------------------------------- } -{ Arbitrary Code from ATG file } -procedure TFFSQL.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 TFFSQL.Init; -begin - fRootNode := TFFSqlStatement.Create; - fRootNode.UseIndex := True; - fRootNode.Reduce := True; - InitReservedWordList; -end; - -procedure TFFSQL.Final; -begin - if successful and fRootNode.Reduce then - fRootNode.ReduceStrength; -end; - -function TFFSQL.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 TFFSQL.IsSymbol(n : integer) : boolean; -begin - if CurrentInputSymbol = n then - Result := True - else - Result := False; -end; - -function TFFSQL.Matches(n: integer): boolean; -begin - Result := IsSymbol(n); - if Result then - Get; -end; {Expect} - -function TFFSQL.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 TFFSQL.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 TFFSQL.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 TFFSQL.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 TFFSQL.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 TFFSQL.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 TFFSQL.IsParenTableExp : boolean; -begin - Result := IsParenNonJoinTableExp or IsParenJoinTableExp; -end; - -function TFFSQL.IsTableExp : boolean; -begin - Result := IsNonJoinTableExp or IsJoinTableExp or IsParenTableExp; -end; - -(* End of Arbitrary Code *) - - - -{ --------------------------------------------------------------------------- } -{ ---- implementation for TFFSQLScanner ---- } - -procedure TFFSQLScanner.NextCh; -{ Return global variable ch } -begin - LastInputCh := CurrInputCh; - BufferPosition := BufferPosition + 1; - SrcStream.Seek(BufferPosition,soFromBeginning); - CurrInputCh := CurrentCh(BufferPosition); - if (CurrInputCh = _EL) OR ((CurrInputCh = _LF) AND (LastInputCh <> _EL)) then - begin - CurrLine := CurrLine + 1; - if Assigned(OnStatusUpdate) then - OnStatusUpdate(Owner, cstLineNum, '', CurrLine); - StartOfLine := BufferPosition; - end -end; {NextCh} - -function TFFSQLScanner.Comment : boolean; -var - level : integer; - startLine : integer; - oldLineStart : longint; - CommentStr : string; -begin - level := 1; - startLine := CurrLine; - oldLineStart := StartOfLine; - CommentStr := CharAt(BufferPosition); -//Result := false; -if (CurrInputCh = '/') then - begin -NextCh; -CommentStr := CommentStr + CharAt(BufferPosition); -if (CurrInputCh = '/') then -begin -NextCh; -CommentStr := CommentStr + CharAt(BufferPosition); -while true do -begin -if (CurrInputCh = CHR(13)) then -begin -level := level - 1; -NumEOLInComment := CurrLine - startLine; -NextCh; -CommentStr := CommentStr + CharAt(BufferPosition); -if level = 0 then -begin - Result := true; - Exit; -end; -end -else if CurrInputCh = _EF then -begin - Result := false; - Exit; -end -else -begin - NextCh; - CommentStr := CommentStr + CharAt(BufferPosition); -end; -end; { WHILE TRUE } -end -else -begin -if (CurrInputCh = _CR) OR (CurrInputCh = _LF) then -begin -CurrLine := CurrLine - 1; -StartOfLine := oldLineStart -end; -BufferPosition := BufferPosition - 1; -CurrInputCh := LastInputCh; -//Result := false; -end; -end; -//Result := false; -if (CurrInputCh = '-') then - begin -NextCh; -CommentStr := CommentStr + CharAt(BufferPosition); -if (CurrInputCh = '-') then -begin -NextCh; -CommentStr := CommentStr + CharAt(BufferPosition); -while true do -begin -if (CurrInputCh = CHR(13)) then -begin -level := level - 1; -NumEOLInComment := CurrLine - startLine; -NextCh; -CommentStr := CommentStr + CharAt(BufferPosition); -if level = 0 then -begin - Result := true; - Exit; -end; -end -else if CurrInputCh = _EF then -begin - Result := false; - Exit; -end -else -begin - NextCh; - CommentStr := CommentStr + CharAt(BufferPosition); -end; -end; { WHILE TRUE } -end -else -begin -if (CurrInputCh = _CR) OR (CurrInputCh = _LF) then -begin -CurrLine := CurrLine - 1; -StartOfLine := oldLineStart -end; -BufferPosition := BufferPosition - 1; -CurrInputCh := LastInputCh; -//Result := false; -end; -end; -Result := false; -if (CurrInputCh = '/') then - begin -NextCh; -CommentStr := CommentStr + CharAt(BufferPosition); -if (CurrInputCh = '*') then -begin -NextCh; -CommentStr := CommentStr + CharAt(BufferPosition); -while true do -begin -if (CurrInputCh = '*') then -begin -NextCh; -CommentStr := CommentStr + CharAt(BufferPosition); -if (CurrInputCh = '/') then -begin -level := level - 1; -NextCh; -CommentStr := CommentStr + CharAt(BufferPosition); -if level = 0 then -begin - Result := true; - Exit; -end -end -end -else if (CurrInputCh = '/') then -begin -NextCh; -CommentStr := CommentStr + CharAt(BufferPosition); -if (CurrInputCh = '*') then -begin - level := level + 1; - NextCh; -CommentStr := CommentStr + CharAt(BufferPosition); -end -end -else if CurrInputCh = _EF then -begin - Result := false; - Exit; -end -else -begin - NextCh; - CommentStr := CommentStr + CharAt(BufferPosition); -end; -end; { WHILE TRUE } -end -else -begin -if (CurrInputCh = _CR) OR (CurrInputCh = _LF) then -begin -CurrLine := CurrLine - 1; -StartOfLine := oldLineStart -end; -BufferPosition := BufferPosition - 1; -CurrInputCh := LastInputCh; -Result := false; -end; -end; -end; { Comment } - -function TFFSQLScanner.CharInIgnoreSet(const Ch : char) : boolean; -begin -Result := (Ch = ' ') OR -((CurrInputCh >= CHR(1)) AND (CurrInputCh <= ' ')); -end; {CharInIgnoreSet} - -function TFFSQLScanner.Equal(s : string) : boolean; -var - i : integer; - q : longint; -begin - if NextSymbol.Len <> Length(s) then - begin - Result := false; - EXIT - end; - i := 1; - q := bpCurrToken; - while i <= NextSymbol.Len do - begin - if CurrentCh(q) <> s[i] then - begin - Result := false; - EXIT; - end; - inc(i); - inc(q); - end; - Result := true -end; {Equal} - -procedure TFFSQLScanner.CheckLiteral(var Sym : integer); -begin -case CurrentCh(bpCurrToken) of - 'A': if Equal('ABS') then -begin -sym := ABSSym; -end -else if Equal('ALL') then -begin -sym := ALLSym; -end -else if Equal('AND') then -begin -sym := ANDSym; -end -else if Equal('ANY') then -begin -sym := ANYSym; -end -else if Equal('AS') then -begin -sym := ASSym; -end -else if Equal('ASC') then -begin -sym := ASCSym; -end -else if Equal('AVG') then -begin -sym := AVGSym; -end; - - 'B': if Equal('BETWEEN') then -begin -sym := BETWEENSym; -end -else if Equal('BOTH') then -begin -sym := BOTHSym; -end -else if Equal('BY') then -begin -sym := BYSym; -end; - - 'C': if Equal('CASE') then -begin -sym := CASESym; -end -else if Equal('CEILING') then -begin -sym := CEILINGSym; -end -else if Equal('CHARACTER_LENGTH') then -begin -sym := CHARACTER_underscoreLENGTHSym; -end -else if Equal('CHAR_LENGTH') then -begin -sym := CHAR_underscoreLENGTHSym; -end -else if Equal('COALESCE') then -begin -sym := COALESCESym; -end -else if Equal('COUNT') then -begin -sym := COUNTSym; -end -else if Equal('CROSS') then -begin -sym := CROSSSym; -end -else if Equal('CURRENT_DATE') then -begin -sym := CURRENT_underscoreDATESym; -end -else if Equal('CURRENT_TIME') then -begin -sym := CURRENT_underscoreTIMESym; -end -else if Equal('CURRENT_TIMESTAMP') then -begin -sym := CURRENT_underscoreTIMESTAMPSym; -end -else if Equal('CURRENT_USER') then -begin -sym := CURRENT_underscoreUSERSym; -end; - - 'D': if Equal('DATE') then -begin -sym := DATESym; -end -else if Equal('DAY') then -begin -sym := DAYSym; -end -else if Equal('DEFAULT') then -begin -sym := DEFAULTSym; -end -else if Equal('DELETE') then -begin -sym := DELETESym; -end -else if Equal('DESC') then -begin -sym := DESCSym; -end -else if Equal('DISTINCT') then -begin -sym := DISTINCTSym; -end; - - 'E': if Equal('ELSE') then -begin -sym := ELSESym; -end -else if Equal('END') then -begin -sym := ENDSym; -end -else if Equal('ESCAPE') then -begin -sym := ESCAPESym; -end -else if Equal('EXISTS') then -begin -sym := EXISTSSym; -end -else if Equal('EXP') then -begin -sym := EXPSym; -end -else if Equal('EXTRACT') then -begin -sym := EXTRACTSym; -end; - - 'F': if Equal('FALSE') then -begin -sym := FALSESym; -end -else if Equal('FLOOR') then -begin -sym := FLOORSym; -end -else if Equal('FOR') then -begin -sym := FORSym; -end -else if Equal('FROM') then -begin -sym := FROMSym; -end -else if Equal('FULL') then -begin -sym := FULLSym; -end; - - 'G': if Equal('GROUP') then -begin -sym := GROUPSym; -end; - - 'H': if Equal('HAVING') then -begin -sym := HAVINGSym; -end -else if Equal('HOUR') then -begin -sym := HOURSym; -end; - - 'I': if Equal('IGNORE') then -begin -sym := IGNORESym; -end -else if Equal('IN') then -begin -sym := INSym; -end -else if Equal('INNER') then -begin -sym := INNERSym; -end -else if Equal('INSERT') then -begin -sym := INSERTSym; -end -else if Equal('INTERVAL') then -begin -sym := INTERVALSym; -end -else if Equal('INTO') then -begin -sym := INTOSym; -end -else if Equal('IS') then -begin -sym := ISSym; -end; - - 'J': if Equal('JOIN') then -begin -sym := JOINSym; -end; - - 'L': if Equal('LEADING') then -begin -sym := LEADINGSym; -end -else if Equal('LEFT') then -begin -sym := LEFTSym; -end -else if Equal('LIKE') then -begin -sym := LIKESym; -end -else if Equal('LOG') then -begin -sym := LOGSym; -end -else if Equal('LOWER') then -begin -sym := LOWERSym; -end; - - 'M': if Equal('MATCH') then -begin -sym := MATCHSym; -end -else if Equal('MAX') then -begin -sym := MAXSym; -end -else if Equal('MIN') then -begin -sym := MINSym; -end -else if Equal('MINUTE') then -begin -sym := MINUTESym; -end -else if Equal('MONTH') then -begin -sym := MONTHSym; -end; - - 'N': if Equal('NATURAL') then -begin -sym := NATURALSym; -end -else if Equal('NOINDEX') then -begin -sym := NOINDEXSym; -end -else if Equal('NOREDUCE') then -begin -sym := NOREDUCESym; -end -else if Equal('NOT') then -begin -sym := NOTSym; -end -else if Equal('NULL') then -begin -sym := NULLSym; -end -else if Equal('NULLIF') then -begin -sym := NULLIFSym; -end; - - 'O': if Equal('ON') then -begin -sym := ONSym; -end -else if Equal('OR') then -begin -sym := ORSym; -end -else if Equal('ORDER') then -begin -sym := ORDERSym; -end -else if Equal('OUTER') then -begin -sym := OUTERSym; -end; - - 'P': if Equal('PARTIAL') then -begin -sym := PARTIALSym; -end -else if Equal('POSITION') then -begin -sym := POSITIONSym; -end -else if Equal('POWER') then -begin -sym := POWERSym; -end; - - 'R': if Equal('RAND') then -begin -sym := RANDSym; -end -else if Equal('RIGHT') then -begin -sym := RIGHTSym; -end -else if Equal('ROUND') then -begin -sym := ROUNDSym; -end; - - 'S': if Equal('SECOND') then -begin -sym := SECONDSym; -end -else if Equal('SELECT') then -begin -sym := SELECTSym; -end -else if Equal('SESSION_USER') then -begin -sym := SESSION_underscoreUSERSym; -end -else if Equal('SET') then -begin -sym := SETSym; -end -else if Equal('SOME') then -begin -sym := SOMESym; -end -else if Equal('SUBSTRING') then -begin -sym := SUBSTRINGSym; -end -else if Equal('SUM') then -begin -sym := SUMSym; -end -else if Equal('SYSTEM_USER') then -begin -sym := SYSTEM_underscoreUSERSym; -end; - - 'T': if Equal('TABLE') then -begin -sym := TABLESym; -end -else if Equal('THEN') then -begin -sym := THENSym; -end -else if Equal('TIME') then -begin -sym := TIMESym; -end -else if Equal('TIMESTAMP') then -begin -sym := TIMESTAMPSym; -end -else if Equal('TO') then -begin -sym := TOSym; -end -else if Equal('TRAILING') then -begin -sym := TRAILINGSym; -end -else if Equal('TRIM') then -begin -sym := TRIMSym; -end -else if Equal('TRUE') then -begin -sym := TRUESym; -end; - - 'U': if Equal('UNION') then -begin -sym := UNIONSym; -end -else if Equal('UNIQUE') then -begin -sym := UNIQUESym; -end -else if Equal('UNKNOWN') then -begin -sym := UNKNOWNSym; -end -else if Equal('UPDATE') then -begin -sym := UPDATESym; -end -else if Equal('UPPER') then -begin -sym := UPPERSym; -end -else if Equal('USER') then -begin -sym := USERSym; -end -else if Equal('USING') then -begin -sym := USINGSym; -end; - - 'V': if Equal('VALUES') then -begin -sym := VALUESSym; -end; - - 'W': if Equal('WHEN') then -begin -sym := WHENSym; -end -else if Equal('WHERE') then -begin -sym := WHERESym; -end; - - 'Y': if Equal('YEAR') then -begin -sym := YEARSym; -end; - -else -begin -end -end -end; {CheckLiteral} - - -procedure TFFSQLScanner.Get(var sym : integer); -var - state : integer; -begin {Get} -while CharInIgnoreSet(CurrInputCh) do - NextCh; -if ((CurrInputCh = '/') OR (CurrInputCh = '-') OR (CurrInputCh = '/')) AND Comment then -begin - Get(sym); - exit; - end; - - CurrentSymbol.Assign(NextSymbol); - - NextSymbol.Pos := BufferPosition; - NextSymbol.Col := BufferPosition - StartOfLine; - NextSymbol.Line := CurrLine; - NextSymbol.Len := 0; - - ContextLen := 0; - state := StartState[ORD(CurrInputCh)]; - bpCurrToken := BufferPosition; - while true do - begin - NextCh; - NextSymbol.Len := NextSymbol.Len + 1; - if BufferPosition > SrcStream.Size then - begin - sym := EOFSYMB; - CurrInputCh := _EF; - BufferPosition := BufferPosition - 1; - exit - end; - case state of - 1: if ((CurrInputCh = '!') OR -(CurrInputCh >= '#') AND (CurrInputCh <= '$') OR -(CurrInputCh >= '0') AND (CurrInputCh <= '9') OR -(CurrInputCh >= '@') AND (CurrInputCh <= 'Z') OR -(CurrInputCh = '\') OR -(CurrInputCh >= '^') AND (CurrInputCh <= '{') OR -(CurrInputCh >= '}')) then -begin - -end -else -begin -sym := identSym; -CheckLiteral(sym); -exit; -end; - 2: if ((CurrInputCh >= '0') AND (CurrInputCh <= '9')) then -begin -state := 3; -end -else -begin -sym := _pointSym; -exit; -end; - 3: if ((CurrInputCh >= '0') AND (CurrInputCh <= '9')) then -begin - -end -else -begin -sym := floatSym; -exit; -end; - 4: if ((CurrInputCh <= CHR(12)) OR -(CurrInputCh >= CHR(14)) AND (CurrInputCh <= '&') OR -(CurrInputCh >= '(')) then -begin - -end -else if (CurrInputCh = CHR(39)) then -begin -state := 8; -end -else -begin - sym := _noSym; -exit; -end; - 5: if ((CurrInputCh <= CHR(12)) OR -(CurrInputCh >= CHR(14)) AND (CurrInputCh <= '!') OR -(CurrInputCh >= '#')) then -begin - -end -else if (CurrInputCh = '"') then -begin -state := 6; -end -else -begin - sym := _noSym; -exit; -end; - 6: begin -sym := SQLNameStringSym; -exit; -end; - 7: if ((CurrInputCh >= '0') AND (CurrInputCh <= '9')) then -begin - -end -else if (CurrInputCh = '.') then -begin -state := 2; -end -else -begin -sym := integer_Sym; -exit; -end; - 8: if (CurrInputCh = CHR(39)) then -begin -state := 4; -end -else -begin -sym := SQLStringSym; -exit; -end; - 9: begin -sym := _semicolonSym; -exit; -end; - 10: begin -sym := _lparenSym; -exit; -end; - 11: begin -sym := _rparenSym; -exit; -end; - 12: begin -sym := _commaSym; -exit; -end; - 13: begin -sym := _equalSym; -exit; -end; - 14: begin -sym := _starSym; -exit; -end; - 15: if (CurrInputCh = '=') then -begin -state := 16; -end -else if (CurrInputCh = '>') then -begin -state := 19; -end -else -begin -sym := _lessSym; -exit; -end; - 16: begin -sym := _less_equalSym; -exit; -end; - 17: if (CurrInputCh = '=') then -begin -state := 18; -end -else -begin -sym := _greaterSym; -exit; -end; - 18: begin -sym := _greater_equalSym; -exit; -end; - 19: begin -sym := _less_greaterSym; -exit; -end; - 20: begin -sym := _plusSym; -exit; -end; - 21: begin -sym := _minusSym; -exit; -end; - 22: if (CurrInputCh = '|') then -begin -state := 23; -end -else -begin - sym := _noSym; -exit; -end; - 23: begin -sym := _bar_barSym; -exit; -end; - 24: begin -sym := _slashSym; -exit; -end; - 25: begin -sym := _querySym; -exit; -end; - 26: begin -sym := EOFSYMB; -CurrInputCh := #0; -BufferPosition := BufferPosition - 1; -exit -end; - else - begin - sym := _noSym; - EXIT; // NextCh already done - end; - end; - end; -end; {Get} - -constructor TFFSQLScanner.Create; -begin - inherited; -CurrentCh := CapChAt; -fStartState[ 0] := 26; fStartState[ 1] := 27; fStartState[ 2] := 27; fStartState[ 3] := 27; -fStartState[ 4] := 27; fStartState[ 5] := 27; fStartState[ 6] := 27; fStartState[ 7] := 27; -fStartState[ 8] := 27; fStartState[ 9] := 27; fStartState[ 10] := 27; fStartState[ 11] := 27; -fStartState[ 12] := 27; fStartState[ 13] := 27; fStartState[ 14] := 27; fStartState[ 15] := 27; -fStartState[ 16] := 27; fStartState[ 17] := 27; fStartState[ 18] := 27; fStartState[ 19] := 27; -fStartState[ 20] := 27; fStartState[ 21] := 27; fStartState[ 22] := 27; fStartState[ 23] := 27; -fStartState[ 24] := 27; fStartState[ 25] := 27; fStartState[ 26] := 27; fStartState[ 27] := 27; -fStartState[ 28] := 27; fStartState[ 29] := 27; fStartState[ 30] := 27; fStartState[ 31] := 27; -fStartState[ 32] := 27; fStartState[ 33] := 1; fStartState[ 34] := 5; fStartState[ 35] := 1; -fStartState[ 36] := 1; fStartState[ 37] := 27; fStartState[ 38] := 27; fStartState[ 39] := 4; -fStartState[ 40] := 10; fStartState[ 41] := 11; fStartState[ 42] := 14; fStartState[ 43] := 20; -fStartState[ 44] := 12; fStartState[ 45] := 21; fStartState[ 46] := 2; fStartState[ 47] := 24; -fStartState[ 48] := 7; fStartState[ 49] := 7; fStartState[ 50] := 7; fStartState[ 51] := 7; -fStartState[ 52] := 7; fStartState[ 53] := 7; fStartState[ 54] := 7; fStartState[ 55] := 7; -fStartState[ 56] := 7; fStartState[ 57] := 7; fStartState[ 58] := 27; fStartState[ 59] := 9; -fStartState[ 60] := 15; fStartState[ 61] := 13; fStartState[ 62] := 17; fStartState[ 63] := 25; -fStartState[ 64] := 1; fStartState[ 65] := 1; fStartState[ 66] := 1; fStartState[ 67] := 1; -fStartState[ 68] := 1; fStartState[ 69] := 1; fStartState[ 70] := 1; fStartState[ 71] := 1; -fStartState[ 72] := 1; fStartState[ 73] := 1; fStartState[ 74] := 1; fStartState[ 75] := 1; -fStartState[ 76] := 1; fStartState[ 77] := 1; fStartState[ 78] := 1; fStartState[ 79] := 1; -fStartState[ 80] := 1; fStartState[ 81] := 1; fStartState[ 82] := 1; fStartState[ 83] := 1; -fStartState[ 84] := 1; fStartState[ 85] := 1; fStartState[ 86] := 1; fStartState[ 87] := 1; -fStartState[ 88] := 1; fStartState[ 89] := 1; fStartState[ 90] := 1; fStartState[ 91] := 27; -fStartState[ 92] := 1; fStartState[ 93] := 27; fStartState[ 94] := 1; fStartState[ 95] := 1; -fStartState[ 96] := 1; fStartState[ 97] := 1; fStartState[ 98] := 1; fStartState[ 99] := 1; -fStartState[100] := 1; fStartState[101] := 1; fStartState[102] := 1; fStartState[103] := 1; -fStartState[104] := 1; fStartState[105] := 1; fStartState[106] := 1; fStartState[107] := 1; -fStartState[108] := 1; fStartState[109] := 1; fStartState[110] := 1; fStartState[111] := 1; -fStartState[112] := 1; fStartState[113] := 1; fStartState[114] := 1; fStartState[115] := 1; -fStartState[116] := 1; fStartState[117] := 1; fStartState[118] := 1; fStartState[119] := 1; -fStartState[120] := 1; fStartState[121] := 1; fStartState[122] := 1; fStartState[123] := 1; -fStartState[124] := 22; fStartState[125] := 1; fStartState[126] := 1; fStartState[127] := 1; -fStartState[128] := 1; fStartState[129] := 1; fStartState[130] := 1; fStartState[131] := 1; -fStartState[132] := 1; fStartState[133] := 1; fStartState[134] := 1; fStartState[135] := 1; -fStartState[136] := 1; fStartState[137] := 1; fStartState[138] := 1; fStartState[139] := 1; -fStartState[140] := 1; fStartState[141] := 1; fStartState[142] := 1; fStartState[143] := 1; -fStartState[144] := 1; fStartState[145] := 1; fStartState[146] := 1; fStartState[147] := 1; -fStartState[148] := 1; fStartState[149] := 1; fStartState[150] := 1; fStartState[151] := 1; -fStartState[152] := 1; fStartState[153] := 1; fStartState[154] := 1; fStartState[155] := 1; -fStartState[156] := 1; fStartState[157] := 1; fStartState[158] := 1; fStartState[159] := 1; -fStartState[160] := 1; fStartState[161] := 1; fStartState[162] := 1; fStartState[163] := 1; -fStartState[164] := 1; fStartState[165] := 1; fStartState[166] := 1; fStartState[167] := 1; -fStartState[168] := 1; fStartState[169] := 1; fStartState[170] := 1; fStartState[171] := 1; -fStartState[172] := 1; fStartState[173] := 1; fStartState[174] := 1; fStartState[175] := 1; -fStartState[176] := 1; fStartState[177] := 1; fStartState[178] := 1; fStartState[179] := 1; -fStartState[180] := 1; fStartState[181] := 1; fStartState[182] := 1; fStartState[183] := 1; -fStartState[184] := 1; fStartState[185] := 1; fStartState[186] := 1; fStartState[187] := 1; -fStartState[188] := 1; fStartState[189] := 1; fStartState[190] := 1; fStartState[191] := 1; -fStartState[192] := 1; fStartState[193] := 1; fStartState[194] := 1; fStartState[195] := 1; -fStartState[196] := 1; fStartState[197] := 1; fStartState[198] := 1; fStartState[199] := 1; -fStartState[200] := 1; fStartState[201] := 1; fStartState[202] := 1; fStartState[203] := 1; -fStartState[204] := 1; fStartState[205] := 1; fStartState[206] := 1; fStartState[207] := 1; -fStartState[208] := 1; fStartState[209] := 1; fStartState[210] := 1; fStartState[211] := 1; -fStartState[212] := 1; fStartState[213] := 1; fStartState[214] := 1; fStartState[215] := 1; -fStartState[216] := 1; fStartState[217] := 1; fStartState[218] := 1; fStartState[219] := 1; -fStartState[220] := 1; fStartState[221] := 1; fStartState[222] := 1; fStartState[223] := 1; -fStartState[224] := 1; fStartState[225] := 1; fStartState[226] := 1; fStartState[227] := 1; -fStartState[228] := 1; fStartState[229] := 1; fStartState[230] := 1; fStartState[231] := 1; -fStartState[232] := 1; fStartState[233] := 1; fStartState[234] := 1; fStartState[235] := 1; -fStartState[236] := 1; fStartState[237] := 1; fStartState[238] := 1; fStartState[239] := 1; -fStartState[240] := 1; fStartState[241] := 1; fStartState[242] := 1; fStartState[243] := 1; -fStartState[244] := 1; fStartState[245] := 1; fStartState[246] := 1; fStartState[247] := 1; -fStartState[248] := 1; fStartState[249] := 1; fStartState[250] := 1; fStartState[251] := 1; -fStartState[252] := 1; fStartState[253] := 1; fStartState[254] := 1; fStartState[255] := 1; -end; {Create} - - -{ --------------------------------------------------------------------------- } -{ ---- implementation for TFFSQL ---- } - -constructor TFFSQL.Create(AOwner : TComponent); -begin - inherited; - Scanner := TFFSQLScanner.Create; - GetScanner.Owner := self; -FRootNode := nil; - FReservedWordList := TStringList.Create; - FAllowReservedWordNames := True; - - InitSymSet; -end; {Create} - -destructor TFFSQL.Destroy; -begin - Scanner.Free; -FReservedWordList.Free; - FReservedWordList := NIL; - - inherited; -end; {Destroy} - -function TFFSQL.ErrorStr(const ErrorCode : integer; const Data : string) : string; -begin - case ErrorCode of - 0 : Result := 'EOF expected'; - 1 : Result := 'ident expected'; - 2 : Result := 'integer_ expected'; - 3 : Result := 'float expected'; - 4 : Result := 'SQLString expected'; - 5 : Result := 'SQLNameString expected'; - 6 : Result := '"NOINDEX" expected'; - 7 : Result := '"NOREDUCE" expected'; - 8 : Result := '";" expected'; - 9 : Result := '"SELECT" expected'; - 10 : Result := '"ALL" expected'; - 11 : Result := '"DISTINCT" expected'; - 12 : Result := '"FROM" expected'; - 13 : Result := '"WHERE" expected'; - 14 : Result := '"GROUP" expected'; - 15 : Result := '"BY" expected'; - 16 : Result := '"HAVING" expected'; - 17 : Result := '"ORDER" expected'; - 18 : Result := '"INSERT" expected'; - 19 : Result := '"INTO" expected'; - 20 : Result := '"DEFAULT" expected'; - 21 : Result := '"VALUES" expected'; - 22 : Result := '"(" expected'; - 23 : Result := '")" expected'; - 24 : Result := '"CROSS" expected'; - 25 : Result := '"JOIN" expected'; - 26 : Result := '"NATURAL" expected'; - 27 : Result := '"INNER" expected'; - 28 : Result := '"LEFT" expected'; - 29 : Result := '"OUTER" expected'; - 30 : Result := '"RIGHT" expected'; - 31 : Result := '"FULL" expected'; - 32 : Result := '"UNION" expected'; - 33 : Result := '"ON" expected'; - 34 : Result := '"USING" expected'; - 35 : Result := '"," expected'; - 36 : Result := '"TABLE" expected'; - 37 : Result := '"NULL" expected'; - 38 : Result := '"DELETE" expected'; - 39 : Result := '"UPDATE" expected'; - 40 : Result := '"SET" expected'; - 41 : Result := '"=" expected'; - 42 : Result := '"ASC" expected'; - 43 : Result := '"DESC" expected'; - 44 : Result := '"." expected'; - 45 : Result := '"*" expected'; - 46 : Result := '"AS" expected'; - 47 : Result := '"COUNT" expected'; - 48 : Result := '"MIN" expected'; - 49 : Result := '"MAX" expected'; - 50 : Result := '"SUM" expected'; - 51 : Result := '"AVG" expected'; - 52 : Result := '"OR" expected'; - 53 : Result := '"AND" expected'; - 54 : Result := '"NOT" expected'; - 55 : Result := '"<=" expected'; - 56 : Result := '"<" expected'; - 57 : Result := '">" expected'; - 58 : Result := '">=" expected'; - 59 : Result := '"<>" expected'; - 60 : Result := '"ANY" expected'; - 61 : Result := '"SOME" expected'; - 62 : Result := '"EXISTS" expected'; - 63 : Result := '"UNIQUE" expected'; - 64 : Result := '"IS" expected'; - 65 : Result := '"TRUE" expected'; - 66 : Result := '"FALSE" expected'; - 67 : Result := '"UNKNOWN" expected'; - 68 : Result := '"BETWEEN" expected'; - 69 : Result := '"LIKE" expected'; - 70 : Result := '"ESCAPE" expected'; - 71 : Result := '"IGNORE" expected'; - 72 : Result := '"CASE" expected'; - 73 : Result := '"IN" expected'; - 74 : Result := '"MATCH" expected'; - 75 : Result := '"PARTIAL" expected'; - 76 : Result := '"+" expected'; - 77 : Result := '"-" expected'; - 78 : Result := '"||" expected'; - 79 : Result := '"/" expected'; - 80 : Result := '"CHARACTER_LENGTH" expected'; - 81 : Result := '"CHAR_LENGTH" expected'; - 82 : Result := '"COALESCE" expected'; - 83 : Result := '"CURRENT_DATE" expected'; - 84 : Result := '"CURRENT_TIME" expected'; - 85 : Result := '"CURRENT_TIMESTAMP" expected'; - 86 : Result := '"CURRENT_USER" expected'; - 87 : Result := '"USER" expected'; - 88 : Result := '"LOWER" expected'; - 89 : Result := '"UPPER" expected'; - 90 : Result := '"POSITION" expected'; - 91 : Result := '"SESSION_USER" expected'; - 92 : Result := '"SUBSTRING" expected'; - 93 : Result := '"FOR" expected'; - 94 : Result := '"SYSTEM_USER" expected'; - 95 : Result := '"TRIM" expected'; - 96 : Result := '"LEADING" expected'; - 97 : Result := '"TRAILING" expected'; - 98 : Result := '"BOTH" expected'; - 99 : Result := '"EXTRACT" expected'; - 100 : Result := '"YEAR" expected'; - 101 : Result := '"MONTH" expected'; - 102 : Result := '"DAY" expected'; - 103 : Result := '"HOUR" expected'; - 104 : Result := '"MINUTE" expected'; - 105 : Result := '"SECOND" expected'; - 106 : Result := '"NULLIF" expected'; - 107 : Result := '"ABS" expected'; - 108 : Result := '"CEILING" expected'; - 109 : Result := '"FLOOR" expected'; - 110 : Result := '"EXP" expected'; - 111 : Result := '"LOG" expected'; - 112 : Result := '"POWER" expected'; - 113 : Result := '"RAND" expected'; - 114 : Result := '"ROUND" expected'; - 115 : Result := '"ELSE" expected'; - 116 : Result := '"END" expected'; - 117 : Result := '"WHEN" expected'; - 118 : Result := '"THEN" expected'; - 119 : Result := '"?" expected'; - 120 : Result := '"DATE" expected'; - 121 : Result := '"TIME" expected'; - 122 : Result := '"TIMESTAMP" expected'; - 123 : Result := '"INTERVAL" expected'; - 124 : Result := '"TO" expected'; - 125 : Result := 'not expected'; - 126 : Result := 'invalid BooleanLiteral'; - 127 : Result := 'invalid IntervalLiteral'; - 128 : Result := 'invalid IntervalLiteral'; - 129 : Result := 'invalid WhenClause'; - 130 : Result := 'invalid CaseExpression'; - 131 : Result := 'invalid ScalarFunction'; - 132 : Result := 'invalid ScalarFunction'; - 133 : Result := 'invalid ScalarFunction'; - 134 : Result := 'invalid Literal'; - 135 : Result := 'invalid Factor'; - 136 : Result := 'invalid Factor'; - 137 : Result := 'invalid IsTest'; - 138 : Result := 'invalid InClause'; - 139 : Result := 'invalid AllOrAnyClause'; - 140 : Result := 'invalid CondPrimary'; - 141 : Result := 'invalid CondPrimary'; - 142 : Result := 'invalid CondPrimary'; - 143 : Result := 'invalid CondPrimary'; - 144 : Result := 'invalid CondPrimary'; - 145 : Result := 'invalid FieldRef'; - 146 : Result := 'invalid Aggregate'; - 147 : Result := 'invalid Aggregate'; - 148 : Result := 'invalid Selection'; - 149 : Result := 'invalid OrderItem'; - 150 : Result := 'invalid UpdateItem'; - 151 : Result := 'invalid ValueItem'; - 152 : Result := 'invalid NonJoinTablePrimary'; - 153 : Result := 'invalid JoinTableExp'; - 154 : Result := 'invalid SimpleTableRefOrParenTableExp'; - 155 : Result := 'invalid SQLName'; - 156 : Result := 'invalid InsertStatement'; - 157 : Result := 'invalid TableExp'; - 158 : Result := 'invalid FFSQL'; - -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'; - - else - if Assigned(OnCustomError) then - Result := OnCustomError(Self, ErrorCode, Data) - else - begin - Result := 'Error: ' + IntToStr(ErrorCode); - if Trim(Data) > '' then - Result := Result + ' (' + Data + ')'; - end; - end; {case nr} -end; {ErrorStr} - -procedure TFFSQL.Execute; -begin - ClearErrors; - ListStream.Clear; - Extra := 1; - - { if there is a file name then load the file } - if Trim(SourceFileName) <> '' then - begin - GetScanner.SrcStream.Clear; - GetScanner.SrcStream.LoadFromFile(SourceFileName); - end; - - { install error reporting procedure } - GetScanner.ScannerError := StoreError; - - { instigate the compilation } - DoBeforeParse; - Parse; - DoAfterParse; - - { generate the source listing to the ListStream } - if (GenListWhen = glAlways) OR ((GenListWhen = glOnError) AND (ErrorList.Count > 0)) then - GenerateListing; - if ClearSourceStream then - GetScanner.SrcStream.Clear; - ListStream.Position := 0; // goto the beginning of the stream - if Successful AND Assigned(OnSuccess) then - OnSuccess(Self); - if (NOT Successful) AND Assigned(OnFailure) then - OnFailure(Self, ErrorList.Count); -end; {Execute} - -procedure TFFSQL.Get; -begin - repeat - - - GetScanner.Get(fCurrentInputSymbol); - if fCurrentInputSymbol <= maxT then - errDist := errDist + 1 - else - begin - end; - until fCurrentInputSymbol <= maxT; - if Assigned(AfterGet) then - AfterGet(Self, fCurrentInputSymbol); -end; {Get} - -function TFFSQL.GetScanner : TFFSQLScanner; -begin - Result := Scanner AS TFFSQLScanner; -end; {GetScanner} - -function TFFSQL._In(var s : SymbolSet; x : integer) : boolean; -begin - _In := x mod setsize in s[x div setsize]; -end; {_In} - -procedure TFFSQL._SimpleAlias (var TableRef: TffSqlTableRef);var aSQLName: string; -begin -if (fCurrentInputSymbol = ASSym) then begin -Get; -end; -_SQLName(aSQLName); -TableRef.Alias := aSQLName; -end; - -procedure TFFSQL._BooleanLiteral (Parent: TFFSqlNode; var BooleanLiteral: TFFSqlBooleanLiteral);begin -BooleanLiteral := TFFSqlBooleanLiteral.Create(Parent); -if (fCurrentInputSymbol = TRUESym) then begin -Get; -BooleanLiteral.Value := True; -end else if (fCurrentInputSymbol = FALSESym) then begin -Get; -end else begin SynError(126); -end; -end; - -procedure TFFSQL._IntervalLiteral (Parent: TFFSqlNode; -var IntervalLiteral: TFFSqlIntervalLiteral);begin -IntervalLiteral := TFFSqlIntervalLiteral.Create(Parent); -Expect(INTERVALSym); -IntervalLiteral.StartDef := iUnspec; -Expect(SQLStringSym); -IntervalLiteral.Value := LexString; -case fCurrentInputSymbol of - YEARSym : begin -Get; -IntervalLiteral.StartDef := iYear; - end; - MONTHSym : begin -Get; -IntervalLiteral.StartDef := iMonth; - end; - DAYSym : begin -Get; -IntervalLiteral.StartDef := iDay; - end; - HOURSym : begin -Get; -IntervalLiteral.StartDef := iHour; - end; - MINUTESym : begin -Get; -IntervalLiteral.StartDef := iMinute; - end; - SECONDSym : begin -Get; -IntervalLiteral.StartDef := iSecond; - end; -else begin SynError(127); - end; -end; -IntervalLiteral.EndDef := iUnspec; -if (fCurrentInputSymbol = TOSym) then begin -Get; -case fCurrentInputSymbol of - YEARSym : begin -Get; -IntervalLiteral.EndDef := iYear; - end; - MONTHSym : begin -Get; -IntervalLiteral.EndDef := iMonth; - end; - DAYSym : begin -Get; -IntervalLiteral.EndDef := iDay; - end; - HOURSym : begin -Get; -IntervalLiteral.EndDef := iHour; - end; - MINUTESym : begin -Get; -IntervalLiteral.EndDef := iMinute; - end; - SECONDSym : begin -Get; -IntervalLiteral.EndDef := iSecond; - end; -else begin SynError(128); - end; -end; -end; -end; - -procedure TFFSQL._TimestampLiteral (Parent: TFFSqlNode; -var TimestampLiteral: TFFSqlTimestampLiteral);begin -TimestampLiteral := TFFSqlTimestampLiteral.Create(Parent); -Expect(TIMESTAMPSym); -Expect(SQLStringSym); -TimestampLiteral.Value := LexString; -end; - -procedure TFFSQL._TimeLiteral (Parent: TFFSqlNode; -var TimeLiteral: TFFSqlTimeLiteral);begin -TimeLiteral := TFFSqlTimeLiteral.Create(Parent); -Expect(TIMESym); -Expect(SQLStringSym); -TimeLiteral.Value := LexString; -end; - -procedure TFFSQL._DateLiteral (Parent: TFFSqlNode; -var DateLiteral: TFFSqlDateLiteral);begin -DateLiteral := TFFSqlDateLiteral.Create(Parent); -Expect(DATESym); -Expect(SQLStringSym); -DateLiteral.Value := LexString; -end; - -procedure TFFSQL._StringLiteral (Parent: TFFSqlNode; -var StringLiteral: TFFSqlStringLiteral);begin -StringLiteral := TFFSqlStringLiteral.Create(Parent); -Expect(SQLStringSym); -StringLiteral.Value := LexString; -end; - -procedure TFFSQL._IntegerLiteral (Parent: TFFSqlNode; -var IntegerLiteral: TFFSqlIntegerLiteral);begin -IntegerLiteral := TFFSqlIntegerLiteral.Create(Parent); -Expect(integer_Sym); -IntegerLiteral.Value := LexString; -end; - -procedure TFFSQL._FloatLiteral (Parent: TFFSqlNode; -var FloatLiteral: TFFSqlFloatLiteral);begin -FloatLiteral := TFFSqlFloatLiteral.Create(Parent); -Expect(floatSym); -FloatLiteral.Value := LexString; -end; - -procedure TFFSQL._WhenClause (Parent : TFFSqlNode; -var WhenClause : TFFSqlWhenClause);var CondExp : TFFSqlCondExp; -Exp : TFFSqlSimpleExpression; -begin -WhenClause := TFFSqlWhenClause.Create(Parent); -Expect(WHENSym); -_CondExp(WhenClause, CondExp); -WhenClause.WhenExp := CondExp; -Expect(THENSym); -if (fCurrentInputSymbol = NULLSym) then begin -Get; -end else if _In(symSet[1], fCurrentInputSymbol) then begin -_SimpleExpression(WhenClause, Exp); -WhenClause.ThenExp := Exp; -end else begin SynError(129); -end; -end; - -procedure TFFSQL._WhenClauseList (Parent: TFFSqlNode; -var WhenClauseList : TFFSqlWhenClauseList);var WhenClause : TFFSqlWhenClause; -begin -WhenClauseList := TFFSqlWhenClauseList.Create(Parent); -_WhenClause(WhenClauseList, WhenClause); -WhenClauseList.AddWhenClause(WhenClause); -while (fCurrentInputSymbol = WHENSym) do begin -_WhenClause(WhenClauseList, WhenClause); -WhenClauseList.AddWhenClause(WhenClause); -end; -end; - -procedure TFFSQL._CoalesceExpression (Parent: TFFSqlNode; -var CoalesceExp: TFFSqlCoalesceExpression);var Exp : TFFSqlSimpleExpression; -begin -CoalesceExp := TFFSqlCoalesceExpression.Create(Parent); -Expect(_lparenSym); -_SimpleExpression(CoalesceExp, Exp); -CoalesceExp.AddArg(Exp); -while (fCurrentInputSymbol = _commaSym) do begin -Get; -_SimpleExpression(CoalesceExp, Exp); -CoalesceExp.AddArg(Exp); -end; -Expect(_rparenSym); -end; - -procedure TFFSQL._CaseExpression (Parent: TFFSqlNode; -var CaseExp: TFFSqlCaseExpression);var WhenClauseList : TFFSqlWhenClauseList; -var Exp : TFFSqlSimpleExpression; -begin -CaseExp := TFFSqlCaseExpression.Create(Parent); -_WhenClauseList(CaseExp, WhenClauseList); -CaseExp.WhenClauseList := WhenClauseList; -if (fCurrentInputSymbol = ELSESym) then begin -Get; -if (fCurrentInputSymbol = NULLSym) then begin -Get; -end else if _In(symSet[1], fCurrentInputSymbol) then begin -_SimpleExpression(CaseExp, Exp); -CaseExp.ElseExp := Exp; -end else begin SynError(130); -end; -end; -Expect(ENDSym); -end; - -procedure TFFSQL._ScalarFunction (Parent: TFFSqlNode; -var Func: TFFSqlScalarFunc);var Exp : TFFSqlSimpleExpression; -var CaseExp : TFFSqlCaseExpression; -var CoalesceExp : TFFSqlCoalesceExpression; -begin -Func := TFFSqlScalarFunc.Create(Parent); -case fCurrentInputSymbol of - CASESym : begin -Get; -_CaseExpression(Func, CaseExp); -Func.CaseExp := CaseExp; -Func.SQLFunction := sfCase; - end; - CHARACTER_underscoreLENGTHSym, CHAR_underscoreLENGTHSym : begin -if (fCurrentInputSymbol = CHARACTER_underscoreLENGTHSym) then begin -Get; -end else begin -Get; -end; -Expect(_lparenSym); -_SimpleExpression(Func, Exp); -Expect(_rparenSym); -Func.SQLFunction := sfCharLen; -Func.Arg1 := Exp; - end; - COALESCESym : begin -Get; -_CoalesceExpression(Func, CoalesceExp); -Func.CoalesceExp := CoalesceExp; -Func.SQLFunction := sfCoalesce; - end; - CURRENT_underscoreDATESym : begin -Get; -Func.SQLFunction := sfCurrentDate; - end; - CURRENT_underscoreTIMESym : begin -Get; -Func.SQLFunction := sfCurrentTime; - end; - CURRENT_underscoreTIMESTAMPSym : begin -Get; -Func.SQLFunction := sfCurrentTimestamp; - end; - CURRENT_underscoreUSERSym, USERSym : begin -if (fCurrentInputSymbol = CURRENT_underscoreUSERSym) then begin -Get; -end else begin -Get; -end; -Func.SQLFunction := sfCurrentUser; - end; - LOWERSym : begin -Get; -Expect(_lparenSym); -_SimpleExpression(Func, Exp); -Expect(_rparenSym); -Func.SQLFunction := sfLower; -Func.Arg1 := Exp - end; - UPPERSym : begin -Get; -Expect(_lparenSym); -_SimpleExpression(Func, Exp); -Expect(_rparenSym); -Func.SQLFunction := sfUpper; -Func.Arg1 := Exp; - end; - POSITIONSym : begin -Get; -Expect(_lparenSym); -_SimpleExpression(Func, Exp); -Func.SQLFunction := sfPosition; -Func.Arg1 := Exp; -if (fCurrentInputSymbol = _commaSym) then begin -Get; -end else if (fCurrentInputSymbol = INSym) then begin -Get; -end else begin SynError(131); -end; -_SimpleExpression(Func, Exp); -Func.Arg2 := Exp; -Expect(_rparenSym); - end; - SESSION_underscoreUSERSym : begin -Get; -Func.SQLFunction := sfSessionUser; - end; - SUBSTRINGSym : begin -Get; -Expect(_lparenSym); -_SimpleExpression(Func, Exp); -Func.SQLFunction := sfSubstring; -Func.Arg1 := Exp; -Expect(FROMSym); -_SimpleExpression(Func, Exp); -Func.Arg2 := Exp; -if (fCurrentInputSymbol = FORSym) then begin -Get; -_SimpleExpression(Func, Exp); -Func.Arg3 := Exp; -end; -Expect(_rparenSym); - end; - SYSTEM_underscoreUSERSym : begin -Get; -Func.SQLFunction := sfSystemUser; - end; - TRIMSym : begin -Get; -Expect(_lparenSym); -Func.SQLFunction := sfTrim; -Func.LTB := ltbBoth; -if (fCurrentInputSymbol = LEADINGSym) OR - (fCurrentInputSymbol = TRAILINGSym) OR - (fCurrentInputSymbol = BOTHSym) then begin -if (fCurrentInputSymbol = LEADINGSym) then begin -Get; -Func.LTB := ltbLeading; -end else if (fCurrentInputSymbol = TRAILINGSym) then begin -Get; -Func.LTB := ltbTrailing; -end else begin -Get; -end; -end; -if _In(symSet[1], fCurrentInputSymbol) then begin -_SimpleExpression(Func, Exp); -Func.Arg1 := Exp; -end; -if (fCurrentInputSymbol = FROMSym) then begin -Get; -_SimpleExpression(Func, Exp); -Func.Arg2 := Exp -end; -Expect(_rparenSym); - end; - EXTRACTSym : begin -Get; -Expect(_lparenSym); -Func.SQLFunction := sfExtract; -case fCurrentInputSymbol of - YEARSym : begin -Get; -Func.xDef := iYear; - end; - MONTHSym : begin -Get; -Func.xDef := iMonth; - end; - DAYSym : begin -Get; -Func.xDef := iDay; - end; - HOURSym : begin -Get; -Func.xDef := iHour; - end; - MINUTESym : begin -Get; -Func.xDef := iMinute; - end; - SECONDSym : begin -Get; -Func.xDef := iSecond; - end; -else begin SynError(132); - end; -end; -Expect(FROMSym); -_SimpleExpression(Func, Exp); -Func.Arg1 := Exp; -Expect(_rparenSym); - end; - NULLIFSym : begin -Get; -Expect(_lparenSym); -Func.SQLFunction := sfNullIf; -_SimpleExpression(Func, Exp); -Func.Arg1 := Exp; -Expect(_commaSym); -_SimpleExpression(Func, Exp); -Func.Arg2 := Exp; -Expect(_rparenSym); - end; - ABSSym : begin -Get; -Expect(_lparenSym); -Func.SQLFunction := sfAbs; -_SimpleExpression(Func, Exp); -Func.Arg1 := Exp; -Expect(_rparenSym); - end; - CEILINGSym : begin -Get; -Expect(_lparenSym); -Func.SQLFunction := sfCeil; -_SimpleExpression(Func, Exp); -Func.Arg1 := Exp; -Expect(_rparenSym); - end; - FLOORSym : begin -Get; -Expect(_lparenSym); -Func.SQLFunction := sfFloor; -_SimpleExpression(Func, Exp); -Func.Arg1 := Exp; -Expect(_rparenSym); - end; - EXPSym : begin -Get; -Expect(_lparenSym); -Func.SQLFunction := sfExp; -_SimpleExpression(Func, Exp); -Func.Arg1 := Exp; -Expect(_rparenSym); - end; - LOGSym : begin -Get; -Expect(_lparenSym); -Func.SQLFunction := sfLog; -_SimpleExpression(Func, Exp); -Func.Arg1 := Exp; -Expect(_rparenSym); - end; - POWERSym : begin -Get; -Expect(_lparenSym); -Func.SQLFunction := sfPower; -_SimpleExpression(Func, Exp); -Func.Arg1 := Exp; -Expect(_commaSym); -_SimpleExpression(Func, Exp); -Func.Arg2 := Exp; -Expect(_rparenSym); - end; - RANDSym : begin -Get; -Func.SQLFunction := sfRand; - end; - ROUNDSym : begin -Get; -Expect(_lparenSym); -Func.SQLFunction := sfRound; -_SimpleExpression(Func, Exp); -Func.Arg1 := Exp; -Expect(_rparenSym); - end; -else begin SynError(133); - end; -end; -end; - -procedure TFFSQL._Param (Parent: TFFSqlNode; -var Param: TFFSqlParam);begin -Param := TFFSqlParam.Create(Parent); -Expect(_querySym); -end; - -procedure TFFSQL._Literal (Parent: TFFSqlNode; -var Literal: TFFSqlLiteral);var FloatLiteral : TFFSqlFloatLiteral; -var IntegerLiteral : TFFSqlIntegerLiteral; -var StringLiteral : TFFSqlStringLiteral; -var DateLiteral : TFFSqlDateLiteral; -var TimeLiteral : TFFSqlTimeLiteral; -var TimestampLiteral : TFFSqlTimestampLiteral; -var IntervalLiteral : TFFSqlIntervalLiteral; -var BooleanLiteral : TFFSqlBooleanLiteral; -begin -Literal := TFFSqlLiteral.Create(Parent); -case fCurrentInputSymbol of - floatSym : begin -_FloatLiteral(Literal, FloatLiteral); -Literal.FloatLiteral := FloatLiteral; - end; - integer_Sym : begin -_IntegerLiteral(Literal, IntegerLiteral); -Literal.IntegerLiteral := IntegerLiteral; - end; - SQLStringSym : begin -_StringLiteral(Literal, StringLiteral); -Literal.StringLiteral := StringLiteral; - end; - DATESym : begin -_DateLiteral(Literal, DateLiteral); -Literal.DateLiteral := DateLiteral; - end; - TIMESym : begin -_TimeLiteral(Literal, TimeLiteral); -Literal.TimeLiteral := TimeLiteral; - end; - TIMESTAMPSym : begin -_TimestampLiteral(Literal, TimestampLiteral); -Literal.TimestampLiteral := TimestampLiteral; - end; - INTERVALSym : begin -_IntervalLiteral(Literal, IntervalLiteral); -Literal.IntervalLiteral := IntervalLiteral; - end; - TRUESym, FALSESym : begin -_BooleanLiteral(Literal, BooleanLiteral); -Literal.BooleanLiteral := BooleanLiteral; - end; -else begin SynError(134); - end; -end; -end; - -procedure TFFSQL._Factor (Parent: TFFSqlNode; -var Factor : TFFSqlFactor; -MulOp: TFFSqlMulOp);var FieldRef : TFFSqlFieldRef; -var CondExp : TFFSqlCondExp; -var Literal : TFFSqlLiteral; -var Param : TFFSqlParam; -var Select : TFFSqlSELECT; -var Agg : TFFSqlAggregate; -var Func : TFFSqlScalarFunc; -begin -Factor := TFFSqlFactor.Create(Parent); -Factor.MulOp := MulOp; -if (fCurrentInputSymbol = _minusSym) then begin -Get; -Factor.UnaryMinus := True; -end; -case fCurrentInputSymbol of - _lparenSym : begin -Get; -if _In(symSet[2], fCurrentInputSymbol) then begin -_CondExp(Factor, CondExp); -Factor.CondExp := CondExp; -end else if (fCurrentInputSymbol = SELECTSym) then begin -_SelectStatement(Factor, Select); -Factor.SubQuery := Select; -end else begin SynError(135); -end; -Expect(_rparenSym); - end; - identSym, SQLNameStringSym : begin -_FieldRef(Factor, FieldRef); -Factor.FieldRef := FieldRef; - end; - integer_Sym, floatSym, SQLStringSym, TRUESym, FALSESym, DATESym, TIMESym, - TIMESTAMPSym, INTERVALSym : begin -_Literal(Factor, Literal); -Factor.Literal := Literal; - end; - _querySym : begin -_Param(Factor, Param); -Factor.Param := Param; - end; - COUNTSym, MINSym, MAXSym, SUMSym, AVGSym : begin -_Aggregate(Factor, Agg); -Factor.Aggregate := Agg; - end; - CASESym, CHARACTER_underscoreLENGTHSym, CHAR_underscoreLENGTHSym, COALESCESym, CURRENT_underscoreDATESym, CURRENT_underscoreTIMESym, CURRENT_underscoreTIMESTAMPSym, - CURRENT_underscoreUSERSym, USERSym, LOWERSym, UPPERSym, POSITIONSym, SESSION_underscoreUSERSym, SUBSTRINGSym, SYSTEM_underscoreUSERSym, - TRIMSym, EXTRACTSym, NULLIFSym, ABSSym, CEILINGSym, FLOORSym, EXPSym, LOGSym, - POWERSym, RANDSym, ROUNDSym : begin -_ScalarFunction(Factor, Func); -Factor.ScalarFunc := Func; - end; -else begin SynError(136); - end; -end; -end; - -procedure TFFSQL._Term (Parent: TFFSqlNode; var Term : TFFSqlTerm; AddOp : TFFSqlAddOp);var Factor : TFFSqlFactor; -var MO : TFFSqlMulOp; -begin -Term := TFFSqlTerm.Create(Parent); -Term.AddOp := AddOp; -_Factor(Term, Factor, moMul); -Term.AddFactor(Factor); -while (fCurrentInputSymbol = _starSym) OR - (fCurrentInputSymbol = _slashSym) do begin -if (fCurrentInputSymbol = _starSym) then begin -Get; -MO := moMul; -end else begin -Get; -MO := moDiv; -end; -_Factor(Term, Factor, MO); -Term.AddFactor(Factor); -end; -end; - -procedure TFFSQL._SimpleExpressionList (Parent: TFFSqlNode; -var SimpleExpressionList: TFFSqlSimpleExpressionList);var SimpleExpression : TFFSqlSimpleExpression; -begin -SimpleExpressionList := TFFSqlSimpleExpressionList.Create(Parent); -_SimpleExpression(SimpleExpressionList, SimpleExpression); -SimpleExpressionList.AddExpression(SimpleExpression); -while (fCurrentInputSymbol = _commaSym) do begin -Get; -_SimpleExpression(SimpleExpressionList, SimpleExpression); -SimpleExpressionList.AddExpression(SimpleExpression); -end; -end; - -procedure TFFSQL._IsTest (Parent: TFFSqlNode; -var IsTest: TFFSqlIsTest);begin -Expect(ISSym); -IsTest := TFFSqlIsTest.Create(Parent); -if (fCurrentInputSymbol = NOTSym) then begin -Get; -IsTest.UnaryNot := True; -end; -if (fCurrentInputSymbol = NULLSym) then begin -Get; -IsTest.IsOp := ioNull; -end else if (fCurrentInputSymbol = TRUESym) then begin -Get; -IsTest.IsOp := ioTrue; -end else if (fCurrentInputSymbol = FALSESym) then begin -Get; -IsTest.IsOp := ioFalse; -end else if (fCurrentInputSymbol = UNKNOWNSym) then begin -Get; -IsTest.IsOp := ioUnknown; -end else begin SynError(137); -end; -end; - -procedure TFFSQL._MatchClause (Parent: TFFSqlNode; -var MatchClause: TFFSqlMatchClause);var Select : TFFSqlSelect; -begin -MatchClause := TFFSqlMatchClause.Create(Parent); -Expect(MATCHSym); -if (fCurrentInputSymbol = UNIQUESym) then begin -Get; -MatchClause.Unique := True; -end; -MatchClause.Option := moUnspec; -if (fCurrentInputSymbol = FULLSym) OR - (fCurrentInputSymbol = PARTIALSym) then begin -if (fCurrentInputSymbol = PARTIALSym) then begin -Get; -MatchClause.Option := moPartial; -end else begin -Get; -MatchClause.Option := moFull; -end; -end; -Expect(_lparenSym); -_SelectStatement(MatchClause, Select); -MatchClause.SubQuery := Select; -Expect(_rparenSym); -end; - -procedure TFFSQL._InClause (Parent: TFFSqlNode; -var InClause: TFFSqlInClause; -Negated: Boolean);var SimpleExpressionList : TFFSqlSimpleExpressionList; -var Select : TFFSqlSelect; -begin -InClause := TFFSqlInClause.Create(Parent); -InClause.Negated := Negated; -Expect(INSym); -Expect(_lparenSym); -if (fCurrentInputSymbol = SELECTSym) then begin -_SelectStatement(InClause, Select); -InClause.SubQuery := Select; -end else if _In(symSet[1], fCurrentInputSymbol) then begin -_SimpleExpressionList(InClause, SimpleExpressionList); -Inclause.SimpleExpList := SimpleExpressionList; -end else begin SynError(138); -end; -Expect(_rparenSym); -end; - -procedure TFFSQL._LikeClause (Parent: TFFSqlNode; -var LikeClause: TFFSqlLikeClause; -Negated: Boolean);var SimpleExpression : TFFSqlSimpleExpression; -begin -LikeClause := TFFSqlLikeClause.Create(Parent); -LikeClause.Negated := Negated; -Expect(LIKESym); -_SimpleExpression(LikeClause, SimpleExpression); -LikeClause.SimpleExp := SimpleExpression; -if (fCurrentInputSymbol = ESCAPESym) then begin -Get; -_SimpleExpression(LikeClause, SimpleExpression); -LikeClause.EscapeExp := SimpleExpression; -end; -if (fCurrentInputSymbol = IGNORESym) then begin -Get; -Expect(CASESym); -LikeClause.IgnoreCase := True; -end; -end; - -procedure TFFSQL._BetweenClause (Parent: TFFSqlNode; -var BetweenClause: TFFSqlBetweenClause; -Negated: Boolean);var SimpleExpression : TFFSqlSimpleExpression; -begin -BetweenClause := TFFSqlBetweenClause.Create(Parent); -BetweenClause.Negated := Negated; -Expect(BETWEENSym); -_SimpleExpression(BetweenClause, SimpleExpression); -BetweenClause.SimpleLow := SimpleExpression; -Expect(ANDSym); -_SimpleExpression(BetweenClause, SimpleExpression); -BetweenClause.SimpleHigh := SimpleExpression; -end; - -procedure TFFSQL._AllOrAnyClause (Parent: TFFSqlNode; -var AllOrAny: TFFSqlAllOrAnyClause);var Select : TFFSqlSelect; -begin -AllOrAny := TFFSqlAllOrAnyClause.Create(Parent); -if (fCurrentInputSymbol = ALLSym) then begin -Get; -AllOrAny.All := True; -end else if (fCurrentInputSymbol = ANYSym) then begin -Get; -end else if (fCurrentInputSymbol = SOMESym) then begin -Get; -end else begin SynError(139); -end; -Expect(_lparenSym); -_SelectStatement(AllOrAny, Select); -AllOrAny.SubQuery := Select; -Expect(_rparenSym); -end; - -procedure TFFSQL._UniqueClause (Parent: TFFSqlNode; -var Unique: TFFSqlUniqueClause);var TableExp : TFFSqlTableExp; -begin -Unique := TFFSqlUniqueClause.Create(Parent); -Expect(UNIQUESym); -Expect(_lparenSym); -_TableExp(Unique, TableExp); -Unique.SubQuery := TableExp; -Expect(_rparenSym); -end; - -procedure TFFSQL._ExistsClause (Parent: TFFSqlNode; -var Exists: TFFSqlExistsClause);var Select : TFFSqlSelect; -begin -Exists := TFFSqlExistsClause.Create(Parent); -Expect(EXISTSSym); -Expect(_lparenSym); -_SelectStatement(Exists, Select); -Exists.SubQuery := Select; -Expect(_rparenSym); -end; - -procedure TFFSQL._CondPrimary (Parent: TFFSqlNode; -var CondPrimary : TFFSqlCondPrimary);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; -begin -CondPrimary := TFFSqlCondPrimary.Create(Parent); -RelOp := roNone; -if (fCurrentInputSymbol = EXISTSSym) then begin -_ExistsClause(CondPrimary, ExistsClause); -CondPrimary.ExistsClause := ExistsClause; -end else if (fCurrentInputSymbol = UNIQUESym) then begin -_UniqueClause(CondPrimary, UniqueClause); -CondPrimary.UniqueClause := UniqueClause; -end else if _In(symSet[1], fCurrentInputSymbol) then begin -_SimpleExpression(CondPrimary, SimpleExpression); -CondPrimary.SimpleExp1 := SimpleExpression; -if _In(symSet[3], fCurrentInputSymbol) then begin -if _In(symSet[4], fCurrentInputSymbol) then begin -case fCurrentInputSymbol of - _equalSym, _less_equalSym, _lessSym, _greaterSym, _greater_equalSym, _less_greaterSym : begin -case fCurrentInputSymbol of - _equalSym : begin -Get; -RelOp := roEQ; - end; - _less_equalSym : begin -Get; -RelOp := roLE; - end; - _lessSym : begin -Get; -RelOp := roL; - end; - _greaterSym : begin -Get; -RelOp := roG; - end; - _greater_equalSym : begin -Get; -RelOp := roGE; - end; - _less_greaterSym : begin -Get; -RelOp := roNE; - end; -else begin SynError(140); - end; -end; -CondPrimary.RelOp := RelOp; -if (fCurrentInputSymbol = ALLSym) OR - (fCurrentInputSymbol = ANYSym) OR - (fCurrentInputSymbol = SOMESym) then begin -_AllOrAnyClause(CondPrimary, AllOrAny); -CondPrimary.AllOrAnyClause := AllOrAny; -end else if _In(symSet[1], fCurrentInputSymbol) then begin -_SimpleExpression(CondPrimary, SimpleExpression); -CondPrimary.SimpleExp2 := SimpleExpression; -end else begin SynError(141); -end; - end; - BETWEENSym : begin -_BetweenClause(CondPrimary, BetweenClause, False); -CondPrimary.BetweenClause := BetweenClause; - end; - LIKESym : begin -_LikeClause(CondPrimary, LikeClause, False); -CondPrimary.LikeClause := LikeClause; - end; - INSym : begin -_InClause(CondPrimary, InClause, False); -CondPrimary.InClause := InClause; - end; - MATCHSym : begin -_MatchClause(CondPrimary, MatchClause); -CondPrimary.MatchClause := MatchClause; - end; - NOTSym : begin -Get; -if (fCurrentInputSymbol = BETWEENSym) then begin -_BetweenClause(CondPrimary, BetweenClause, True); -CondPrimary.BetweenClause := BetweenClause; -end else if (fCurrentInputSymbol = LIKESym) then begin -_LikeClause(CondPrimary, LikeClause, True); -CondPrimary.LikeClause := LikeClause; -end else if (fCurrentInputSymbol = INSym) then begin -_InClause(CondPrimary, InClause, True); -CondPrimary.InClause := InClause; -end else begin SynError(142); -end; - end; -else begin SynError(143); - end; -end; -end else begin -_IsTest(CondPrimary, IsTest); -CondPrimary.IsTest := IsTest; -CondPrimary.RelOp := RoNone; -end; -end; -end else begin SynError(144); -end; -end; - -procedure TFFSQL._CondFactor (Parent: TFFSqlNode; -var CondFactor: TFFSqlCondFactor);var CondPrimary : TFFSqlCondPrimary; -begin -CondFactor := TFFSqlCondFactor.Create(Parent); -if (fCurrentInputSymbol = NOTSym) then begin -Get; -CondFactor.UnaryNot := True; -end; -_CondPrimary(CondFactor, CondPrimary); -CondFactor.CondPrimary := CondPrimary; -end; - -procedure TFFSQL._CondTerm (Parent: TFFSqlNode; -var CondTerm : TFFSqlCondTerm);var CondFactor : TFFSqlCondFactor; -begin -CondTerm := TFFSqlCondTerm.Create(Parent); -_CondFactor(CondTerm, CondFactor); -CondTerm.AddCondFactor(CondFactor); -while (fCurrentInputSymbol = ANDSym) do begin -Get; -_CondFactor(CondTerm, CondFactor); -CondTerm.AddCondFactor(CondFactor); -end; -end; - -procedure TFFSQL._GroupColumn (Parent: TFFSqlNode; -var Col : TFFSqlGroupColumn);var - aSQLName : string; -begin -Col := TFFSqlGroupColumn.Create(Parent); -aSQLName := ''; -_SQLName(aSQLName); -if (fCurrentInputSymbol = _pointSym) then begin -Get; -Col.TableName := aSQLName; -_SQLName(aSQLName); -end; -Col.FieldName := aSQLName; -end; - -procedure TFFSQL._FieldRef (Parent: TFFSqlNode; var FieldRef: TFFSqlFieldRef);var - aSQLName : string; -begin -FieldRef := TFFSqlFieldRef.Create(Parent); -aSQLName := ''; -_SQLName(aSQLName); -if (fCurrentInputSymbol = _pointSym) then begin -Get; -FieldRef.TableName := aSQLName; -if (fCurrentInputSymbol = identSym) OR - (fCurrentInputSymbol = SQLNameStringSym) then begin -_SQLName(aSQLName); -end else if (fCurrentInputSymbol = _starSym) then begin -Get; -aSQLName := ''; -end else begin SynError(145); -end; -end; -FieldRef.FieldName := aSQLName; -end; - -procedure TFFSQL._Aggregate (Parent: TFFSqlNode; var Aggregate : TFFSqlAggregate);var SimpleExpression : TFFSqlSimpleExpression; -begin -if Parent.OwnerSelect.InWhere then - SynError(202); -Aggregate := TFFSqlAggregate.Create(Parent); -if (fCurrentInputSymbol = COUNTSym) then begin -Get; -Aggregate.AgFunction := agCount; -Expect(_lparenSym); -if (fCurrentInputSymbol = _starSym) then begin -Get; -end else if _In(symSet[5], fCurrentInputSymbol) then begin -if (fCurrentInputSymbol = ALLSym) OR - (fCurrentInputSymbol = DISTINCTSym) then begin -if (fCurrentInputSymbol = ALLSym) then begin -Get; -end else begin -Get; -Aggregate.Distinct := True; -end; -end; -_SimpleExpression(Aggregate, SimpleExpression); -Aggregate.SimpleExpression := SimpleExpression; -end else begin SynError(146); -end; -Expect(_rparenSym); -end else if (fCurrentInputSymbol = MINSym) OR - (fCurrentInputSymbol = MAXSym) OR - (fCurrentInputSymbol = SUMSym) OR - (fCurrentInputSymbol = AVGSym) then begin -if (fCurrentInputSymbol = MINSym) then begin -Get; -Aggregate.AgFunction := agMin; -end else if (fCurrentInputSymbol = MAXSym) then begin -Get; -Aggregate.AgFunction := agMax; -end else if (fCurrentInputSymbol = SUMSym) then begin -Get; -Aggregate.AgFunction := agSum; -end else begin -Get; -Aggregate.AgFunction := agAvg; -end; -Expect(_lparenSym); -if (fCurrentInputSymbol = ALLSym) OR - (fCurrentInputSymbol = DISTINCTSym) then begin -if (fCurrentInputSymbol = ALLSym) then begin -Get; -end else begin -Get; -Aggregate.Distinct := True; -end; -end; -_SimpleExpression(Aggregate, SimpleExpression); -Aggregate.SimpleExpression := SimpleExpression; -if Aggregate.SimpleExpression.IsAggregateExpression then - SynError(201); -Expect(_rparenSym); -end else begin SynError(147); -end; -end; - -procedure TFFSQL._Column (Parent: TFFSqlNode; -var Col : TFFSqlColumn);var ColumnName : string; -begin -Col := TFFSqlColumn.Create(Parent); -_SQLName(ColumnName); -Col.ColumnName := ColumnName; -end; - -procedure TFFSQL._ColumnAlias (var Selection : TFFSqlSelection);var Col : TFFSqlColumn; -begin -if (fCurrentInputSymbol = ASSym) then begin -Get; -end; -_Column(Selection, Col); -Selection.Column := Col; -end; - -procedure TFFSQL._Selection (SelectionList: TFFSqlSelectionList);var Selection : TFFSqlSelection; -var Exp : TFFSqlSimpleExpression; -var Term: TFFSqlTerm; -var Factor: TFFSqlFactor; -var FieldRef: TFFSqlFieldRef; - -begin -Selection := TFFSqlSelection.Create(SelectionList); -if (fCurrentInputSymbol = _starSym) then begin -Get; - -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; - -end else if _In(symSet[1], fCurrentInputSymbol) then begin -_SimpleExpression(Selection, Exp); -Selection.SimpleExpression := Exp; -if (fCurrentInputSymbol = identSym) OR - (fCurrentInputSymbol = SQLNameStringSym) OR - (fCurrentInputSymbol = ASSym) then begin -_ColumnAlias(Selection); -end; -end else begin SynError(148); -end; -SelectionList.AddSelection(Selection); -end; - -procedure TFFSQL._OrderColumn (Parent: TFFSqlNode; var Col : TFFSqlOrderColumn);var - aSQLName : string; -begin -Col := TFFSqlOrderColumn.Create(Parent); -aSQLName := ''; -_SQLName(aSQLName); -if (fCurrentInputSymbol = _pointSym) then begin -Get; -Col.TableName := aSQLName; -aSQLName := ''; -_SQLName(aSQLName); -end; -Col.FieldName := aSQLName; -end; - -procedure TFFSQL._OrderItem (Parent: TFFSqlNode; -var OrderItem : TFFSqlOrderItem);var OrderColumn : TFFSqlOrderColumn; -begin -OrderItem := TFFSqlOrderItem.Create(Parent); -if (fCurrentInputSymbol = identSym) OR - (fCurrentInputSymbol = SQLNameStringSym) then begin -_OrderColumn(OrderItem, OrderColumn); -OrderItem.Column := OrderColumn; -end else if (fCurrentInputSymbol = integer_Sym) then begin -Get; -OrderItem.Index := LexString; -end else begin SynError(149); -end; -if (fCurrentInputSymbol = ASCSym) OR - (fCurrentInputSymbol = DESCSym) then begin -if (fCurrentInputSymbol = ASCSym) then begin -Get; -end else begin -Get; -OrderItem.Descending := True; -end; -end; -end; - -procedure TFFSQL._UpdateItem (Parent: TFFSqlNode; -var UpdateItem : TFFSqlUpdateItem);var Simplex : TFFSqlSimpleExpression; -var aSQLName : string; -begin -UpdateItem := TFFSqlUpdateItem.Create(Parent); -_SQLName(aSQLName); -UpdateItem.ColumnName := aSQLName; -Expect(_equalSym); -if (fCurrentInputSymbol = DEFAULTSym) then begin -Get; -UpdateItem.Default := True; -end else if (fCurrentInputSymbol = NULLSym) then begin -Get; -end else if _In(symSet[1], fCurrentInputSymbol) then begin -_SimpleExpression(UpdateItem, Simplex); -UpdateItem.Simplex := Simplex; -end else begin SynError(150); -end; -end; - -procedure TFFSQL._UpdateList (Parent: TFFSqlNode; -var UpdateList : TFFSqlUpdateList);var UpdateItem : TFFSqlUpdateItem; -begin -UpdateList := TFFSqlUpdateList.Create(Parent); -_UpdateItem(UpdateList, UpdateItem); -UpdateList.AddItem(UpdateItem); -while (fCurrentInputSymbol = _commaSym) do begin -Get; -_UpdateItem(UpdateList, UpdateItem); -UpdateList.AddItem(UpdateItem); -end; -end; - -procedure TFFSQL._SimpleTableRef (Parent: TFFSqlNode; var TableRef: TffSqlTableRef);var aSQLName : string; -begin -TableRef := TFFSqlTableRef.Create(Parent); -_SQLName(aSQLName); -TableRef.TableName := aSQLName; -if (fCurrentInputSymbol = _pointSym) then begin -Get; -_SQLName(aSQLName); -TableRef.DatabaseName := TableRef.TableName; TableRef.TableName := aSQLName; -end; -if (fCurrentInputSymbol = identSym) OR - (fCurrentInputSymbol = SQLNameStringSym) OR - (fCurrentInputSymbol = ASSym) then begin -_SimpleAlias(TableRef); -end; -end; - -procedure TFFSQL._SimpleExpression (Parent: TFFSqlNode; -var SimpleExpression : TFFSqlSimpleExpression);var Term : TFFSqlTerm; -var AO : TFFSqlAddOp; -begin -SimpleExpression := TFFSqlSimpleExpression.Create(Parent); -_Term(SimpleExpression, Term, aoPlus); -SimpleExpression.AddTerm(Term); -while (fCurrentInputSymbol = _plusSym) OR - (fCurrentInputSymbol = _minusSym) OR - (fCurrentInputSymbol = _bar_barSym) do begin -if (fCurrentInputSymbol = _plusSym) then begin -Get; -AO := aoPlus; -end else if (fCurrentInputSymbol = _minusSym) then begin -Get; -AO := aoMinus; -end else begin -Get; -AO := aoConcat; -end; -_Term(SimpleExpression, Term, AO); -SimpleExpression.AddTerm(Term); -end; -end; - -procedure TFFSQL._ValueItem (Parent: TFFSqlNode; -var ValueItem : TFFSqlValueItem); -var Simplex : TFFSqlSimpleExpression; -begin -ValueItem := TFFSqlValueItem.Create(Parent); -if (fCurrentInputSymbol = DEFAULTSym) then begin -Get; -ValueItem.Default := True; -end else if (fCurrentInputSymbol = NULLSym) then begin -Get; -end else if _In(symSet[1], fCurrentInputSymbol) then begin -_SimpleExpression(ValueItem, Simplex); -ValueItem.Simplex := Simplex; -end else begin SynError(151); -end; -end; - -procedure TFFSQL._InsertItem (Parent: TFFSqlNode; -var InsertItem : TFFSqlInsertItem);var aSQLName: string; -begin -InsertItem := TFFSqlInsertItem.Create(Parent); -_SQLName(aSQLName); -InsertItem.ColumnName := aSQLName; -end; - -procedure TFFSQL._ValueList (Parent: TFFSqlNode; - var ValueList : TFFSqlValueList);var ValueItem : TFFSqlValueItem; -begin -ValueList := TFFSqlValueList.Create(Parent); -_ValueItem(ValueList, ValueItem); -ValueList.AddItem(ValueItem); -while (fCurrentInputSymbol = _commaSym) do begin -Get; -_ValueItem(ValueList, ValueItem); -ValueList.AddItem(ValueItem); -end; -end; - -procedure TFFSQL._TableConstructor (Parent: TFFSqlNode; var ValueList: TffSqlValueList);begin -Expect(VALUESSym); -Expect(_lparenSym); -_ValueList(Parent, ValueList); -Expect(_rparenSym); -end; - -procedure TFFSQL._NonJoinTablePrimary (Parent: TffSqlNode; var NonJoinTablePrimary: TffSqlNonJoinTablePrimary);var ValueList: TffSqlValueList; -var NonJoinTableExp: TffSqlNonJoinTableExp; -var TableRef: TffSqlTableRef; -var SelectSt: TFFSqlSELECT; -begin -NonJoinTablePrimary := TffSqlNonJoinTablePrimary.Create(Parent); -if IsParenNonJoinTableExp then begin -Expect(_lparenSym); -_NonJoinTableExp(NonJoinTablePrimary, NonJoinTableExp); -NonJoinTablePrimary.NonJoinTableExp := NonJoinTableExp; -Expect(_rparenSym); -end else if (fCurrentInputSymbol = SELECTSym) then begin -_SelectStatement(NonJoinTablePrimary, SelectSt); -NonJoinTablePrimary.SelectSt := SelectSt; -end else if (fCurrentInputSymbol = TABLESym) then begin -Get; -_TableRef(NonJoinTablePrimary, TableRef); -NonJoinTablePrimary.TableRef := TableRef; -end else if (fCurrentInputSymbol = VALUESSym) then begin -_TableConstructor(NonJoinTablePrimary, ValueList); -NonJoinTablePrimary.ValueList := ValueList; -end else begin SynError(152); -end; -end; - -procedure TFFSQL._NonJoinTableTerm (Parent:TffSqlNode; var NonJoinTableTerm: TffSqlNonJoinTableTerm);var NonJoinTablePrimary: TffSqlNonJoinTablePrimary; -begin -NonJoinTableTerm := TffSqlNonJoinTableTerm.Create(Parent); -_NonJoinTablePrimary(NonJoinTableTerm, NonJoinTablePrimary); -NonJoinTableTerm.NonJoinTablePrimary := NonJoinTablePrimary; -end; - -procedure TFFSQL._UsingItem (Parent: TFFSqlNode; -var UsingItem : TFFSqlUsingItem);var aSQLName: string; -begin -UsingItem := TFFSqlUsingItem.Create(Parent); -_SQLName(aSQLName); -UsingItem.ColumnName := aSQLName; -end; - -procedure TFFSQL._UsingList (Parent: TFFSqlNode; -var UsingList : TFFSqlUsingList);var UsingItem : TFFSqlUsingItem; -begin -UsingList := TFFSqlUsingList.Create(Parent); -_UsingItem(UsingList, UsingItem); -UsingList.AddItem(UsingItem); -while (fCurrentInputSymbol = _commaSym) do begin -Get; -_UsingItem(UsingList, UsingItem); -UsingList.AddItem(UsingItem); -end; -end; - -procedure TFFSQL._TableRef (Parent: TFFSqlNode; var TableRef: TffSqlTableRef);var aSQLName : string; -var TableExp: TffSqlTableExp; -var ColumnList : TFFSqlInsertColumnList; -begin -TableRef := TFFSqlTableRef.Create(Parent); -if IsTableExp then begin -_TableExp(TableRef, TableExp); -TableRef.TableExp := TableExp; -if (fCurrentInputSymbol = identSym) OR - (fCurrentInputSymbol = SQLNameStringSym) OR - (fCurrentInputSymbol = ASSym) then begin -_SimpleAlias(TableRef); -end; -if (fCurrentInputSymbol = _lparenSym) then begin -Get; -_InsertColumnList(TableRef, ColumnList); -Expect(_rparenSym); -TableRef.ColumnList := ColumnList; -end; -end -else begin -_SQLName(aSQLName); -TableRef.TableName := aSQLName; -if (fCurrentInputSymbol = _pointSym) then begin -Get; -_SQLName(aSQLName); -TableRef.DatabaseName := TableRef.TableName; TableRef.TableName := aSQLName; -end; -if (fCurrentInputSymbol = identSym) OR - (fCurrentInputSymbol = SQLNameStringSym) OR - (fCurrentInputSymbol = ASSym) then begin -_SimpleAlias(TableRef); -end; -end; -end; - -procedure TFFSQL._NonJoinTableExp (Parent:TffSqlNode; var NonJoinTableExp: TffSqlNonJoinTableExp);var NonJoinTableTerm: TffSqlNonJoinTableTerm; -begin -NonJoinTableExp := TffSqlNonJoinTableExp.Create(Parent); -_NonJoinTableTerm(NonJoinTableExp, NonJoinTableTerm); -NonJoinTableExp.NonJoinTableTerm := NonJoinTableTerm; -end; - -procedure TFFSQL._JoinTableExp (Parent:TffSqlNode; const JoinTableExp: TffSqlJoinTableExp); -var TableRef: TffSqlTableRef; -var CondExp: TFFSqlCondExp; -var UsingList : TFFSqlUsingList; - -begin -if (fCurrentInputSymbol = CROSSSym) then begin -Get; -Expect(JOINSym); -_TableRef(JoinTableExp, TableRef); -JoinTableExp.JoinType := jtCross; -JoinTableExp.TableRef2 := TableRef; -end else if _In(symSet[6], fCurrentInputSymbol) then begin -if (fCurrentInputSymbol = NATURALSym) then begin -Get; -JoinTableExp.Natural := True; -end; -JoinTableExp.JoinType := jtInner; -if (fCurrentInputSymbol = INNERSym) OR - (fCurrentInputSymbol = LEFTSym) OR - (fCurrentInputSymbol = RIGHTSym) OR - (fCurrentInputSymbol = FULLSym) OR - (fCurrentInputSymbol = UNIONSym) then begin -if (fCurrentInputSymbol = INNERSym) then begin -Get; -end else if (fCurrentInputSymbol = LEFTSym) then begin -Get; -if (fCurrentInputSymbol = OUTERSym) then begin -Get; -end; -JoinTableExp.JoinType := jtLeftOuter; -end else if (fCurrentInputSymbol = RIGHTSym) then begin -Get; -if (fCurrentInputSymbol = OUTERSym) then begin -Get; -end; -JoinTableExp.JoinType := jtRightOuter; -end else if (fCurrentInputSymbol = FULLSym) then begin -Get; -if (fCurrentInputSymbol = OUTERSym) then begin -Get; -end; -JoinTableExp.JoinType := jtFullOuter; -end else begin -Get; -JoinTableExp.JoinType := jtUnion; -end; -end; -Expect(JOINSym); -_SimpleTableRefOrParenTableExp(JoinTableExp, TableRef); -JoinTableExp.TableRef2 := TableRef; -if (fCurrentInputSymbol = ONSym) OR - (fCurrentInputSymbol = USINGSym) then begin -if (fCurrentInputSymbol = ONSym) then begin -Get; -_CondExp(JoinTableExp, CondExp); -JoinTableExp.CondExp := CondExp; -end else begin -Get; -Expect(_lparenSym); -_UsingList(JoinTableExp, UsingList); -Expect(_rparenSym); -JoinTableExp.UsingList := UsingList; -end; -end; -end else begin SynError(153); -end; -end; - -procedure TFFSQL._SimpleTableRefOrParenTableExp (Parent: TFFSqlNode; var TableRef: TffSqlTableRef);var TableExp: TffSqlTableExp; -var aSQLName : string; -begin -TableRef := TFFSqlTableRef.Create(Parent); -if (fCurrentInputSymbol = identSym) OR - (fCurrentInputSymbol = SQLNameStringSym) then begin -_SQLName(aSQLName); -TableRef.TableName := aSQLName; -if (fCurrentInputSymbol = _pointSym) then begin -Get; -_SQLName(aSQLName); -TableRef.DatabaseName := TableRef.TableName; TableRef.TableName := aSQLName; -end; -if (fCurrentInputSymbol = identSym) OR - (fCurrentInputSymbol = SQLNameStringSym) OR - (fCurrentInputSymbol = ASSym) then begin -_SimpleAlias(TableRef); -end; -end else if (fCurrentInputSymbol = _lparenSym) then begin -Get; -_TableExp(TableRef, TableExp); -TableRef.TableExp := TableExp; -Expect(_rparenSym); -if (fCurrentInputSymbol = identSym) OR - (fCurrentInputSymbol = SQLNameStringSym) OR - (fCurrentInputSymbol = ASSym) then begin -_SimpleAlias(TableRef); -end; -end else begin SynError(154); -end; -end; - -procedure TFFSQL._InsertColumnList (Parent: TFFSqlNode; -var InsertColumnList : TFFSqlInsertColumnList);var InsertItem : TFFSqlInsertItem; -begin -InsertColumnList := TFFSqlInsertColumnList.Create(Parent); -_InsertItem(InsertColumnList, InsertItem); -InsertColumnList.AddItem(InsertItem); -while (fCurrentInputSymbol = _commaSym) do begin -Get; -_InsertItem(InsertColumnList, InsertItem); -InsertColumnList.AddItem(InsertItem); -end; -end; - -procedure TFFSQL._SQLName (var aName : string);begin -if (fCurrentInputSymbol = identSym) then begin -Get; -aName := LexString; -end else if (fCurrentInputSymbol = SQLNameStringSym) then begin -Get; -aName := CheckSQLName(LexString); -end else begin SynError(155); -end; -end; - -procedure TFFSQL._OrderList (Parent: TFFSqlNode; -var OrderList : TFFSqlOrderList);var OrderItem : TFFSqlOrderItem; -begin -OrderList := TFFSqlOrderList.Create(Parent); -_OrderItem(OrderList, OrderItem); -OrderList.AddOrderItem(OrderItem); -while (fCurrentInputSymbol = _commaSym) do begin -Get; -_OrderItem(OrderList, OrderItem); -OrderList.AddOrderItem(OrderItem); -end; -end; - -procedure TFFSQL._GroupColumnList (Parent: TFFSqlNode; -var ColumnList : TFFSqlGroupColumnList);var Col : TFFSqlGroupColumn; -begin -ColumnList := TFFSqlGroupColumnList.Create(Parent); -_GroupColumn(Parent, Col); -ColumnList.AddColumn(Col); -while (fCurrentInputSymbol = _commaSym) do begin -Get; -_GroupColumn(Parent, Col); -ColumnList.AddColumn(Col); -end; -end; - -procedure TFFSQL._CondExp (Parent: TFFSqlNode; -var CondExp: TFFSqlCondExp);var CondTerm : TFFSqlCondTerm; -begin -CondExp := TFFSqlCondExp.Create(Parent); -_CondTerm(CondExp, CondTerm); -CondExp.AddCondTerm(CondTerm); -while (fCurrentInputSymbol = ORSym) do begin -Get; -_CondTerm(CondExp, CondTerm); -CondExp.AddCondTerm(CondTerm); -end; -end; - -procedure TFFSQL._TableRefList (Parent: TFFSqlNode; -var TableRefList: TFFSqlTableRefList);var TableRef: TffSqlTableRef; -begin -TableRefList := TFFSqlTableRefList.Create(Parent); -_TableRef(TableRefList, TableRef); -TableRefList.AddTableRef(TableRef); -while (fCurrentInputSymbol = _commaSym) do begin -Get; -_TableRef(TableRefList, TableRef); -TableRefList.AddTableRef(TableRef); -end; -end; - -procedure TFFSQL._SelectionList (Parent: TFFSqlSELECT; var SelectionList: TFFSqlSelectionList);begin -SelectionList := TFFSqlSelectionList.Create(Parent); -_Selection(SelectionList); -while (fCurrentInputSymbol = _commaSym) do begin -Get; -_Selection(SelectionList); -end; -end; - -procedure TFFSQL._SelectStatement (Parent: TFFSqlNode; -var Select : TFFSqlSELECT);var SelectionList : TFFSqlSelectionList; -var CondExp : TFFSqlCondExp; -var GroupColumnList : TFFSqlGroupColumnList; -var TableRefList : TFFSqlTableRefList; -var OrderList : TFFSqlOrderList; -begin -Expect(SELECTSym); -Select := TFFSqlSELECT.Create(Parent); -if (fCurrentInputSymbol = ALLSym) OR - (fCurrentInputSymbol = DISTINCTSym) then begin -if (fCurrentInputSymbol = ALLSym) then begin -Get; -end else begin -Get; -Select.Distinct := True; -end; -end; -_SelectionList(Select, SelectionList); -Select.SelectionList := SelectionList; -Expect(FROMSym); -_TableRefList(Select, TableRefList); -Select.TableRefList := TableRefList; -if (fCurrentInputSymbol = WHERESym) then begin -Get; -Select.InWhere := True; -_CondExp(Select, CondExp); -Select.CondExpWhere := CondExp; -Select.InWhere := False; -end; -if (fCurrentInputSymbol = GROUPSym) then begin -Get; -Expect(BYSym); -_GroupColumnList(Select, GroupColumnList); -Select.GroupColumnList := GroupColumnList; -end; -if (fCurrentInputSymbol = HAVINGSym) then begin -Get; -_CondExp(Select, CondExp); -Select.CondExpHaving := CondExp; -end; -if (fCurrentInputSymbol = ORDERSym) then begin -Get; -Expect(BYSym); -_OrderList(Select, OrderList); -Select.OrderList := OrderList; -end; -end; - -procedure TFFSQL._DeleteStatement (Parent: TFFSqlNode; -var DeleteSt : TFFSqlDELETE);var TableRef: TffSqlTableRef; -var CondExp: TFFSqlCondExp; -begin -Expect(DELETESym); -Expect(FROMSym); -DeleteSt := TFFSqlDELETE.Create(Parent); -_SimpleTableRef(DeleteSt, TableRef); -DeleteSt.TableRef := TableRef; -if (fCurrentInputSymbol = WHERESym) then begin -Get; -_CondExp(DeleteSt, CondExp); -DeleteSt.CondExpWhere := CondExp; -end; -end; - -procedure TFFSQL._UpdateStatement (Parent: TFFSqlNode; -var UpdateSt : TFFSqlUPDATE);var TableRef: TffSqlTableRef; -var CondExp: TFFSqlCondExp; -var UpdateList: TFFSqlUpdateList; -begin -Expect(UPDATESym); -UpdateSt := TFFSqlUPDATE.Create(Parent); -_SimpleTableRef(UpdateSt, TableRef); -UpdateSt.TableRef := TableRef; -Expect(SETSym); -_UpdateList(UpdateSt, UpdateList); -UpdateSt.UpdateList := UpdateList; -if (fCurrentInputSymbol = WHERESym) then begin -Get; -_CondExp(UpdateSt, CondExp); -UpdateSt.CondExpWhere := CondExp; -end; -end; - -procedure TFFSQL._InsertStatement (Parent: TFFSqlNode; -var InsertSt : TFFSqlINSERT);var aSQLName: string; -var InsertColumnList: TffSqlInsertColumnList; -var TableExp: TffSqlTableExp; - -begin -Expect(INSERTSym); -Expect(INTOSym); -InsertSt := TFFSqlINSERT.Create(Parent); -_SQLName(aSQLName); -InsertSt.TableName := aSQLName; -if (fCurrentInputSymbol = DEFAULTSym) then begin -Get; -Expect(VALUESSym); -InsertSt.DefaultValues := True; -end else if IsColumnList then begin -Expect(_lparenSym); -_InsertColumnList(InsertSt, InsertColumnList); -InsertSt.InsertColumnList := InsertColumnList; -Expect(_rparenSym); -_TableExp(InsertSt, TableExp); -InsertSt.TableExp := TableExp; -end else if (fCurrentInputSymbol = SELECTSym) OR - (fCurrentInputSymbol = VALUESSym) OR - (fCurrentInputSymbol = _lparenSym) OR - (fCurrentInputSymbol = TABLESym) then begin -_TableExp(InsertSt, TableExp); -InsertSt.TableExp := TableExp; -end else begin SynError(156); -end; -end; - -procedure TFFSQL._TableExp (Parent:TffSqlNode; var TableExp: TffSqlTableExp);var NestedTableExp: TffSqlTableExp; -var JoinTableExp: TffSqlJoinTableExp; -var TmpJoinTableExp: TffSqlJoinTableExp; -var TmpTableExp: TffSqlTableExp; -var TableRef, TmpTableRef: TffSqlTableRef; -var NonJoinTableExp: TffSqlNonJoinTableExp; -begin -TableExp := TffSqlTableExp.Create(Parent); -if IsJoinTableExp then begin -JoinTableExp := TffSqlJoinTableExp.Create(TableExp); -TableExp.JoinTableExp := JoinTableExp; -_SimpleTableRefOrParenTableExp(JoinTableExp, TableRef); -JoinTableExp.TableRef1 := TableRef; -_JoinTableExp(TableExp, JoinTableExp); -while _In(symSet[7], fCurrentInputSymbol) do begin -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(TableExp, JoinTableExp); -end; -end else if (fCurrentInputSymbol = SELECTSym) OR - (fCurrentInputSymbol = VALUESSym) OR - (fCurrentInputSymbol = TABLESym) then begin -_NonJoinTableExp(TableExp, NonJoinTableExp); -TableExp.NonJoinTableExp := NonJoinTableExp; -end else if (fCurrentInputSymbol = _lparenSym) then begin -Get; -_TableExp(TableExp, NestedTableExp); -TableExp.NestedTableExp := NestedTableExp; -Expect(_rparenSym); -end else begin SynError(157); -end; -end; - -procedure TFFSQL._FFSQL; -var TableExp: TffSqlTableExp; -var InsertSt: TffSqlINSERT; -var UpdateSt: TffSqlUPDATE; -var DeleteSt: TffSqlDELETE; - -begin -Init; -if (fCurrentInputSymbol = NOINDEXSym) then begin -Get; -fRootNode.UseIndex := False -end; -if (fCurrentInputSymbol = NOREDUCESym) then begin -Get; -fRootNode.Reduce := False -end; -if IsTableExp then begin -_TableExp(fRootNode, TableExp); -fRootNode.TableExp := TableExp; -end else if (fCurrentInputSymbol = INSERTSym) then begin -_InsertStatement(fRootNode, InsertSt); -fRootNode.Insert := InsertSt; -end else if (fCurrentInputSymbol = UPDATESym) then begin -_UpdateStatement(fRootNode, UpdateSt); -fRootNode.Update := UpdateSt; -end else if (fCurrentInputSymbol = DELETESym) then begin -_DeleteStatement(fRootNode, DeleteSt); -fRootNode.Delete := DeleteSt; -end else begin SynError(158); -end; -if (fCurrentInputSymbol = _semicolonSym) then begin -Get; -end; -if fCurrentInputSymbol <> EOFSYMB then - SynError(200); -Final; -end; - -function TFFSQL.GetBuildDate : TDateTime; -const - BDate = 37579; - Hour = 14; - Min = 45; -begin - Result := BDate + EncodeTime(Hour, Min, 0 ,0); -end; - -function TFFSQL.GetVersion : string; -begin - Result := '0.0.0.102'; -end; - -function TFFSQL.GetVersionStr : string; -begin - Result := '0.0.0.102'; -end; - -function TFFSQL.GetVersionInfo : string; -begin - Result := 'Comment: ' + #13#10 + -'Author: ' + #13#10 + -'Copyright: '; -end; - -procedure TFFSQL.SetVersion(const Value : string); -begin - // This is a read only property. However, we want the value - // to appear in the Object Inspector during design time. -end; - -procedure TFFSQL.Parse; -begin - errDist := minErrDist; -GetScanner._Reset; -Get; -_FFSQL; -end; {Parse} - -procedure TFFSQL.InitSymSet; -begin -symSet[ 0, 0] := [EOFSYMB]; -symSet[ 0, 1] := []; -symSet[ 0, 2] := []; -symSet[ 0, 3] := []; -symSet[ 0, 4] := []; -symSet[ 0, 5] := []; -symSet[ 0, 6] := []; -symSet[ 0, 7] := []; -symSet[ 1, 0] := [identSym, integer_Sym, floatSym, SQLStringSym, - SQLNameStringSym]; -symSet[ 1, 1] := [_lparenSym-16]; -symSet[ 1, 2] := [COUNTSym-32]; -symSet[ 1, 3] := [MINSym-48, MAXSym-48, SUMSym-48, AVGSym-48]; -symSet[ 1, 4] := [TRUESym-64, FALSESym-64, CASESym-64, _minusSym-64]; -symSet[ 1, 5] := [CHARACTER_underscoreLENGTHSym-80, - CHAR_underscoreLENGTHSym-80, COALESCESym-80, - CURRENT_underscoreDATESym-80, CURRENT_underscoreTIMESym-80, - CURRENT_underscoreTIMESTAMPSym-80, - CURRENT_underscoreUSERSym-80, USERSym-80, LOWERSym-80, - UPPERSym-80, POSITIONSym-80, SESSION_underscoreUSERSym-80, - SUBSTRINGSym-80, SYSTEM_underscoreUSERSym-80, TRIMSym-80]; -symSet[ 1, 6] := [EXTRACTSym-96, NULLIFSym-96, ABSSym-96, CEILINGSym-96, - FLOORSym-96, EXPSym-96, LOGSym-96]; -symSet[ 1, 7] := [POWERSym-112, RANDSym-112, ROUNDSym-112, _querySym-112, - DATESym-112, TIMESym-112, TIMESTAMPSym-112, INTERVALSym-112]; -symSet[ 2, 0] := [identSym, integer_Sym, floatSym, SQLStringSym, - SQLNameStringSym]; -symSet[ 2, 1] := [_lparenSym-16]; -symSet[ 2, 2] := [COUNTSym-32]; -symSet[ 2, 3] := [MINSym-48, MAXSym-48, SUMSym-48, AVGSym-48, NOTSym-48, - EXISTSSym-48, UNIQUESym-48]; -symSet[ 2, 4] := [TRUESym-64, FALSESym-64, CASESym-64, _minusSym-64]; -symSet[ 2, 5] := [CHARACTER_underscoreLENGTHSym-80, - CHAR_underscoreLENGTHSym-80, COALESCESym-80, - CURRENT_underscoreDATESym-80, CURRENT_underscoreTIMESym-80, - CURRENT_underscoreTIMESTAMPSym-80, - CURRENT_underscoreUSERSym-80, USERSym-80, LOWERSym-80, - UPPERSym-80, POSITIONSym-80, SESSION_underscoreUSERSym-80, - SUBSTRINGSym-80, SYSTEM_underscoreUSERSym-80, TRIMSym-80]; -symSet[ 2, 6] := [EXTRACTSym-96, NULLIFSym-96, ABSSym-96, CEILINGSym-96, - FLOORSym-96, EXPSym-96, LOGSym-96]; -symSet[ 2, 7] := [POWERSym-112, RANDSym-112, ROUNDSym-112, _querySym-112, - DATESym-112, TIMESym-112, TIMESTAMPSym-112, INTERVALSym-112]; -symSet[ 3, 0] := []; -symSet[ 3, 1] := []; -symSet[ 3, 2] := [_equalSym-32]; -symSet[ 3, 3] := [NOTSym-48, _less_equalSym-48, _lessSym-48, _greaterSym-48, - _greater_equalSym-48, _less_greaterSym-48]; -symSet[ 3, 4] := [ISSym-64, BETWEENSym-64, LIKESym-64, INSym-64, MATCHSym-64]; -symSet[ 3, 5] := []; -symSet[ 3, 6] := []; -symSet[ 3, 7] := []; -symSet[ 4, 0] := []; -symSet[ 4, 1] := []; -symSet[ 4, 2] := [_equalSym-32]; -symSet[ 4, 3] := [NOTSym-48, _less_equalSym-48, _lessSym-48, _greaterSym-48, - _greater_equalSym-48, _less_greaterSym-48]; -symSet[ 4, 4] := [BETWEENSym-64, LIKESym-64, INSym-64, MATCHSym-64]; -symSet[ 4, 5] := []; -symSet[ 4, 6] := []; -symSet[ 4, 7] := []; -symSet[ 5, 0] := [identSym, integer_Sym, floatSym, SQLStringSym, - SQLNameStringSym, ALLSym, DISTINCTSym]; -symSet[ 5, 1] := [_lparenSym-16]; -symSet[ 5, 2] := [COUNTSym-32]; -symSet[ 5, 3] := [MINSym-48, MAXSym-48, SUMSym-48, AVGSym-48]; -symSet[ 5, 4] := [TRUESym-64, FALSESym-64, CASESym-64, _minusSym-64]; -symSet[ 5, 5] := [CHARACTER_underscoreLENGTHSym-80, - CHAR_underscoreLENGTHSym-80, COALESCESym-80, - CURRENT_underscoreDATESym-80, CURRENT_underscoreTIMESym-80, - CURRENT_underscoreTIMESTAMPSym-80, - CURRENT_underscoreUSERSym-80, USERSym-80, LOWERSym-80, - UPPERSym-80, POSITIONSym-80, SESSION_underscoreUSERSym-80, - SUBSTRINGSym-80, SYSTEM_underscoreUSERSym-80, TRIMSym-80]; -symSet[ 5, 6] := [EXTRACTSym-96, NULLIFSym-96, ABSSym-96, CEILINGSym-96, - FLOORSym-96, EXPSym-96, LOGSym-96]; -symSet[ 5, 7] := [POWERSym-112, RANDSym-112, ROUNDSym-112, _querySym-112, - DATESym-112, TIMESym-112, TIMESTAMPSym-112, INTERVALSym-112]; -symSet[ 6, 0] := []; -symSet[ 6, 1] := [JOINSym-16, NATURALSym-16, INNERSym-16, LEFTSym-16, - RIGHTSym-16, FULLSym-16]; -symSet[ 6, 2] := [UNIONSym-32]; -symSet[ 6, 3] := []; -symSet[ 6, 4] := []; -symSet[ 6, 5] := []; -symSet[ 6, 6] := []; -symSet[ 6, 7] := []; -symSet[ 7, 0] := []; -symSet[ 7, 1] := [CROSSSym-16, JOINSym-16, NATURALSym-16, INNERSym-16, - LEFTSym-16, RIGHTSym-16, FULLSym-16]; -symSet[ 7, 2] := [UNIONSym-32]; -symSet[ 7, 3] := []; -symSet[ 7, 4] := []; -symSet[ 7, 5] := []; -symSet[ 7, 6] := []; -symSet[ 7, 7] := []; -end; {InitSymSet} - -end { FFSQL }. diff --git a/components/flashfiler/sourcelaz/ffsqlbas.pas b/components/flashfiler/sourcelaz/ffsqlbas.pas deleted file mode 100644 index 81d064693..000000000 --- a/components/flashfiler/sourcelaz/ffsqlbas.pas +++ /dev/null @@ -1,185 +0,0 @@ -{*********************************************************} -{* FlashFiler: SQL Symbol 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 ***** *) - - -{ symbol table, expression tree, etc} - -{$I ffdefine.inc} - -unit ffsqlbas; - -interface - -uses - Classes, - ffllbase, - ffllcomp, - fflleng; - -type - - { The following type defines the data needed for a SQL parameter. } - PffSqlParamInfo = ^TffSqlParamInfo; - TffSqlParamInfo = record {Information block for SQL parameter} - piNum : word; {..parameter number (1..n)} - piName : string[ffcl_GeneralNameSize]; {..parameter name } - piType : TffFieldType; {..data type} - piOffset : word; {..offset in record} - piLength : word; {..length in bytes} - end; - - TffSqlParamInfoList = array[0..1023] of TffSqlParamInfo; - PffSqlParamInfoList = ^TffSqlParamInfoList; - - { This is the base class for a FlashFiler SQL engine. A SQL engine must - support the following operations: - - 1. Execute a prepared statement, returning a cursor to the client. - Client calls: - Alloc - Prepare - SetParams (optional) - Exec - FreeStmt - 2. Execute an unprepared statement, returning a cursor to the client: - Client calls: - ExecDirect - } - TffBaseSQLEngine = class(TffLoggableComponent) - protected - - public - - destructor Destroy; override; {!!.11} - - function Alloc(anEngine : TffBaseServerEngine; - aClientID : TffClientID; - aDatabaseID : TffDatabaseID; - aTimeout : Longint; - var aStmtID : TffSqlStmtID): TffResult; virtual; abstract; - { Allocates a statement handle for a query. This method must be - called prior to Prepare, Exec, etc. When the statement is no longer - needed, you must free the statement handle using FreeStmt. } - -{Begin !!.01} - procedure CollectGarbage; virtual; abstract; - { Use this method to perform garbage collection. Invoked when server - engine's garbage collection is invoked. } -{End !!.01} - - function Exec(aStmtID: TffSqlStmtID; - aOpenMode: TffOpenMode; - var aCursorID: TffCursorID; - aStream: TStream): TffResult; virtual; abstract; - { Executes a previously-prepared statement. Prior to calling this - method, the client must allocate a statement handle using Alloc and - specify the query using Prepare. - - aCursorID is set to zero if no result set returned otherwise it is a - handle to the result set. If a result set is returned, aStream - contains a data dictionary defining the structure of the resultset. } - - function ExecDirect(anEngine : TffBaseServerEngine; - aClientID : TffClientID; - aDatabaseID : TffDatabaseID; - aQueryText : PChar; - aOpenMode : TffOpenMode; - aTimeout : Longint; - var aCursorID : TffCursorID; - aStream : TStream): TffResult; virtual; abstract; - { Prepares and executes a query immediately. - - aCursorID is set to zero if no result set returned otherwise it is a - handle to the result set. If a result set is returned, aStream - contains a data dictionary defining the structure of the resultset. } - -{Begin !!.03} - procedure RequestClose; virtual; abstract; - { Ask the remaining SQL prepared statements to close. This occurs - when preparing for shutdown with the goal of preventing a cursor - being freed before its SQL table proxy is freed. } -{End !!.03} - - function FreeStmt(aStmtID: TffSqlStmtID): TffResult; virtual; abstract; - { Frees the resources associated with the specified statement. Must - be called after a statement has been allocated and executed. } - - function Prepare(aStmtID: TffSqlStmtID; - aQueryText: PChar; - aStream : TStream): TffResult; virtual; abstract; - { Use this method to prepare a query for execution. The client must - first allocate a statement using Alloc. Parameters: - - aStmtID is the handle to the statement created by Alloc. - aQueryText is the SQL statement to prepare. - aStream is for error reporting. If the SQL statement cannot be - prepared (i.e., it is incorrectly formed) or some other error - occurs, write a descriptive error message to the stream. The error - text is used when forming an exception on the client side. } - -{Begin !!.03} - procedure RemoveForClient(const aClientID : TffClientID); virtual; abstract; - { Remove the prepared statements associated with a particular client. } -{End !!.03} - - function SetParams(aStmtID : TffSqlStmtID; - aNumParams : Word; - aParamDescs : PffSqlParamInfoList; - aDataBuffer : PffByteArray; - aStream : TStream): TffResult; virtual; abstract; - { Use this method to associate values with parameters embedded within - a prepared statement. The client must allocate a statement using Alloc - and prepare the statement using Prepare. Parameters: - - aStmtID is the handle to the statement created by Alloc. - aNumParams is the number of parameters being passed to this method. - aParamDescs is a pointer to the array of parameters. - aDataBuffer is an array containing the parameter values. Each param - description points to its corresponding value in this buffer. - aStream is for error reporting. If one or more parameters are invalid - or some other error occurs, write a descriptive error message to the - stream. The error text is used when forming an exception on the - client side. } - - published - - end; - - -implementation - -{===TffBaseSQLEngine======================================================} -destructor TffBaseSQLEngine.Destroy; -begin - FFNotifyDependents(ffn_Destroy); - inherited; -end; -{=========================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/ffsqldb.pas b/components/flashfiler/sourcelaz/ffsqldb.pas deleted file mode 100644 index 70cabe374..000000000 --- a/components/flashfiler/sourcelaz/ffsqldb.pas +++ /dev/null @@ -1,2206 +0,0 @@ -{*********************************************************} -{* FlashFiler: SQL Engine database interface *} -{*********************************************************} - -(* ***** 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} - -{$Z+} - -unit ffsqldb; - -interface -uses - Windows, - SysUtils, - DB, - Classes, - ffllbase, - fflleng, - ffsrbde, - ffsreng, - ffsrlock, - fflldict, - ffstdate, - ffhash, - ffsrbase, - {$IFDEF DCC6OrLater} - Variants, - {$ENDIF} - ffsrcur, - ffsrixhl; - -const - ffcl_MaxSqlSortDepth = 64; -type - PStDate = ^TStDate; - PStTime = ^TStTime; - TBTable = array[0..255] of Byte; {Table used by Boyer-Moore search routines} {!!.11} - PBTable = ^TBTable; {!!.11} - -type - {Type for describing a field for creating temporary tables - - see CreateTemporaryTable below.} - PFFSqlFieldDefProxyRec = ^TFFSqlFieldDefProxyRec; - TFFSqlFieldDefProxyRec = record - FieldName : string; - FieldType : TffFieldType; - FieldUnits : Integer; - Decimals : Integer; - end; - - TffSqlFieldDefList = class(TffObject) - protected - FieldList: TffPointerList; - function GetCount: Integer; - function GetFieldDecimals(Index: Integer): Integer; - function GetFieldName(Index: Integer): string; - function GetFieldType(Index: Integer): TffFieldType; - function GetFieldUnits(Index: Integer): Integer; - public - constructor Create; - destructor Destroy; override; - procedure AddField(const aName: string; aType: TffFieldType; aUnit: Integer; aDec: Integer); - property Count: Integer read GetCount; - property FieldName[Index: Integer]: string read GetFieldName; - property FieldType[Index: Integer]: TffFieldType read GetFieldType; - property FieldUnits[Index: Integer]: Integer read GetFieldUnits; - property FieldDecimals[Index: Integer]: Integer read GetFieldDecimals; - end; - - TffSqlSortArray = array[0..pred(ffcl_MaxSqlSortDepth)] of Integer; - - TFFSqlTableProxy = class; - - {Interface between SQL engine and a table field definition} - TFFSqlFieldProxy = class(TffObject) - private - procedure SetBlobValue(const Value: Variant); {!!.13} - protected - FCursorID : TFFCursorID; - FIndex : Integer; - FIsTarget : Boolean; - FOwnerTable : TFFSqlTableProxy; - FSrcField : TffSqlFieldProxy; - FSrcIndex : Integer; - TypeKnown: Boolean; - FType : TffFieldType; - procedure ReadField(var IsNull: Boolean); - procedure WriteField; - procedure WriteFieldDirect(Buffer: PffByteArray); - function GetBlobValue: Variant; {!!.11}{!!.13} - function BLOBBmSearch(const Table: TBTable; - const SearchPhrase: string; - IgnoreCase: Boolean {!!.13} - ): Boolean; {!!.11} - public - FieldBuffer : PffByteArray; - FieldBufferLength: Integer; - constructor Create(AnOwnerTable: TFFSqlTableProxy; AnIndex: Integer; ACursorID: TFFCursorID); - destructor Destroy; override; - property Index: Integer read FIndex; - function Name: string; - function IsNull: Boolean; - function GetSize: Integer; - function GetDecimals: Integer; - function GetType : TffFieldType; - function GetValue: Variant; - procedure SetValue(const Value: Variant); - property IsTarget : Boolean read FIsTarget write FIsTarget; - { If this is a field in the result set table (i.e., a target field) then - this property returns True. } - property OwnerTable:TFFSqlTableProxy read FOwnerTable; - function QualName: string; - property SrcField : TffSQLFieldProxy read FSrcField write FSrcField; - { If this is a target field that refers to a source field then this - property references the source field. } - property SrcIndex : Integer read FSrcIndex write FSrcIndex; - { If this is a target field that refers to a simple expression then - this property identifies the index of the simple expression in - protected variable FSX. } - function CanUpdate: Boolean; - procedure SetDefault; {!!.11} - procedure SetFieldToNull; - function BMMatch(const Table: TBTable; const SearchPhrase: string; - IgnoreCase: Boolean {!!.13} - ): Boolean; {!!.11} - end; - - TFFSqlDatabaseProxy = class; - - TFFCopyValidator = function: Boolean of object; - - TFFSqlTableIterator = function(Cookie: TffWord32): Boolean of object; - - {Interface between SQL engine and a table definition} - TFFSqlTableProxy = class(TffObject) - protected - FCursorID : TFFCursorID; - FieldList : TList; - FName : string; - FAlias: string; - KeyBuffer1, - KeyBuffer2, - RecordBuffer : PffByteArray; - FDataBase: TFFSqlDatabaseProxy; - FEngine : TffBaseServerEngine; - FIndex : Integer; - FLeaveOpen : Boolean; - FRecordLen : Longint; - NoRecord: Boolean; - FOwner: TObject; - function SortOnAllFields(const CaseSensitive : Boolean) : TffResult; {!!.13} - public - procedure Iterate(Iterator: TFFSqlTableIterator; Cookie: TffWord32); - constructor Create(AOwner: TObject; - ADataBase: TFFSqlDatabaseProxy; ACursorID : TFFCursorID; const AName, - AAlias: string); {!!.11} - destructor Destroy; override; - property Name: string read FName; - property Alias: string read FAlias; {!!.11} - property CursorID : TFFCursorID read FCursorID; - property LeaveCursorOpen: Boolean read FLeaveOpen write FLeaveOpen; - function FieldCount: Integer; - function Field(Index: Integer): TFFSqlFieldProxy; - function FieldByName(const Name: string): TFFSqlFieldProxy; - procedure Close; - function Delete : TffResult; {!!.11} - function First: Boolean; - function Next: Boolean; - function Prior : Boolean; - procedure SetRange(const StartValues, EndValues: array of Variant; - const LowCount, HighCount: Integer; - const IncludeLowLimit, IncludeHighLimit, - IndexAsc: Boolean); - function EnsureWritable : TffResult; {!!.11} - { Verify the table may be modified. } {!!.11} - function EOF: Boolean; - procedure Insert; - {- create a new record where all fields are initially NULL} - function Post : TffResult; {!!.11} - {- actually insert the record. - - Currently, Insert and Post will only be performed - on temporary tables created by the SQL statement itself.} - function Update : TffResult; {!!.11} - { - update the current record buffer in the table} - procedure SetIndex(KeyNum: Integer); - {- switch to specified key, 0..pred(GetNumIndexes) means an actual index; - -1 means physical order (i.e. use no defined ordering) } - function GetSegments : Integer; - {- return number of fields in the currently active index} - function CopyValidated(AOwner: TObject; Validator: TFFCopyValidator): TFFSqlTableProxy;{!!.10} - {- return a copy of the table with only records that are valid - as per the called Validator function} - function CopySortedOnAllFields(AOwner: TObject): TFFSqlTableProxy; - function GetCurrentRecordID: Tffint64; - procedure GetRecordByID(ID: Tffint64; {!!.11} - const LockType : TffSrLockType); {!!.11} - function IndexesOnField(F : TFFSqlFieldProxy; MustBeCaseInsensitive: Boolean; - var IndexRefs: array of integer): Integer; - procedure GetIndexProperties(const Index: Integer; - var Unique, IgnoreCase, IndexAsc: Boolean; - var IndexFieldCount: Integer; var IndexFields: array of integer); -{Begin !!.13} - function Sort(const SortListCount: Integer; - const SortList: TffSqlSortArray; - const CaseSensitive : Boolean) : TffResult; - function CopyUnique(AOwner: TObject; - const CaseSensitive : Boolean): TFFSqlTableProxy; - function HasDuplicates(const CaseSensitive : Boolean): Boolean; -{End !!.13} - function ExtractFieldDef: TffSqlFieldDefList; - function GetRecordCount: Integer; - property Engine : TffBaseServerEngine read FEngine write FEngine; - procedure NullRecord; - property Owner: TObject read FOwner write FOwner; - procedure SetDefaults; - function PostNoDefaults: TffResult; {!!.11} - end; - - {Interface between SQL engine and the database} - TFFSqlDatabaseProxy = class(TffObject) - protected - FEngine : TFFServerEngine; - FDatabaseID : TFFDatabaseID; - public - property Engine: TFFServerEngine read FEngine; - constructor Create(Engine : TFFServerEngine; DatabaseID : TFFDatabaseID); - destructor Destroy; override; - function TableByName(AOwner: TObject; - const S: string; - const ExclContentLock : Boolean; - const AAlias: string): TFFSqlTableProxy; {!!.11} - {- find a table by name. if the table does not exist, NIL - is returned} - - function CreateTemporaryTableWithIndex( - AOwner: TObject; - const FieldDef: TffSqlFieldDefList; - IndexFields: Integer; IndexColumns: TffSqlSortArray): - TFFSqlTableProxy; - {- create a temporary table as per the specified field and - key segment lists. Return a proxy object, which gives - access to the (initially empty) table. When the proxy - object is freed, the tables can (should) be deleted. - FieldList is a TList containing PFFSqlFieldDefProxyRec - instances (see above). Each entry describes a field in the - table. KeyList is a TList containing PFFSqlKeySegmentDefProxyRec - instances (see above). Each entry describes a key segment} - function CreateTemporaryTableWithoutIndex( - AOwner: TObject; - const FieldDef: TffSqlFieldDefList): TFFSqlTableProxy; - - function StartTransaction(const Tables : array of TffSqlTableProxy) : TffResult; - procedure Commit; - procedure AbortTransaction; - function Alias: string; - end; - -type - TFFVariantList = class - protected - List : TFFPointerList; - public - constructor Create(Capacity: Integer); - destructor Destroy; override; - function GetValue(Index: Integer): Variant; - procedure SetValue(Index: Integer; const Value: Variant); - end; - -const - ffNRHashMaxRecords = MaxInt div sizeof(TffInt64); - ffMaxSourceTables = MaxInt div sizeof(TFFSqlTableProxy); -type - TffNRecordHashNode = class(TffHashNode) - destructor Destroy; override; - end; - - TffNRecordHashEntry = array[0..pred(ffNRHashMaxRecords)] of TffInt64; - PffNRecordHashEntry = ^TffNRecordHashEntry; - TffTableArray = array[0..pred(ffMaxSourceTables)] of TFFSqlTableProxy; - PffTableArray = ^TffTableArray; - - TffNRecordHash = class(TffBaseHashTable) - {- a data structure for keeping track of duplicate - record combinations when doing joins} - protected - FSourceTables: PffTableArray; - EntrySlots : Integer; - function fhCompareKey(const aKey1 : Pointer; - const aKey2 : Pointer) : Boolean; override; - - function fhCreateNode: TffHashNode; 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 - constructor Create; - {$IFDEF DCC4OrLater} reintroduce; {$ENDIF} - destructor Destroy; override; - procedure AddTable(const SourceTable: TFFSqlTableProxy); - procedure Add; - function Exists: Boolean; - end; - -type - TFFFieldCopier = class(TffObject) - protected - FSourceList, FTargetList, FCompatible, FBlob: TffPointerList; - public - constructor Create; - destructor Destroy; override; - procedure Execute; - procedure Add(SourceField, TargetField: TffSqlFieldProxy); - end; - -procedure CopyField(const SourceField, TargetField: TffSqlFieldProxy); -function CompatibleFields(const SourceField, TargetField: TffSqlFieldProxy): Boolean; -procedure BMMakeTableS(const MatchString : ShortString; var BT : TBTable); {!!.11} - -implementation - -uses - FFLLExcp, - FFSrCvex; - -{$I FFCONST.INC} - -{ TFFSqlDatabaseProxy } - -type - PComp = ^Comp; - -procedure TFFSqlDatabaseProxy.AbortTransaction; -begin - Assert(FEngine <> nil); - Assert(FEngine is TFFBaseServerEngine); - FEngine.TransactionRollbackSQL(FDatabaseID, False); -end; - -procedure TFFSqlDatabaseProxy.Commit; -begin - Assert(FEngine <> nil); - Assert(FEngine is TFFBaseServerEngine); - FEngine.TransactionCommitSQL(FDatabaseID, False); -end; - -constructor TFFSqlDatabaseProxy.Create(Engine: TFFServerEngine; - DatabaseID: TFFDatabaseID); -begin - inherited Create; - FEngine := Engine; - FDatabaseID := DatabaseID; -end; - -destructor TffSqlDatabaseProxy.Destroy; -begin - inherited Destroy; -end; - -function TFFSqlDatabaseProxy.CreateTemporaryTableWithIndex( - AOwner: TObject; - const FieldDef: TffSqlFieldDefList; - IndexFields: Integer; IndexColumns: TffSqlSortArray): TFFSqlTableProxy; -var - Dictionary : TffDataDictionary; - i: Integer; - KeySegList : TFFFieldList; - FldIHList : TFFFieldIHList; - Cursor : TffSrBaseCursor; - -begin - Dictionary := TffDataDictionary.Create(ffcl_64k); - try - for i := 0 to pred(FieldDef.Count) do - Dictionary.AddField(FieldDef.FieldName[i], '', FieldDef.FieldType[i], - FieldDef.FieldUnits[i], FieldDef.FieldDecimals[i], False, nil); - - for i := 0 to pred(IndexFields) do begin - KeySegList[i] := IndexColumns[i]; - FldIHList[i] := ''; - end; - - Dictionary.AddIndex('key0','',0, IndexFields, - KeySegList, FldIHList, True, True, False); - - Cursor := TffSrCursor.Create(TFFServerEngine(FEngine), - TFFSrDatabase(FDatabaseID), - FFGetRemainingTime); - - Cursor.Build('', Dictionary, omReadWrite, smExclusive, - False, True, [fffaTemporary, fffaBLOBChainSafe], 0); - - Cursor.CloseTable := True; - Result := TFFSqlTableProxy.Create(AOwner, Self, Cursor.CursorID, '', ''); {!!.11} - Result.Engine := FEngine; - - finally - Dictionary.Free; - end; -end; - -function TFFSqlDatabaseProxy.CreateTemporaryTableWithoutIndex(AOwner: TObject; - const FieldDef: TffSqlFieldDefList): TFFSqlTableProxy; -var - Dictionary : TffDataDictionary; - i: Integer; - Cursor : TffSrBaseCursor; -begin - Dictionary := TffDataDictionary.Create(ffcl_64k); - try - for i := 0 to pred(FieldDef.Count) do - Dictionary.AddField(FieldDef.FieldName[i], '', FieldDef.FieldType[i], - FieldDef.FieldUnits[i], FieldDef.FieldDecimals[i], False, nil); - - Cursor := TffSrSqlResultSet.Create(TFFServerEngine(FEngine), - TFFSrDatabase(FDatabaseID), - FFGetRemainingTime); - - Cursor.Build('', Dictionary, omReadWrite, smExclusive, - False, True, [fffaTemporary, fffaBLOBChainSafe], 0); - - Cursor.CloseTable := True; - Result := TFFSqlTableProxy.Create(AOwner, Self, Cursor.CursorID, '', ''); - Result.Engine := FEngine; - - finally - Dictionary.Free; - end; -end; - -function TFFSqlDatabaseProxy.StartTransaction(const Tables : array of TffSqlTableProxy) : TffResult; -var - CursorIDs : TffPointerList; - Inx : Integer; -begin - Assert(FEngine <> nil); - Assert(FEngine is TFFBaseServerEngine); - if Tables[0] = nil then begin - Result := DBIERR_NONE; - FEngine.TransactionStartSQL(FDatabaseID, False) - end - else begin - { Build the list of cursor IDs. } - CursorIDs := TffPointerList.Create; - try - for Inx := Low(Tables) to High(Tables) do - CursorIDs.Append(Pointer(Tables[Inx].CursorID)); - Result := FEngine.TransactionStartWith(FDatabaseID, False, CursorIDs); - finally - CursorIDs.Free; - end; - end; -end; - -function TFFSqlDatabaseProxy.TableByName(AOwner: TObject; - const S: string; - const ExclContentLock : Boolean; - const AAlias: string): TFFSqlTableProxy; {!!.11} -var - Cursor : TffSrBaseCursor; -begin - Cursor := nil; - try - Assert(FEngine <> nil); - Assert(FEngine is TFFServerEngine); - Assert(FDatabaseID <> 0); - Assert(TObject(FDatabaseID) is TFFSrDatabase); - - - Cursor := TffSrCursor.Create(TFFServerEngine(FEngine), - TFFSrDatabase(FDatabaseID), - FFGetRemainingTime); - Cursor.Open(S, '', 0, omReadOnly, smShared, False, ExclContentLock, []); - Result := TFFSqlTableProxy.Create(AOwner, Self, Cursor.CursorID, S, AAlias); - Result.Engine := FEngine; - - except - on E:Exception do begin - ConvertServerExceptionEx(E, FEngine.EventLog, FEngine.IsReadOnly); - Cursor.Free; - Result := nil; - end; - end; -end; - -function TFFSqlDatabaseProxy.Alias: string; -begin - Assert(FDatabaseID <> 0); - Assert(TObject(FDatabaseID) is TFFSrDatabase); - Result := TFFSrDatabase(FDatabaseID).Alias; -end; - -{ TFFVariantList } - -constructor TFFVariantList.Create(Capacity: Integer); -var - I: Integer; -begin - inherited Create; - List := TFFPointerList.Create; - List.Capacity := Capacity; - List.Count := Capacity; - for i := 0 to pred(List.Capacity) do - List[i] := nil; -end; - -destructor TFFVariantList.Destroy; -var - i : Integer; - P : Pointer; -begin - for i := 0 to pred(List.Count) do - if List[i] <> nil then begin - Finalize(PVariant(List[i])^); - P := List[i]; - FFFreeMem(P, sizeof(Variant)); - end; - List.Free; - inherited; -end; - -function TFFVariantList.GetValue(Index: Integer): Variant; -begin - Assert(List[Index] <> nil); - Result := PVariant(List[Index])^; -end; - -procedure TFFVariantList.SetValue(Index: Integer; const Value: Variant); -var - PV : PVariant; -begin - if List[Index] = nil then begin - FFGetZeroMem(PV, sizeof(Variant)); - List[Index] := PV; - end; - PVariant(List[Index])^ := Value; -end; - -{ TFFSqlTableProxy } - -function TffSqlTableProxy.ExtractFieldDef: TffSqlFieldDefList; -var - i: Integer; -begin - Result := TffSqlFieldDefList.Create; - for i := 0 to pred(FieldList.Count) do - Result.AddField(Field(i).Name, Field(i).GetType, Field(i).GetSize, - Field(i).GetDecimals); -end; - -function TFFSqlTableProxy.CopySortedOnAllFields( - AOwner: TObject): TFFSqlTableProxy; -var - i : Integer; - FieldDefList : TffSqlFieldDefList; -{$IFOPT C+} - CopyResult : TffResult; -{$ENDIF} - IndexColumns: TffSqlSortArray; -begin - FieldDefList := ExtractFieldDef; - try - for i := 0 to pred(FieldList.Count) do - IndexColumns[i] := i; - - Result := FDatabase.CreateTemporaryTableWithIndex(AOwner, FieldDefList, - FieldList.Count, IndexColumns); - - finally - FieldDefList.Free; - end; - - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - Assert(Result.FCursorID <> 0); - Assert(TObject(Result.FCursorID) is TffSrBaseCursor); - - {$IFOPT C+} - CopyResult := - {$ENDIF} - TffSrBaseCursor(Result.FCursorID).CopyRecords( - TffSrBaseCursor(FCursorID), ffbcmCreateLink, nil, 0, 0); - - {$IFOPT C+} - Assert(CopyResult = DBIERR_NONE); - {$ENDIF} - - Result.SetIndex(0); -end; - -function TFFSqlTableProxy.SortOnAllFields(const CaseSensitive : Boolean) : TffResult; {!!.13} -var - aCount : Integer; - i : Integer; - KeyArray : TffSqlSortArray; -begin - aCount := FFMinI(FieldList.Count, ffcl_MaxIndexFlds); - for i := 0 to pred(aCount) do begin - KeyArray[i] := TFFSqlFieldProxy(FieldList[i]).Index + 1; - {KeyArray values are +1 to allow for specifying descending sorting on column 0 - (by negating)} - end; - - Result := Sort(aCount, KeyArray, CaseSensitive); {!!.13} -end; - -{Begin !!.13} -function TFFSqlTableProxy.CopyUnique(AOwner: TObject; - const CaseSensitive : Boolean): TFFSqlTableProxy; -{End !!.13} -var - i : Integer; - FieldCopier : TFFFieldCopier; - FieldDefList : TffSqlFieldDefList; - IsFirst, DoCopy: Boolean; - Status : TffResult; - LastValues : TffVariantList; -begin - Status := SortOnAllFields(CaseSensitive); {!!.13} - if Status <> DBIERR_NONE then - raise EffException.CreateNoData(ffStrResServer, Status); - - FieldDefList := ExtractFieldDef; - try - Result := FDatabase.CreateTemporaryTableWithoutIndex(AOwner, FieldDefList); - finally - FieldDefList.Free; - end; - - {build a map of compatible fields} - FieldCopier := TFFFieldCopier.Create; - try - - for i := 0 to pred(FieldList.Count) do - FieldCopier.Add(Field(i), Result.Field(i)); - - FDatabase.StartTransaction([nil]); - try - IsFirst := True; - LastValues := TffVariantList.Create(FieldList.Count); - try - if First then - repeat - if IsFirst then begin - IsFirst := False; - DoCopy := True; - end else begin - DoCopy := False; - for i := 0 to pred(FieldList.Count) do - if Field(i).GetValue <> LastValues.GetValue(i) then begin - DoCopy := True; - break; - end; - end; - if DoCopy then begin - Result.Insert; - FieldCopier.Execute; - Result.Post; - end; - for i := 0 to pred(FieldList.Count) do - LastValues.SetValue(i, Field(i).GetValue); - until not Next; - finally - LastValues.Free; - end; - finally - FDatabase.Commit; - end; - finally - FieldCopier.Free; - end; -end; - -function TFFSqlTableProxy.HasDuplicates(const CaseSensitive : Boolean): Boolean; {!!.13} -var - i : Integer; - LastValues : TffVariantList; - IsFirst, Del : Boolean; - Status : TffResult; -begin - Status := SortOnAllFields(CaseSensitive); {!!.13} - if Status <> DBIERR_NONE then - raise EffException.CreateNoData(ffStrResServer, Status); - - FDatabase.StartTransaction([nil]); - LastValues := nil; - try - IsFirst := True; - LastValues := TffVariantList.Create(FieldList.Count); - if First then - repeat - if IsFirst then - IsFirst := False - else begin - Del := True; - for i := 0 to pred(FieldList.Count) do - if Field(i).GetValue <> LastValues.GetValue(i) then begin - Del := False; - break; - end; - if Del then begin - Result := True; - exit; - end; - end; - for i := 0 to pred(FieldList.Count) do - LastValues.SetValue(i, Field(i).GetValue); - until not Next; - finally - FDatabase.Commit; - LastValues.Free; - end; - Result := False; -end; - -function TFFSqlTableProxy.CopyValidated(AOwner: TObject; Validator: TFFCopyValidator): TFFSqlTableProxy; -var - i : Integer; - FieldCopier : TFFFieldCopier; - FieldDefList : TffSqlFieldDefList; -begin - FieldDefList := ExtractFieldDef; - try - Result := FDatabase.CreateTemporaryTableWithoutIndex(AOwner, FieldDefList); - finally - FieldDefList.Free; - end; - - {build a map of compatible fields} - FieldCopier := TFFFieldCopier.Create; - try - - for i := 0 to pred(FieldList.Count) do - FieldCopier.Add(Field(i), Result.Field(i)); - - FDatabase.StartTransaction([nil]); - try - if First then - repeat - if Validator then begin - Result.Insert; - FieldCopier.Execute; - Result.Post; - end; - until not Next; - finally - FDatabase.Commit; - end; - finally - FieldCopier.Free; - end; -end; - -{Begin !!.13} -function TFFSqlTableProxy.Sort(const SortListCount: Integer; - const SortList: TffSqlSortArray; - const CaseSensitive : Boolean) : TffResult; -{End !!.13} -var - aOrderByArray : TffOrderByArray; - FldList : TffFieldList; - IHList : TffFieldIHList; - i : Integer; -begin - - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - Assert(SortListCount <= ffcl_MaxIndexFlds); - { A data dictionary contains a sequential access index by default. In order - to sort the data, we must replace index 0 with the index describing how - the data is to be sorted. We must leave this index on the cursor. } - if TffSrBaseCursor(FCursorID).Dictionary.IndexCount > 0 then - TffSrBaseCursor(FCursorID).Dictionary.RemoveIndex(0); - - { Set up the index for sorting. } - for i := 0 to pred(SortListCount) do begin - Assert(Abs(SortList[i]) > 0); - FldList[i] := abs(SortList[i]) - 1; - with TffSrBaseCursor(FCursorID).Dictionary do - if FieldType[FldList[i]] in - [fftByteArray, fftBLOB, fftBLOBMemo, fftBLOBFmtMemo, fftBLOBOLEObj, - fftBLOBGraphic, fftBLOBDBSOLEObj, fftBLOBTypedBin, fftBLOBFile] then - FFRaiseException(EffServerException, ffStrResGeneral, - fferrBadDistinctField, [FieldName[FldList[i]]]); - IHList[i] := ''; - if SortList[i] < 0 then - aOrderByArray[i] := ffobDescending - else - aOrderByArray[i] := ffobAscending; - end; - TffSrBaseCursor(FCursorID).Dictionary.AddIndex - ('Sort', '', 0, SortListCount, FldList, IHList, True, True, {!!.13} - not CaseSensitive); {!!.13} - - TffSrBaseCursor(FCursorID).Dictionary.BindIndexHelpers; - - Result := - TffSrBaseCursor(FCursorID).SortRecords(FldList, aOrderByArray, SortListCount); -end; - -function TFFSqlTableProxy.GetCurrentRecordID: tffint64; -begin - if NoRecord then - ffInitI64(Result) - else begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - Result := TffSrBaseCursor(FCursorID).RefNr; - end; -end; - -procedure TFFSqlTableProxy.GetRecordByID(ID: TffInt64; {!!.11} - const LockType : TffSrLockType); {!!.11} -begin - TffSrBaseCursor(FCursorID).SetToKey(skaEqual, True, 1, 0, @ID); - TffSrBaseCursor(FCursorID).GetNextRecord(RecordBuffer, LockType); {!!.11} -end; - -procedure TFFSqlTableProxy.Close; -begin - Assert(Self <> nil); - Assert(TObject(Self) is TFFSqlTableProxy); - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor, - Format('%d is not a cursor', [FCursorID])); -{Begin !!.13} - with TffSrBaseCursor(FCursorID) do - if CanClose(True) then - Free - else - RequestClose; -{End !!.13} -end; - -constructor TFFSqlTableProxy.Create(AOwner: TObject; - ADataBase: TFFSqlDatabaseProxy; ACursorID: TFFCursorID; const AName, AAlias: string); -var - i : Integer; - Field : TFFSqlFieldProxy; -begin - inherited Create; - Assert(AOwner <> nil); - FOwner := AOwner; - FIndex := -1; - FDatabase := ADatabase; - FName := AName; - FAlias := AAlias; {!!.11} - FCursorID := ACursorID; - FieldList := TList.Create; - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - for i := 0 to pred(TffSrBaseCursor(FCursorID).Dictionary.FieldCount) do begin - Field := TFFSqlFieldProxy.Create(Self, i, FCursorID); - FieldList.Add(Field); - end; - FRecordLen := TffSrBaseCursor(FCursorID).Dictionary.RecordLength; - FFGetMem(RecordBuffer, FRecordLen); - FFGetMem(KeyBuffer1, FRecordLen); - FFGetMem(KeyBuffer2, FRecordLen); -end; - -destructor TFFSqlTableProxy.Destroy; -begin - Assert(Self <> nil); - Assert(TObject(Self) is TFFSqlTableProxy); - Assert(FOwner = nil); - while FieldList.Count > 0 do begin - TFFSqlFieldProxy(FieldList[0]).Free; - FieldList.Delete(0); - end; - FieldList.Free; - FFFreeMem(RecordBuffer, FRecordLen); - FFFreeMem(KeyBuffer1, FRecordLen); - FFFreeMem(KeyBuffer2, FRecordLen); - if not LeaveCursorOpen then - try - Close; - except - on E:Exception do - FEngine.LogFmt('Exception when closing TffSqlTableProxy: %s', - [E.message]); - end; - inherited; -end; -{Begin !!.11} -{--------} -function TffSqlTableProxy.EnsureWritable : TffResult; -var - Table : TffSrBaseTable; -begin - { There cannot be any type of lock on the table (unless its ours and - is a write lock). } - Result := DBIERR_NONE; - Table := TffSrBaseCursor(FCursorID).Table; - if Table.ClientLocks.Count > 0 then - if Table.ClientLocks.SummaryMode = ffsltExclusive then begin - if not Table.HasClientLock(CursorID) then begin - Result := DBIERR_FILELOCKED; - Exit; - end; - end - else begin - Result := DBIERR_FILELOCKED; - Exit; - end; -end; -{End !!.11} -{--------} -function TFFSqlTableProxy.EOF: Boolean; -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - Result := TffSrBaseCursor(FCursorID).Position = cpEOF; -end; -{--------} -function TFFSqlTableProxy.Field(Index: Integer): TFFSqlFieldProxy; -begin - Result := TFFSqlFieldProxy(FieldList[index]); -end; -{--------} -function TFFSqlTableProxy.FieldByName( - const Name: string): TFFSqlFieldProxy; -var - i : Integer; -begin - for i := 0 to pred(FieldList.Count) do - if AnsiCompareText(TFFSqlFieldProxy(FieldList[i]).Name, Name) = 0 then begin - Result := TFFSqlFieldProxy(FieldList[i]); - exit; - end; - Result := nil; -end; - -function TFFSqlTableProxy.FieldCount: Integer; -begin - Result := FieldList.Count; -end; - -function TFFSqlTableProxy.First: Boolean; -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - TffSrBaseCursor(FCursorID).SetToBegin; - Result := TffSrBaseCursor(FCursorID).GetNextRecord(RecordBuffer, ffsltNone) = DBIERR_NONE; - NoRecord := False; -end; - -function TFFSqlTableProxy.GetSegments: Integer; -begin - Result := TffSrBaseCursor(FCursorID).Dictionary.IndexDescriptor[FIndex + 1].idCount; -end; - -procedure TFFSqlTableProxy.Insert; -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - TffSrBaseCursor(FCursorID).Dictionary.InitRecord(RecordBuffer); -end; - -procedure TFFSqlTableProxy.SetDefaults; -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - TffSrBaseCursor(FCursorID).Dictionary.SetDefaultFieldValues(RecordBuffer); -end; - -function TFFSqlTableProxy.Next: Boolean; -var - DbResult : TffResult; -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - DbResult := TffSrBaseCursor(FCursorID).GetNextRecord(RecordBuffer, ffsltNone); - Result := DbResult = DBIERR_NONE; - NoRecord := False; -end; - -function TFFSqlTableProxy.Post : TffResult; {!!.11} -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - Result := TffSrBaseCursor(FCursorID).InsertRecord(RecordBuffer, {!!.11} - ffsltExclusive); {!!.11} - NoRecord := False; -end; - -function TFFSqlTableProxy.PostNoDefaults: TffResult; -{Rewritten !!.11} -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - Result := TffSrBaseCursor(FCursorID).InsertRecordNoDefault - (RecordBuffer, ffsltExclusive); - NoRecord := False; -end; - -function TFFSqlTableProxy.Prior: Boolean; -var - DbResult : TffResult; -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - DbResult := TffSrBaseCursor(FCursorID).GetPriorRecord(RecordBuffer, ffsltNone); - Result := DbResult = DBIERR_NONE; - NoRecord := False; -end; - -procedure TFFSqlTableProxy.SetIndex(KeyNum: Integer); -begin - if KeyNum <> FIndex then begin - FIndex := KeyNum; - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - TffSrBaseCursor(FCursorID).SwitchToIndex(KeyNum + 1, False); - end; -end; - -procedure TFFSqlTableProxy.SetRange(const StartValues, EndValues: array of Variant; - const LowCount, HighCount : Integer; - const IncludeLowLimit, IncludeHighLimit, - IndexAsc : Boolean); -var - LowSegs, HighSegs, i : Integer; - K1, K2 : PffByteArray; -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - LowSegs := FFMinI(GetSegments, LowCount); - HighSegs := FFMinI(GetSegments, HighCount); - for i := 0 to pred(LowSegs) do - Field(TffSrBaseCursor(FCursorID).Dictionary.IndexDescriptor[FIndex + 1]. - idFields[i]).SetValue(StartValues[i]); - TffSrBaseCursor(FCursorID).Table.BuildKeyForRecord(FIndex + 1, - RecordBuffer, KeyBuffer1, LowSegs, 0); - for i := 0 to pred(HighSegs) do - Field(TffSrBaseCursor(FCursorID).Dictionary.IndexDescriptor[FIndex + 1]. - idFields[i]).SetValue(EndValues[i]); - TffSrBaseCursor(FCursorID).Table.BuildKeyForRecord(FIndex + 1, - RecordBuffer, KeyBuffer2, HighSegs, 0); - if LowSegs > 0 then - K1 := KeyBuffer1 - else - K1 := nil; - if HighSegs > 0 then - K2 := KeyBuffer2 - else - K2 := nil; - if IndexAsc then - TffSrBaseCursor(FCursorID).SetRange(True, LowSegs, 0, K1, IncludeLowLimit, - HighSegs, 0, K2, IncludeHighLimit) - else - TffSrBaseCursor(FCursorID).SetRange(True, HighSegs, 0, K2, IncludeHighLimit, - LowSegs, 0, K1, IncludeLowLimit); -end; - -procedure TFFSqlTableProxy.Iterate(Iterator: TFFSqlTableIterator; Cookie: TffWord32); -begin - if First then - repeat - if not Iterator(Cookie) then - break; - until not Next; -end; - -function TFFSqlTableProxy.IndexesOnField(F: TFFSqlFieldProxy; MustBeCaseInsensitive: Boolean; {!!.10} - var IndexRefs: array of integer): Integer; -var - i : Integer; -begin - Result := 0; - for i := 0 to pred(TffSrBaseCursor(FCursorID).Dictionary.IndexCount) do begin - if TffSrBaseCursor(FCursorID).Dictionary.IndexDescriptor[i].idCount > 0 then - if TffSrBaseCursor(FCursorID).Dictionary.IndexDescriptor[i].idFields[0] = - F.Index then begin - if not MustBeCaseInsensitive {!!.10} - or (TffSrBaseCursor(FCursorID).Dictionary. - IndexDescriptor[i].idNoCase) then begin - IndexRefs[Result] := i; - inc(Result); - end; - end; - end; -end; - -procedure TFFSqlTableProxy.GetIndexProperties(const Index: Integer; - var Unique, IgnoreCase, IndexAsc: Boolean; - var IndexFieldCount: Integer; - var IndexFields: array of integer); -var - i : Integer; - IdxDescrip : PffIndexDescriptor; -begin - IdxDescrip := TffSrBaseCursor(FCursorID).Dictionary.IndexDescriptor[Index]; - Unique := not IdxDescrip.idDups; - IgnoreCase := IdxDescrip.idNoCase; - IndexFieldCount := IdxDescrip.idCount; - IndexAsc := IdxDescrip.idAscend; - for i := 0 to pred(IndexFieldCount) do - IndexFields[i] := IdxDescrip.idFields[i]; -end; - -function TFFSqlTableProxy.Delete : TffResult; {!!.11} -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - Result := TffSrBaseCursor(FCursorID).DeleteRecord(nil); {!!.11} -end; - -function TFFSqlTableProxy.GetRecordCount: Integer; -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - TffSrBaseCursor(FCursorID).GetRecordCount(Result); -end; - -function TFFSqlTableProxy.Update : TffResult; {!!.11} -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - Result := TffSrBaseCursor(FCursorID).ModifyRecord(RecordBuffer, true); {!!.11} -end; - -procedure TFFSqlTableProxy.NullRecord; -var - i: Integer; -begin - for i := 0 to FieldCount - 1 do - Field(i).SetFieldToNull; - NoRecord := True; -end; - -{ TFFSqlFieldProxy } - -constructor TFFSqlFieldProxy.Create(AnOwnerTable: TFFSqlTableProxy; AnIndex: Integer; - ACursorID: TFFCursorID); -begin - inherited Create; - FOwnerTable := AnOwnerTable; - FCursorID := ACursorID; - FIndex := AnIndex; - FIsTarget := False; - FSrcIndex := -1; - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - FieldBufferLength := TffSrBaseCursor(FCursorID).Dictionary.FieldLength[FIndex]; - FFGetMem(FieldBuffer, FieldBufferLength); -end; - -destructor TFFSqlFieldProxy.Destroy; -begin - FFFreeMem(FieldBuffer, FieldBufferLength); - inherited; -end; - -function TFFSqlFieldProxy.GetDecimals: Integer; -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - Result := TffSrBaseCursor(FCursorID).Dictionary.FieldDecPl[FIndex]; -end; - -function TFFSqlFieldProxy.GetSize: Integer; -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - Result := TffSrBaseCursor(FCursorID).Dictionary.FieldUnits[FIndex]; -end; - -function TFFSqlFieldProxy.GetType: TffFieldType; -begin - if not TypeKnown then begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - FType := TffSrBaseCursor(FCursorID).Dictionary.FieldType[FIndex]; - {!!.13 - if FType = fftAutoInc then - FType := fftWord32; - } - TypeKnown := True; - end; - Result := FType; -end; - -procedure TFFSqlFieldProxy.ReadField(var IsNull: Boolean); -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - {$IFOPT C+} - Assert(TffSrBaseCursor(FCursorID).GetRecordField(FIndex, - FOwnerTable.RecordBuffer, IsNull, FieldBuffer) = DBIERR_NONE); - {$ELSE} - TffSrBaseCursor(FCursorID).GetRecordField(FIndex, FOwnerTable.RecordBuffer, - IsNull, FieldBuffer); - {$ENDIF} -end; - -{!!.11 new} -function TffSqlFieldProxy.GetBlobValue: Variant; -{Rewritten !!.13} -var - Offset : Integer; - BLOBNr : TffInt64; - Error, Len : Integer; - BytesRead : TffWord32; - VPtr : PByte; -begin - Offset := TffSrBaseCursor(FCursorID).Dictionary.FieldOffset[Index]; - BLOBNr := PffInt64(@OwnerTable.RecordBuffer^[Offset])^; - Len := TffSrBaseCursor(FCursorID).BLOBGetLength(BLOBNr, Error); - if Error = DBIERR_NONE then begin - if Len = 0 then - Result := null - else begin - Result := VarArrayCreate([1, Len], VarByte); - VPtr := VarArrayLock(Result); - try - TffSrBaseCursor(FCursorID).BLOBRead(BLOBNr, 0, Len, VPtr^, BytesRead); - finally - VarArrayUnlock(Result); - end; - end; - end; -end; - -{!!.11 new} -procedure TffSqlFieldProxy.SetBlobValue(const Value: Variant); -{Rewritten !!.13} -var - Offset : Integer; - BLOBNr : TffInt64; - Error, - Len : Longint; - ValueLen : TffWord32; - ValueLocked : Boolean; - VPtr : PAnsiChar; - VStr : string; -begin - ValueLocked := False; - try - { Obtain the length of the BLOB data & a pointer to the data. } - if TVarData(Value).VType and VarTypeMask = varByte then begin - ValueLen := VarArrayHighBound(Value, 1); - VPtr := VarArrayLock(Value); - ValueLocked := True; - end - else begin - VStr := VarToStr(Value); - ValueLen := Length(VStr); - VPtr := PAnsiChar(VStr); - end; - - Offset := TffSrBaseCursor(FCursorID).Dictionary.FieldOffset[Index]; - BLOBNr := PffInt64(@OwnerTable.RecordBuffer^[Offset])^; - - { If there is already BLOB data, truncate it to the length of the - new value. } - if (BLOBNr.iLow <> 0) or (BLOBNr.iHigh <> 0) then begin - Len := TffSrBaseCursor(FCursorID).BLOBGetLength(BLOBNr, Error); - if TffWord32(Len) > ValueLen then - TffSrBaseCursor(FCursorID).BLOBTruncate(BLOBNr, ValueLen); - { If the new value is null then null the field in the record otherwise - writ the new value over the old value. } - if ValueLen = 0 then - SetFieldToNull - else - { Write the new value over the old value. } - TffSrBaseCursor(FCursorID).BLOBWrite(BLOBNr, 0, ValueLen, VPtr^); - end - else begin - { This is a new BLOB. If it is null then set the field in the record to - null. } - if ValueLen = 0 then - SetFieldToNull - else if TffSrBaseCursor(FCursorID).BLOBAdd(BLOBNr) = DBIERR_NONE then begin - { The BLOB has content & its creation was successful. Write the content - to the table. } - if TffSrBaseCursor(FCursorID).BLOBWrite(BLOBNr, 0, ValueLen, VPtr^) = DBIERR_NONE then - WriteFieldDirect(@BLOBNr); - TffSrBaseCursor(FCursorID).BLOBFree(BLOBNr); - end; - end; { if..else } - finally - if ValueLocked then - VarArrayUnlock(Value); - end; -end; - -function TFFSqlFieldProxy.GetValue: Variant; -var - IsNull : Boolean; - D : double; - W : WideString; - WC : WideChar; - DT : TDateTime; -begin - ReadField(IsNull); - if IsNull then - Result := Null - else case GetType of - fftBoolean : - Result := Boolean(FieldBuffer^[0]); - fftChar : - Result := Char(FieldBuffer^[0]); - fftWideChar : - begin - WC := PWideChar(FieldBuffer)^; - W := WC; - Result := W; - end; - fftByte : - Result := PByte(FieldBuffer)^; - fftWord16 : - Result := PWord(FieldBuffer)^; - fftWord32 : - begin - D := PffWord32(FieldBuffer)^; - Result := D; - end; - fftInt8 : - Result := PShortInt(FieldBuffer)^; - fftInt16 : - Result := PSmallInt(FieldBuffer)^; - fftInt32 : - Result := PInteger(FieldBuffer)^; - fftAutoInc : - begin - D := PffWord32(FieldBuffer)^; - Result := D; - end; - fftSingle : - Result := PSingle(FieldBuffer)^; - fftDouble : - Result := PDouble(FieldBuffer)^; - fftExtended : - Result := PExtended(FieldBuffer)^; - fftComp : - Result := PComp(FieldBuffer)^; - fftCurrency : - Result := PCurrency(FieldBuffer)^; - fftStDate : - Result := StDateToDateTime(PStDate(FieldBuffer)^); - fftStTime : - Result := StTimeToDateTime(PStTime(FieldBuffer)^); - fftDateTime : - begin - DT := PffDateTime(FieldBuffer)^ - 693594.0; - Result := DT; - end; - fftShortString : - Result := PShortString(FieldBuffer)^; - fftShortAnsiStr : - Result := PShortString(FieldBuffer)^; - fftNullString : - Result := StrPas(PChar(FieldBuffer)); - fftNullAnsiStr : - Result := String(PChar(FieldBuffer)); - fftWideString : - Result := WideString(PWideChar(FieldBuffer)); - fftBLOB..fftBLOBFile : {!!.11} - Result := GetBlobValue; {!!.11}{!!.13} - else - Assert(False); - end; -end; - -function TFFSqlFieldProxy.IsNull: Boolean; -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - {$IFOPT C+} - Assert(TffSrBaseCursor(FCursorID).GetRecordField(FIndex, FOwnerTable.RecordBuffer, - Result, FieldBuffer) = DBIERR_NONE); - {$ELSE} - TffSrBaseCursor(FCursorID).GetRecordField(FIndex, FOwnerTable.RecordBuffer, - Result, FieldBuffer); - {$ENDIF} -end; - -function TFFSqlFieldProxy.Name: string; -begin - Assert(FCursorID <> 0); - Assert(TObject(FCursorID) is TffSrBaseCursor); - Result := TffSrBaseCursor(FCursorID).Dictionary.FieldName[FIndex]; -end; - -procedure TFFSqlFieldProxy.WriteField; -begin - TffSrBaseCursor(FCursorID).Dictionary.SetRecordField(FIndex, - FOwnerTable.RecordBuffer, FieldBuffer); -end; - -procedure TFFSqlFieldProxy.WriteFieldDirect(Buffer: PffByteArray); -begin - TffSrBaseCursor(FCursorID).Dictionary.SetRecordField(FIndex, - FOwnerTable.RecordBuffer, Buffer); -end; - -{Begin !!.11} -procedure TffSqlFieldProxy.SetDefault; -begin - TffSrBaseCursor(FCursorID).Dictionary.SetDefaultFieldValue - (FOwnerTable.RecordBuffer, FIndex); -end; -{End !!.11} - -procedure TFFSqlFieldProxy.SetFieldToNull; -begin - TffSrBaseCursor(FCursorID).Dictionary.SetRecordFieldNull( - FIndex, FOwnerTable.RecordBuffer, True); -end; - -procedure TFFSqlFieldProxy.SetValue(const Value: Variant); -var - S : string; - W : WideString; - FT : TffFieldType; - ValueIsNull: Boolean; - LenW : Word; {!!.11} - Len : Integer; {!!.11} -begin - ValueIsNull := VarIsNull(Value); - if ValueIsNull then - SetFieldToNull - else begin - FT := GetType; - case FT of - fftBoolean : - Boolean(FieldBuffer^[0]) := Value; - fftChar : - begin - S := Value; - char(FieldBuffer^[0]) := S[1]; - end; - fftWideChar : - begin - W := Value; - PWideChar(FieldBuffer)^ := W[1]; - end; - fftByte : - PByte(FieldBuffer)^ := Value; - fftWord16 : - PWord(FieldBuffer)^ := Value; - fftWord32 : - PFFWord32(FieldBuffer)^ := {$ifdef fpc}DWORD(Value){$else}Value{$endif}; - fftInt8 : - PShortInt(FieldBuffer)^ := Value; - fftInt16 : - PSmallInt(FieldBuffer)^ := Value; - fftInt32 : - PInteger(FieldBuffer)^ := Value; - fftAutoInc : - PFFWord32(FieldBuffer)^ := {$ifdef fpc}DWORD(Value){$else}Value{$endif}; - fftSingle : - PSingle(FieldBuffer)^ := Value; - fftDouble : - PDouble(FieldBuffer)^ := Value; - fftExtended : - PExtended(FieldBuffer)^ := Value; - fftComp : - PComp(FieldBuffer)^ := Value; - fftCurrency : - PCurrency(FieldBuffer)^ := Value; - fftStDate : - PStDate(FieldBuffer)^ := DateTimeToStDate(Value); - fftStTime : - PStTime(FieldBuffer)^ := DateTimeToStTime(Value); - fftDateTime : - PffDateTime(FieldBuffer)^ := Value + 693594; -{Begin !!.11} - fftShortString, fftShortAnsiStr : - begin - S := Value; - FillChar(FieldBuffer^, FieldBufferLength, 0); - LenW := FFMinI(Length(S), Pred(FieldBufferLength)); - FieldBuffer[0] := LenW; - if S <> '' then {!!.12} - Move(S[1], FieldBuffer[1], LenW); - end; - fftNullString, fftNullAnsiStr : - begin - S := Value; - FillChar(FieldBuffer^, FieldBufferLength, 0); - Len := FFMinI(Length(S), Pred(FieldBufferLength)); - if S <> '' then {!!.12} - Move(S[1], FieldBuffer^, Len); - end; - fftWideString : - begin - W := Value; - FillChar(FieldBuffer^, FieldBufferLength, 0); - if W <> '' then {!!.12} - Move(W[1], FieldBuffer^, - FFMinI(Length(W) * 2, FieldBufferLength - 2)); - end; - fftBLOB..fftBLOBTypedBin : -{Begin !!.13} - begin - SetBLOBValue(Value); - Exit; - end; -{End !!.13} -{End !!.11} - else - Assert(False); - end; - WriteField; - end; -end; - -function TFFSqlFieldProxy.QualName: string; -begin - Result := FOwnerTable.Name + '.' + Name; -end; - -function TFFSqlFieldProxy.CanUpdate: Boolean; -begin - case GetType of - fftBoolean, fftChar, fftWideChar, fftByte, - fftWord16, fftWord32, fftInt8, fftInt16, - fftInt32, fftAutoInc, fftSingle, fftDouble, - fftExtended, fftComp, fftCurrency, fftStDate, - fftStTime, fftDateTime, fftShortString, - fftShortAnsiStr, fftNullString, fftNullAnsiStr, - fftBLOB..fftBLOBTypedBin, {!!.11} - fftWideString : - Result := True; - else - Result := False; - end; -end; - -{!!.11 new} -procedure BMMakeTableS(const MatchString : ShortString; var BT : TBTable); - {-Build a Boyer-Moore link table} -register; -asm - push edi { Save registers because they will be changed } - push esi - mov esi, eax { Move EAX to ESI } - push ebx - - xor eax, eax { Zero EAX } - xor ecx, ecx { Zero ECX } - mov cl, [esi] { ECX has length of MatchString } - inc esi - - mov ch, cl { Duplicate CL in CH } - mov eax, ecx { Fill each byte in EAX with length } - shl eax, 16 - or eax, ecx - mov edi, edx { Point to the table } - mov ecx, 64 { Fill table bytes with length } - rep stosd - cmp al, 1 { If length <= 1, we're done } - jbe @@MTDone - xor ebx, ebx { Zero EBX } - mov cl, al { Restore CL to length of string } - dec ecx - -@@MTNext: - mov al, [esi] { Load table with positions of letters } - mov bl, al { that exist in the search string } - inc esi - mov [edx+ebx], cl - dec cl - jnz @@MTNext - -@@MTDone: - pop ebx { Restore registers } - pop esi - pop edi -end; - -{!!.11 new} -function BMSearchS(var Buffer; BufLength : DWord; const BT : TBTable; - const MatchString : ShortString ; var Pos : Cardinal) : Boolean; assembler; - {-Use the Boyer-Moore search method to search a buffer for a string.} -register; -var - BufPtr : Pointer; -asm - push edi { Save registers since we will be changing } - push esi - push ebx - - mov BufPtr, eax { Copy Buffer to local variable and EDI } - mov edi, eax - mov ebx, ecx { Copy BT ptr to EBX } - mov ecx, edx { Length of buffer to ECX } - mov esi, MatchString { Set ESI to beginning of MatchString } - xor eax, eax { Zero EAX } - - mov dl, [esi] { Length of MatchString in EDX } - inc esi - and edx, 0FFh - - cmp dl, 1 { Check to see if we have a trivial case } - ja @@BMSInit { If Length(MatchString) > 1 do BM search } - jb @@BMSNotFound { If Length(MatchString) = 0 we're done } - - mov al,[esi] { If Length(MatchString) = 1 do a REPNE SCASB } - mov ebx, edi - repne scasb - jne @@BMSNotFound { No match during REP SCASB } - mov esi, Pos { Set position in Pos } - {dec edi} { Found, calculate position } - sub edi, ebx - mov eax, 1 { Set result to True } - mov [esi], edi - jmp @@BMSDone { We're done } - -@@BMSInit: - dec edx { Set up for BM Search } - add esi, edx { Set ESI to end of MatchString } - add ecx, edi { Set ECX to end of buffer } - add edi, edx { Set EDI to first check point } - std { Backward string ops } - mov dh, [esi] { Set DH to character we'll be looking for } - dec esi { Dec ESI in prep for BMSFound loop } - jmp @@BMSComp { Jump to first comparison } - -@@BMSNext: - mov al, [ebx+eax] { Look up skip distance from table } - add edi, eax { Skip EDI ahead to next check point } - -@@BMSComp: - cmp edi, ecx { Have we reached end of buffer? } - jae @@BMSNotFound { If so, we're done } - mov al, [edi] { Move character from buffer into AL for comparison } - cmp dh, al { Compare } - jne @@BMSNext { If not equal, go to next checkpoint } - - push ecx { Save ECX } - dec edi - xor ecx, ecx { Zero ECX } - mov cl, dl { Move Length(MatchString) to ECX } - repe cmpsb { Compare MatchString to buffer } - je @@BMSFound { If equal, string is found } - - mov al, dl { Move Length(MatchString) to AL } - sub al, cl { Calculate offset that string didn't match } - add esi, eax { Move ESI back to end of MatchString } - add edi, eax { Move EDI to pre-string compare location } - inc edi - mov al, dh { Move character back to AL } - pop ecx { Restore ECX } - jmp @@BMSNext { Do another compare } - -@@BMSFound: { EDI points to start of match } - mov edx, BufPtr { Move pointer to buffer into EDX } - mov esi, Pos - sub edi, edx { Calculate position of match } - mov eax, edi - inc eax - inc eax { Pos is one based } - mov [esi], eax { Set Pos to position of match } - mov eax, 1 { Set result to True } - pop ecx { Restore ESP } - jmp @@BMSDone - -@@BMSNotFound: - xor eax, eax { Set result to False } - -@@BMSDone: - cld { Restore direction flag } - pop ebx { Restore registers } - pop esi - pop edi -end; - -{!!.13 new} -function BMSearchUCS(var Buffer; BufLength : Cardinal; const BT : TBTable; - const MatchString : ShortString ; var Pos : Cardinal) : Boolean; assembler; - {-Use the Boyer-Moore search method to search a buffer for a string. This - search is not case sensitive.} -register; -var - BufPtr : Pointer; -asm - push edi { Save registers since we will be changing } - push esi - push ebx - - mov BufPtr, eax { Copy Buffer to local variable and ESI } - mov edi, eax - mov ebx, ecx { Copy BT ptr to EBX } - mov ecx, edx { Length of buffer to ECX } - mov esi, MatchString { Set ESI to beginning of MatchString } - xor eax, eax { Zero EAX } - - mov dl, byte ptr [esi] { Length of MatchString in EDX } - and edx, 0FFh { Clean up EDX } - inc esi { Set ESI to first character } - - or dl, dl { Check to see if we have a trivial case } - jz @@BMSNotFound { If Length(MatchString) = 0 we're done } - -@@BMSInit: - dec edx { Set up for BM Search } - add esi, edx { Set ESI to end of MatchString } - add ecx, edi { Set ECX to end of buffer } - add edi, edx { Set EDI to first check point } - std { Backward string ops } - mov dh, [esi] { Set DH to character we'll be looking for } - dec esi { Dec ESI in prep for BMSFound loop } - jmp @@BMSComp { Jump to first comparison } - -@@BMSNext: - mov al, [ebx+eax] { Look up skip distance from table } - add edi, eax { Skip EDI ahead to next check point } - -@@BMSComp: - cmp edi, ecx { Have we reached end of buffer? } - jae @@BMSNotFound { If so, we're done } - - push ebx { Save registers } - push ecx - push edx - mov al, [edi] { Move character from buffer into AL for comparison } - push eax { Push Char onto stack for CharUpper } - cld - call CharUpper - std - pop edx { Restore registers } - pop ecx - pop ebx - - cmp dh, al { Compare } - jne @@BMSNext { If not equal, go to next checkpoint } - - push ecx { Save ECX } - dec edi - xor ecx, ecx { Zero ECX } - mov cl, dl { Move Length(MatchString) to ECX } - jecxz @@BMSFound { If ECX is zero, string is found } - -@@StringComp: - xor eax, eax - mov al, [edi] { Get char from buffer } - dec edi { Dec buffer index } - - push ebx { Save registers } - push ecx - push edx - push eax { Push Char onto stack for CharUpper } - cld - call CharUpper - std - pop edx { Restore registers } - pop ecx - pop ebx - - mov ah, al { Move buffer char to AH } - mov al, [esi] { Get MatchString char } - dec esi - cmp ah, al { Compare } - loope @@StringComp { OK? Get next character } - je @@BMSFound { Matched! } - - xor ah, ah { Zero AH } - mov al, dl { Move Length(MatchString) to AL } - sub al, cl { Calculate offset that string didn't match } - add esi, eax { Move ESI back to end of MatchString } - add edi, eax { Move EDI to pre-string compare location } - inc edi - mov al, dh { Move character back to AL } - pop ecx { Restore ECX } - jmp @@BMSNext { Do another compare } - -@@BMSFound: { EDI points to start of match } - mov edx, BufPtr { Move pointer to buffer into EDX } - mov esi, Pos - sub edi, edx { Calculate position of match } - mov eax, edi - inc eax - inc eax { Pos is one based } - mov [esi], eax { Set Pos to position of match } - mov eax, 1 { Set result to True } - pop ecx { Restore ESP } - jmp @@BMSDone - -@@BMSNotFound: - xor eax, eax { Set result to False } - -@@BMSDone: - cld { Restore direction flag } - pop ebx { Restore registers } - pop esi - pop edi -end; - -{!!.11 new} -function TFFSqlFieldProxy.BLOBBmSearch(const Table: TBTable; const SearchPhrase: string; - IgnoreCase: Boolean): Boolean; -const - BufferSize = 4096; -var - Offset : Integer; - BLOBNr : TffInt64; - Error, Len : Integer; - BytesRead : TffWord32; - Pos : Cardinal; - ChunkSize, - ChunkOffset : Integer; - Buffer : array[0..BufferSize-1] of char; -begin - Result := False; - Offset := TffSrBaseCursor(FCursorID).Dictionary.FieldOffset[Index]; - BLOBNr := PffInt64(@OwnerTable.RecordBuffer^[Offset])^; - Len := TffSrBaseCursor(FCursorID).BLOBGetLength(BLOBNr, Error); - if Error = DBIERR_NONE then begin - ChunkOffset := 0; - ChunkSize := BufferSize - length(SearchPhrase); - while Len > 0 do begin - TffSrBaseCursor(FCursorID).BLOBRead(BLOBNr, ChunkOffset, BufferSize, Buffer, BytesRead); - {!!.13 begin} - if IgnoreCase then begin - if BMSearchUCS(Buffer, BytesRead, Table, SearchPhrase, Pos) then begin - Result := True; - exit; - end; - end else begin - if BMSearchS(Buffer, BytesRead, Table, SearchPhrase, Pos) then begin - Result := True; - exit; - end; - end; - {!!.13 end} - dec(Len, ChunkSize); - inc(ChunkOffset, ChunkSize); - end; - end; -end; - -{!!.11 new} -function TFFSqlFieldProxy.BMMatch(const Table: TBTable; const SearchPhrase: string; - IgnoreCase: Boolean): Boolean; {!!.13} -var - S: string; - Pos: Cardinal; -begin - if IsNull then - Result := False - else if GetType = fftBLOBMemo then - Result := BLOBBmSearch(Table, SearchPhrase, IgnoreCase) {!!.13} - else begin - S := GetValue; - {!!.13 begin - Result := (S <> '') and BMSearchS(S[1], length(S), Table, SearchPhrase, Pos); - } - Result := False; - if S <> '' then - if IgnoreCase then begin - if BMSearchUCS(S[1], length(S), Table, SearchPhrase, Pos) then - Result := True; - end else - if BMSearchS(S[1], length(S), Table, SearchPhrase, Pos) then - Result := True; - {!!.13 end} - end; -end; - -type - TffHashNodeFriend = class(TffHashNode); - -{===TffNRecordHash========================================================} -procedure TffNRecordHash.Add; -var - keyPtr : PffNRecordHashEntry; - i, Size : Integer; -begin - Size := EntrySlots * sizeOf(TffInt64); - FFGetMem(keyPtr, Size); - for i := 0 to pred(EntrySlots) do - KeyPtr^[i] := FSourceTables[i].GetCurrentRecordID; - //store size of record in hash entry's value field for destruction - {$IFOPT C+} - Assert(fhAddPrim(keyPtr, Pointer(Size))); - {$ELSE} - fhAddPrim(keyPtr, Pointer(Size)); - {$ENDIF} -end; -{--------} -procedure TffNRecordHash.AddTable(const SourceTable: TFFSqlTableProxy); -begin - FFReallocMem(FSourceTables, - EntrySlots * sizeof(TFFSqlTableProxy), - succ(EntrySlots) * sizeof(TFFSqlTableProxy)); - inc(EntrySlots); - FSourceTables^[EntrySlots - 1] := SourceTable; -end; -{--------} -constructor TffNRecordHash.Create; -begin - inherited Create(ffc_Size2099); -end; -{--------} -destructor TffNRecordHash.Destroy; -begin - if FSourceTables <> nil then - FFFreeMem(FSourceTables, EntrySlots * sizeof(TFFSqlTableProxy)); - inherited Destroy; -end; -{--------} -function TffNRecordHash.fhCompareKey(const aKey1 : Pointer; - const aKey2 : Pointer) : Boolean; -var - i : Integer; -begin - for i := 0 to pred(EntrySlots) do - if FFCmpI64(PffNRecordHashEntry(aKey1)^[i], PffNRecordHashEntry(aKey2)^[i]) <> 0 then begin - Result := False; - exit; - end; - Result := True; -end; -{--------} -procedure TffNRecordHash.fhFreeKeyPrim(aKey : pointer); -begin - FFFreeMem(aKey, EntrySlots * sizeOf(TffInt64)); -end; -{--------} -function TffNRecordHash.fhGetIndex(const AKey : Pointer; - const ACount : Integer): Integer; -var - X : TffInt64; - I : Integer; -begin - X := PffNRecordHashEntry(aKey)^[0]; - for i := 1 to pred(EntrySlots) do begin - X.iLow := X.iLow xor PffNRecordHashEntry(aKey)^[i].iLow; - X.iHigh := X.iHigh xor PffNRecordHashEntry(aKey)^[i].iHigh; - end; - Result := ffI64ModInt(X, ACount); -end; -{--------} -function TffNRecordHash.Exists: Boolean; -var - I : integer; - Node : TffHashNode; - keyPtr : PffNRecordHashEntry; -begin - - FFGetMem(keyPtr, EntrySlots * sizeOf(TffInt64)); - try - for i := 0 to pred(EntrySlots) do - KeyPtr^[i] := FSourceTables[i].GetCurrentRecordID; - Result := fhFindPrim(KeyPtr, I, Node); - finally - FFFreeMem(keyPtr, EntrySlots * sizeOf(TffInt64)); - end; -end; - -function TffNRecordHash.fhCreateNode: TffHashNode; -begin - Result := TffNRecordHashNode.Create; -end; -{--------} - - -{ TffNRecordHashNode } - -destructor TffNRecordHashNode.Destroy; -begin - assert(TObject(Self) is TffNRecordHashNode); - assert(fhValue <> nil); - inherited; -end; - -procedure CopyField(const SourceField, TargetField: TffSqlFieldProxy); -var - IsNull: Boolean; -begin - Assert(SourceField.GetType = TargetField.GetType); - SourceField.ReadField(IsNull); - if not IsNull then - TargetField.WriteFieldDirect(SourceField.FieldBuffer) - else - TargetField.SetFieldToNull; -end; - -procedure CopyBLOBField(const SourceField, - TargetField : TffSqlFieldProxy); -var - IsNull : Boolean; - SrcOffset, - TgtOffset : Integer; - aSrcBLOBNr, - aBLOBNr : TffInt64; - aLinkTableName : TffTableName; {!!.11 - New} -begin - Assert(SourceField.GetType = TargetField.GetType); - SourceField.ReadField(IsNull); - if (not IsNull) then begin - Assert(TObject(SourceField.FCursorID) is TffSrBaseCursor); - SrcOffset := TffSrBaseCursor(SourceField.FCursorID).Dictionary.FieldOffset[SourceField.Index]; - TgtOffset := TffSrBaseCursor(TargetField.FCursorID).Dictionary.FieldOffset[TargetField.Index]; - { link the BLOBs } - { Get the BLOB reference out of the record. } - aSrcBLOBNr := PffInt64(@SourceField.OwnerTable.RecordBuffer^[SrcOffset])^; - - with TffSrBaseCursor(TargetField.FCursorID) do begin {!!.11 - Start} - { Clear the null flag for the target field. } {!!.10} - Dictionary.SetRecordFieldNull(TargetField.Index, {!!.10} - TargetField.OwnerTable.RecordBuffer,{!!.10} - False); {!!.10} - - { Is aSrcBLOBNr another BLOB Link? } - if (TffSrBaseCursor(SourceField.FCursorID).BLOBIsLink(aSrcBLOBNr, - aLinkTableName, - aSrcBLOBNr)) then begin - - { Yes. BLOBIsLink filled in the TableName and updated aSrcBLOBNr. } - BLOBLinkAdd(aLinkTableName, - aSrcBLOBNr, - aBLOBNr); - end else begin - { Add a BLOB link. } - BLOBLinkAdd(TffSrBaseCursor(SourceField.FCursorID).Table.BaseName, - aSrcBLOBNr, - aBLOBNr); - end; - end; {!!.11 - End} - - { Update the BLOB reference in the record. } - PffInt64(@TargetField.OwnerTable.RecordBuffer^[TgtOffset])^ := aBLOBNr; - end else - TargetField.SetFieldToNull; -end; - -function CompatibleFields(const SourceField, TargetField: TffSqlFieldProxy): Boolean; -begin - Result := (SourceField.GetType = TargetField.GetType) - and (SourceField.FieldBufferLength = TargetField.FieldBufferLength); -end; - -{ TFFFieldCopier } - -procedure TFFFieldCopier.Add(SourceField, TargetField: TffSqlFieldProxy); -begin - FSourceList.Append(SourceField); - FTargetList.Append(TargetField); - if CompatibleFields(SourceField, TargetField) then begin - FCompatible.Append(Pointer(1)); - case SourceField.GetType of - fftBLOB..fftBLOBFile : - FBlob.Append(Pointer(1)); - else - FBlob.Append(Pointer(0)); - end; - end else begin - FCompatible.Append(Pointer(0)); - FBlob.Append(Pointer(0)); - end; -end; - -constructor TFFFieldCopier.Create; -begin - inherited Create; - FSourceList := TffPointerList.Create; - FTargetList := TffPointerList.Create; - FCompatible := TffPointerList.Create; - FBlob := TffPointerList.Create; -end; - -destructor TFFFieldCopier.Destroy; -begin - FSourceList.Free; - FTargetList.Free; - FCompatible.Free; - FBlob.Free; - inherited; -end; - -procedure TFFFieldCopier.Execute; -var - i : Integer; -begin - for i := 0 to pred(FSourceList.Count) do - if FCompatible[i] <> nil then - if FBlob[i] <> nil then - CopyBLOBField( - TffSqlFieldProxy(FSourceList[i]), - TffSqlFieldProxy(FTargetList[i])) - else - CopyField( - TffSqlFieldProxy(FSourceList[i]), - TffSqlFieldProxy(FTargetList[i])) - else - TffSqlFieldProxy(FTargetList[i]).SetValue( - TffSqlFieldProxy(FSourceList[i]).GetValue); -end; - -{ TffSqlFieldDefList } - -procedure TffSqlFieldDefList.AddField(const aName: string; - aType: TffFieldType; aUnit, aDec: Integer); -var - NewEntry : PFFSqlFieldDefProxyRec; -begin - FFGetZeroMem(NewEntry, sizeof(NewEntry^)); - NewEntry.FieldName := aName; - NewEntry.FieldType := aType; -{Begin !!.13} - { If this field is of type string and the units are set to zero then this - is probably a scalar function that is being applied to a BLOB. Set the # of - units to 255. The value 255 sounds good because the actual size may vary & - we cannot predict what it will be. } - if (aType in [fftShortString..fftWideString]) and (aUnit = 0) then - NewEntry.FieldUnits := 255 - else - NewEntry.FieldUnits := aUnit; -{End !!.13} - NewEntry.Decimals := aDec; - FieldList.Append(NewEntry); -end; - -constructor TffSqlFieldDefList.Create; -begin - inherited Create; - FieldList := TffPointerList.Create; -end; - -destructor TffSqlFieldDefList.Destroy; -var - i: Integer; - P : PFFSqlFieldDefProxyRec; -begin - for i := 0 to pred(FieldList.Count) do begin - P := PFFSqlFieldDefProxyRec(FieldList[i]); - P^.FieldName := ''; - FFFreeMem(P, sizeof(TFFSqlFieldDefProxyRec)); - end; - FieldList.Free; - inherited; -end; - -function TffSqlFieldDefList.GetCount: Integer; -begin - Result := FieldList.Count; -end; - -function TffSqlFieldDefList.GetFieldDecimals(Index: Integer): Integer; -begin - case FieldType[Index] of - fftSingle..fftExtended, fftCurrency : - Result := PFFSqlFieldDefProxyRec(FieldList[Index])^.Decimals; - else - Result := 0; - end; -end; - -function TffSqlFieldDefList.GetFieldName(Index: Integer): string; -begin - Result := PFFSqlFieldDefProxyRec(FieldList[Index])^.FieldName; -end; - -function TffSqlFieldDefList.GetFieldType(Index: Integer): TffFieldType; -begin - Result := PFFSqlFieldDefProxyRec(FieldList[Index])^.FieldType; -end; - -function TffSqlFieldDefList.GetFieldUnits(Index: Integer): Integer; -begin - case FieldType[Index] of - fftChar, - fftWideChar : - Result := 1; - fftAutoInc : - Result := 10; - fftByteArray..fftWideString : - Result := PFFSqlFieldDefProxyRec(FieldList[Index])^.FieldUnits; - else - Result := 0; - end; -end; - -end. - diff --git a/components/flashfiler/sourcelaz/ffsqldef.pas b/components/flashfiler/sourcelaz/ffsqldef.pas deleted file mode 100644 index 9e017a24c..000000000 --- a/components/flashfiler/sourcelaz/ffsqldef.pas +++ /dev/null @@ -1,18199 +0,0 @@ -{*********************************************************} -{* FlashFiler: SQL Class Definitions *} -{*********************************************************} - -(* ***** 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 ***** *) - -{2.11 - extensive changes throughout} - -{$I ffdefine.inc} - -{Enable the following to have index optimization analysis and usage - information logged to a file (used for debugging)} -{.$DEFINE LogIndexAnalysis} - -{Enable the following to have transformation information - logged to a file (used for debugging)} -{$DEFINE LogTransformations} - -{Enable the following to have writes counted} -{.$DEFINE CountWrites} - -{Enable the following to have the root node made available through the global - LastStatement variable below (used for debugging only)} -{.$DEFINE ExposeLastStatement} - -unit ffsqldef; - -interface -uses - Windows, - SysUtils, - Classes, - DB, - {$IFDEF DCC6OrLater} - Variants, - {$ENDIF} - ffllbase, - ffsqldb, - ffhash; - -const - fftInterval = fftReserved20; -{$IFDEF LogIndexAnalysis} - IALogFile = 'c:\ffialog.txt'; -{$ENDIF} -{$IFDEF LogTransformations} - TRLogFile = 'c:\fftrlog.txt'; -{$ENDIF} - -{$IFDEF LogIndexAnalysis} -var - IALog : System.Text; -{$ENDIF} -{$IFDEF LogTransformations} -var - TRLog : System.Text; -{$ENDIF} - -type - TffSqlAggQueryMode = (aqmIdle, aqmGrouping, aqmHaving); - - TffSqlNode = class; - TffSqlStatement = class; - TffSqlEnumMethod = procedure(Node: TffSqlNode) of object; - TffSqlAggregate = class; - TffSqlSELECT = class; - TffSqlColumnListOwner = class; - TffSqlRelOp = (roNone, roEQ, roLE, roL, roG, roGE, roNE); - TffSqlNode = class(TFFObject) - protected - FParent : TffSqlNode; - FOwner : TffSqlStatement; - FOwnerStmt: TffSqlColumnListOwner; {!!.11} - procedure WriteStr(Stream: TStream; const S: string); - procedure WriteEOF(Stream: TStream); - procedure AddTableReference(Select: TffSqlSELECT); virtual; - procedure AddColumnDef(Target: TffSqlColumnListOwner); virtual; - procedure AddAggregate(Target: TList); virtual; - procedure ClearBinding; virtual; - function IsAncestor(const Node : TffSqlNode) : Boolean; - { Returns True if Node is an ancestor of this node. } - procedure ResetConstant; virtual; - procedure FlagAggregate(Select: TffSqlSELECT); virtual; - function GetType: TffFieldType; virtual; - function GetSize: Integer; virtual; - function GetDecimals: Integer; virtual; - function GetOwner: TffSqlStatement; - function GetOwnerSelect : TffSqlSelect; - function GetOwnerStmt: TFFSqlColumnListOwner; {!!.11} - procedure SQLError(const ErrorMsg: string); - procedure AssignError(Source: TffSqlNode); - procedure TypeMismatch; - function BindField(const TableName, - FieldName: string): TFFSqlFieldProxy; virtual; - function IsAggregate: Boolean; virtual; - public - constructor Create(AParent: TffSqlNode); - property Parent : TffSqlNode read FParent write FParent; - property Owner : TffSqlStatement read GetOwner; - property OwnerSelect : TffSqlSelect read GetOwnerSelect; - property OwnerStmt: TFFSqlColumnListOwner read GetOwnerStmt; {!!.11} - procedure EmitSQL(Stream : TStream); virtual; - function SQLText: string; - function Equals(Other: TffSqlNode): Boolean; virtual; abstract; - procedure Assign(const Source: TffSqlNode); virtual; abstract; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); - virtual; abstract; - end; - - TffSqlFieldRef = class(TffSqlNode) - protected - FFieldName: string; - FTableName: string; - TypeKnown : Boolean; - FType : TffFieldType; - FField : TFFSqlFieldProxy; - FGroupField : TffSqlFieldProxy; - WasWildcard: Boolean; - procedure ClearBinding; override; - function GetDecimals: Integer; override; - function GetSize: Integer; override; - function GetTitle(const Qualified : boolean): string; {!!.11} - function GetType: TffFieldType; override; - procedure CheckType; - procedure MatchType(ExpectedType: TffFieldType); - function GetField: TFFSqlFieldProxy; - function GetGroupField : TffSqlFieldProxy; - public - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure Assign(const Source: TffSqlNode); override; - property TableName : string read FTableName write FTableName; - property FieldName : string read FFieldName write FFieldName; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue : Variant; - property Field: TFFSqlFieldProxy read GetField; - property GroupField : TffSqlFieldProxy read GetGroupField; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - function QualName : string; - function IsNull: Boolean; - end; - - TffSqlSimpleExpression = class; - - TAggCounter = class(TffObject) - protected - FMin, FMax : variant; - FSum, FCount : double; - function GetMax: Variant; - function GetMin: Variant; - function GetSum: Variant; - function GetAvg: Variant; - public - procedure Reset; - procedure Add(const Value: Variant); - property Min: Variant read GetMin; - property Max: Variant read GetMax; - property Count: double read FCount; - property Sum: Variant read GetSum; - property Avg: Variant read GetAvg; - end; - - TffSQLAggFunction = (agCount, agMin, agMax, agSum, agAvg); - - TffSqlAggregate = class(TffSqlNode) - protected - FAgFunction: TffSQLAggFunction; - FSimpleExpression : TffSqlSimpleExpression; - FDistinct : Boolean; - FCounter : TAggCounter; - FSourceField: TFFSqlFieldProxy; - function GetTitle(const Qualified : boolean): string; {!!.11} - procedure MatchType(ExpectedType: TffFieldType); - function GetSize: Integer; override; - function GetDecimals: Integer; override; - function GetType: TffFieldType; override; - procedure FlagAggregate(Select: TffSqlSELECT); override; - procedure AddAggregate(Target: TList); override; - function Reduce: Boolean; - public - procedure Assign(const Source: TffSqlNode); override; - destructor Destroy; override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - property AgFunction : TffSQLAggFunction read FAgFunction write FAgFunction; - property SimpleExpression : TffSqlSimpleExpression - read FSimpleExpression write FSimpleExpression; - property Distinct: Boolean read FDistinct write FDistinct; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetAggregateValue: Variant; - procedure CreateCounter(SourceField: TFFSqlFieldProxy); - procedure DeleteCounter; - procedure ResetCounters; - procedure Update; - function ValidType(aType : TffFieldType) : Boolean; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffSqlColumn = class(TffSqlNode) - protected - FColumnName: string; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - property ColumnName: string read FColumnName write FColumnName; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - end; - - TffSqlBaseColumn = class(TffSqlNode) - protected - FFieldName: string; - FTableName: string; - public - property TableName: string read FTableName write FTableName; - property FieldName: string read FFieldName write FFieldName; - end; - - TffSqlGroupColumn = class(TffSqlBaseColumn) - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function QualColumnName: string; virtual; - end; - - TffSqlOrderColumn = class(TffSqlBaseColumn) - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function QualColumnName: string; - end; - - TffSqlSelection = class; - - TffSqlGroupColumnList = class(TffSqlNode) - protected - ColumnList : TList; - procedure Clear; - function GetColumn(Index: Integer): TffSqlGroupColumn; - procedure SetColumn(Index: Integer; const Value: TffSqlGroupColumn); - function GetColumnCount: Integer; - function Reduce: Boolean; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - function AddColumn(Column: TffSqlGroupColumn): TffSqlGroupColumn; - property ColumnCount : Integer read GetColumnCount; - property Column[Index: Integer] : TffSqlGroupColumn read GetColumn write SetColumn; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function Contains(const aColName : string; - Se: TffSqlSelection): Boolean; - end; - - TffSqlIsOp = (ioNull, ioTrue, ioFalse, ioUnknown); - TffSqlIsTest = class(TffSqlNode) - protected - FUnaryNot : Boolean; - FIsOp : TffSqlIsOp; - procedure MatchType(ExpectedType: TffFieldType); - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - property UnaryNot: Boolean read FUnaryNot write FUnaryNot; - property IsOp : TffSqlIsOp read FIsOp write FIsOp; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function AsBoolean(const TestValue: Variant): Boolean; - function Evaluate(Expression: TffSqlSimpleExpression): Boolean; - end; - - TffSqlBetweenClause = class(TffSqlNode) - protected - FSimpleHigh: TffSqlSimpleExpression; - FSimpleLow: TffSqlSimpleExpression; - FNegated : Boolean; - FIsConstant: Boolean; - FIsConstantChecked: Boolean; - procedure CheckIsConstant; - function IsConstant: Boolean; - procedure MatchType(ExpectedType: TffFieldType); - function Reduce: Boolean; - procedure ResetConstant; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - destructor Destroy; override; - property Negated : Boolean read FNegated write FNegated; - property SimpleLow : TffSqlSimpleExpression read FSimpleLow write FSimpleLow; - property SimpleHigh : TffSqlSimpleExpression read FSimpleHigh write FSimpleHigh; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function AsBoolean(const TestValue: Variant): Boolean; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffSqlLikePattern = class(TffObject) - protected - LeadPattern, - TrailPattern : string; - LeadMask, - TrailMask: string; - FloatPatterns, - FloatMasks: TStringList; - public - constructor Create(SearchPattern: string; const Escape: string); - {S is the search pattern; Escape is an optional one-character escape - character} - {S contains the string to be searched for, and optionally one or more - occurrences of - '%' (match zero or more characters of any kind), and/or - '_' (match exactly one character of any kind) - If the Escape character is specified, it defines a character to prefix '%' - or '_' with - to indicate a literal '%' or '_', respectively, in the search phrase S.} - {the search must be case sensitive ('a' <> 'A') } - destructor Destroy; override; - function Find(const TextToSearch: Variant; IgnoreCase: Boolean): Boolean; {!!.13} - {examples: - S = '%Berkeley%' - Find returns true if the string 'Berkeley' exists - anywhere in TextToSearch - S = 'S__' - Find returns true if TextToSearch is exactly thee characters - long and starts with an upper-case 'S' - S = '%c___' - Find returns True if length(TextToSearch) >= 4 and the - last but three is 'c' - S = '=_%' and Escape = '=' - Find returns True if TextToSearch begins - with an underscore. - } - end; - - TffSqlLikeClause = class(TffSqlNode) - protected - FSimpleExp: TffSqlSimpleExpression; - FEscapeExp: TffSqlSimpleExpression; - FNegated : Boolean; - FIsConstant: Boolean; - FIsConstantChecked: Boolean; - Limited: Boolean; - LikePattern: TffSqlLikePattern; - FBMCompat : Boolean; {!!.11} - BMCompatChecked : Boolean; {!!.11} - FBMTable: PBTable; {!!.11} - FBMPhrase: string; {!!.11} - FIgnoreCase: Boolean; {!!.13} - procedure CheckBMCompat; {!!.11} - function IsBMCompatible: Boolean; {!!.11} - function GetBmTable: PBTable; {!!.11} - function CanLimit: Boolean; - function CanReplaceWithCompare: Boolean; - procedure CheckIsConstant; - function GetLowLimit: string; - function GetHighLimit: string; - function IsConstant: Boolean; - procedure MatchType(ExpectedType: TffFieldType); - function Reduce: Boolean; - procedure ResetConstant; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - destructor Destroy; override; - property SimpleExp : TffSqlSimpleExpression read FSimpleExp write FSimpleExp; - property EscapeExp: TffSqlSimpleExpression read FEscapeExp write FEscapeExp; - property Negated : Boolean read FNegated write FNegated; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function AsBoolean(const TestValue: Variant): Boolean; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - property BmTable: PBTable read GetBmTable; {!!.11} - property BmPhrase: string read FBmPhrase; {!!.11} - property IgnoreCase: Boolean read FIgnoreCase write FIgnoreCase; {!!.13} - end; - - TffSqlSimpleExpressionList = class; - - TffSqlInClause = class(TffSqlNode) - protected - FSimpleExp: TffSqlSimpleExpressionList; - FNegated : Boolean; - FSubQuery : TffSqlSELECT; - FIsConstant: Boolean; - FIsConstantChecked: Boolean; - procedure CheckIsConstant; - function IsConstant: Boolean; - procedure MatchType(ExpectedType: TffFieldType); - function Reduce: Boolean; - procedure ResetConstant; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - destructor Destroy; override; - property SimpleExpList : TffSqlSimpleExpressionList - read FSimpleExp write FSimpleExp; - property SubQuery : TffSqlSELECT read FSubQuery write FSubQuery; - property Negated : Boolean read FNegated write FNegated; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function AsBoolean(const TestValue: Variant): Boolean; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffSqlTableExp = class; - - TffSqlMatchOption = (moUnspec, moPartial, moFull); - TffSqlMatchClause = class(TffSqlNode) - protected - FSubQuery : TffSqlSELECT; - FOption: TffSqlMatchOption; - FUnique : Boolean; - procedure MatchType(ExpectedType: TffFieldType); - function Reduce: Boolean; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - destructor Destroy; override; - property Unique: Boolean read FUnique write FUnique; - property Option: TffSqlMatchOption read FOption write FOption; - property SubQuery : TffSqlSELECT read FSubQuery write FSubQuery; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function AsBoolean(const TestValue: Variant): Boolean; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffSqlAllOrAnyClause = class(TffSqlNode) - protected - FSubQuery : TffSqlSELECT; - FAll : Boolean; - procedure MatchType(ExpectedType: TffFieldType); - function Compare(RelOp: TffSqlRelOp; const Val: Variant): Boolean; - function Reduce: Boolean; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - destructor Destroy; override; - property All: Boolean read FAll write FAll; - property SubQuery : TffSqlSELECT read FSubQuery write FSubQuery; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffSqlExistsClause = class(TffSqlNode) - protected - FSubQuery : TffSqlSELECT; - function Reduce: Boolean; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - destructor Destroy; override; - property SubQuery : TffSqlSELECT read FSubQuery write FSubQuery; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function AsBoolean: Boolean; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffSqlUniqueClause = class(TffSqlNode) - protected - FSubQuery: TffSqlTableExp; - function Reduce: Boolean; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - destructor Destroy; override; - property SubQuery : TffSqlTableExp read FSubQuery write FSubQuery; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function AsBoolean: Boolean; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffSqlCondPrimary = class(TffSqlNode) - protected - FSimpleExp1: TffSqlSimpleExpression; - FRelOp: TffSqlRelOp; - FSimpleExp2: TffSqlSimpleExpression; - FBetweenClause : TffSqlBetweenClause; - FLikeClause : TffSqlLikeClause; - FInClause : TffSqlInClause; - FIsTest : TffSqlIsTest; - FAllOrAnyClause : TffSqlAllOrAnyClause; - FExistsClause : TFfSqlExistsClause; - FUniqueClause : TFfSqlUniqueClause; - FMatchClause : TffSqlMatchClause; - TypeChecked : Boolean; - FIsConstant: Boolean; - FIsConstantChecked: Boolean; - ConstantValue: Variant; - procedure Clear; - procedure CheckIsConstant; - function IsConstant: Boolean; - procedure CheckType; - function GetType: TffFieldType; override; - function GetDecimals: Integer; override; - function GetSize: Integer; override; - function GetTitle(const Qualified : boolean): string; {!!.11} - function JustSimpleExpression: Boolean; - procedure MatchType(ExpectedType: TffFieldType); {!!.11} - function Reduce: Boolean; - procedure ResetConstant; override; - public - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - destructor Destroy; override; - procedure Assign(const Source: TffSqlNode); override; - property SimpleExp1 : TffSqlSimpleExpression - read FSimpleExp1 write FSimpleExp1; - property RelOp : TffSqlRelOp read FRelOp write FRelOp; - property SimpleExp2 : TffSqlSimpleExpression - read FSimpleExp2 write FSimpleExp2; - property BetweenClause : TffSqlBetweenClause - read FBetweenClause write FBetweenClause; - property LikeClause : TffSqlLikeClause read FLikeClause write FLikeClause; - property InClause : TffSqlInClause read FInClause write FInClause; - property IsTest : TffSqlIsTest read FIsTest write FIsTest; - property AllOrAnyClause : TffSqlAllOrAnyClause - read FAllOrAnyClause write FAllOrAnyClause; - property ExistsClause : TffSqlExistsClause - read FExistsClause write FExistsClause; - property UniqueClause : TffSqlUniqueClause - read FUniqueClause write FUniqueClause; - property MatchClause : TffSqlMatchClause read FMatchClause write FMatchClause; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function AsBoolean: Boolean; - function GetValue: Variant; - procedure BindHaving; - function IsRelationTo(Table : TFFSqlTableProxy; - var FieldReferenced: TFFSqlFieldProxy; - var Operator: TffSqlRelOp; - var ArgExpression: TffSqlSimpleExpression; - var SameCase: Boolean): Boolean; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffSqlCondFactor = class(TffSqlNode) - protected - FUnaryNot: Boolean; - FCondPrimary: TffSqlCondPrimary; - FIsConstant: Boolean; - FIsConstantChecked: Boolean; - ConstantValue: Variant; - TmpKnown: Boolean; - TmpValue: Boolean; - EvalLevel: Integer; - procedure CheckIsConstant; - procedure Clear; - function IsConstant: Boolean; - function GetType: TffFieldType; override; - function GetDecimals: Integer; override; - function GetSize: Integer; override; - function GetTitle(const Qualified : boolean): string; {!!.11} - procedure MatchType(ExpectedType: TffFieldType); {!!.11} - function Reduce: Boolean; - procedure ResetConstant; override; - public - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure Assign(const Source: TffSqlNode); override; - destructor Destroy; override; - property UnaryNot : Boolean read FUnaryNot write FUnaryNot; - property CondPrimary : TffSqlCondPrimary read FCondPrimary write FCondPrimary; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function AsBoolean: Boolean; - function GetValue: Variant; - procedure BindHaving; - function IsRelationTo(Table : TFFSqlTableProxy; - var FieldReferenced: TFFSqlFieldProxy; - var Operator: TffSqlRelOp; - var ArgExpression: TffSqlSimpleExpression; - var SameCase: Boolean): Boolean; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - procedure MarkTrue; - procedure MarkUnknown; - end; - - TffSqlCondExp = class; - TFFObjectProc = procedure of object; - - TFFSqlKeyRelation = record - CondF : TFFSqlCondFactor; - RelationB: array[0..pred(ffcl_MaxIndexFlds)] of TffSqlCondFactor; {!!.11} - NativeKeyIndex: Integer; - RelationFieldCount, - RelationKeyFieldCount: Integer; - RelationOperators : array[0..pred(ffcl_MaxIndexFlds)] of TffSqlRelOp; - RelationOperatorB : array[0..pred(ffcl_MaxIndexFlds)] of TffSqlRelOp; {!!.11} - RelationKeyIsUnique: Boolean; - RelationKeyIsCaseInsensitive: Boolean; - RelationKeyIndexAsc : Boolean; - ArgExpressionB : array[0..pred(ffcl_MaxIndexFlds)] of TffSqlSimpleExpression; {!!.11} - ArgExpressions : array[0..pred(ffcl_MaxIndexFlds)] of TffSqlSimpleExpression; - {$IFDEF LogIndexAnalysis} - RelationFields : array[0..pred(ffcl_MaxIndexFlds)] of TFFSqlFieldProxy; - {$ENDIF} - SameCases : array[0..pred(ffcl_MaxIndexFlds)] of Boolean; - SameCaseB: array[0..pred(ffcl_MaxIndexFlds)] of Boolean; {!!.11} - DepIndex: Integer; - end; - - TFFSqlTableProxySubset = class(TffObject) - protected - FTable : TFFSqlTableProxy; - FOpposite: TFFSqlTableProxy; - FOuter: Boolean; - public - Relations: Integer; - KeyRelation: TffSqlKeyRelation; - constructor Create(Table: TFFSqlTableProxy); - function EqualKeyDepth: Integer; - procedure Iterate(Iterator: TFFSqlTableIterator; Cookie: TffWord32); - property Table : TFFSqlTableProxy read FTable; - procedure Assign(const Source: TFFSqlTableProxySubset); - function UniqueValue: Boolean; - function ClosedSegment: Boolean; - function KeyDepth: Integer; - property Outer: Boolean read FOuter write FOuter; - property Opposite: TFFSqlTableProxy read FOpposite write FOpposite; - end; - - TFFSqlTableProxySubsetList = class; - - TffSqlCondTerm = class(TffSqlNode) - protected - CondFactorList : TList; - FIsConstant: Boolean; - FIsConstantChecked: Boolean; - ConstantValue: Variant; - OrderedSources : TFFSqlTableProxySubsetList; - procedure Clear; - procedure CheckIsConstant; - function IsConstant: Boolean; - function GetCondFactor(Index: Integer): TffSqlCondFactor; - procedure SetCondFactor(Index: Integer; const Value: TffSqlCondFactor); - function GetCondFactorCount: Integer; - function GetSize: Integer; override; - function GetTitle(const Qualified : boolean): string; {!!.11} - function GetType: TffFieldType; override; - function GetDecimals: Integer; override; - function Reduce: Boolean; - procedure ResetConstant; override; - function AsBooleanLevel(Level: Integer): Boolean; - procedure MatchType(ExpectedType: TffFieldType); {!!.11} - public - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure Assign(const Source: TffSqlNode); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - function AddCondFactor(Factor : TffSqlCondFactor): TffSqlCondFactor; - function InsertCondFactor(Index: Integer; Factor : TffSqlCondFactor): - TffSqlCondFactor; - property CondFactorCount : Integer read GetCondFactorCount; - property CondFactor[Index: Integer] : TffSqlCondFactor - read GetCondFactor write SetCondFactor; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function AsBoolean: Boolean; - function GetValue: Variant; - procedure BindHaving; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - procedure SetLevelDep(List: TFFSqlTableProxySubsetList); - end; - - TFFSqlTableProxySubsetList = class(TffObject) - protected - FList : TList; - Level : Integer; - FCondTerm : TffSqlCondTerm; - FCreateResultRecord : TFFObjectProc; - FRecordsRead : Longint; - FOwner: TffSqlStatement; - WroteRow: Boolean; - FOuterJoin: Boolean; - FSkipInner: Boolean; - V : array[0..pred(ffcl_MaxIndexFlds)] of Variant; - VB : array[0..pred(ffcl_MaxIndexFlds)] of Variant; {!!.11} - procedure ReadSources; - function GetItem(Index: Integer): TFFSqlTableProxySubset; - function GetCount: Integer; - function ProcessLevel(Cookie1: TffWord32): Boolean; - procedure Clear; - function Insert( - TableProxySubset: TFFSqlTableProxySubset): TFFSqlTableProxySubset; - public - constructor Create(AOwner: TffSqlStatement); - destructor Destroy; override; - function Add(TableProxySubset: TFFSqlTableProxySubset): TFFSqlTableProxySubset; - procedure Delete(Index: Integer); - property Item[Index: Integer]: TFFSqlTableProxySubset read GetItem; - property Count: Integer read GetCount; - procedure Assign(const Source: TFFSqlTableProxySubsetList); - function RelationUsed(Relation: TffSqlCondFactor): Boolean; - function DependencyExists(Table : TFFSqlTableProxy): Boolean; - procedure Join( - CondTerm: TffSqlCondTerm; - CreateResultRecord: TFFObjectProc); - property RecordsRead : Longint read FRecordsRead; - property Owner: TffSqlStatement read FOwner; - property OuterJoin: Boolean read FOuterJoin write FOuterJoin; - property SkipInner: Boolean read FSkipInner write FSkipInner; - end; - - TffSqlCondExp = class(TffSqlNode) - protected - CondTermList : TList; - FIsConstant: Boolean; - FIsConstantChecked: Boolean; - ConstantValue: Variant; - procedure Clear; - procedure CheckIsConstant; - function IsConstant: Boolean; - function GetCondTerm(Index: Integer): TffSqlCondTerm; - procedure SetCondTerm(Index: Integer; const Value: TffSqlCondTerm); - function GetCondTermCount: Integer; - procedure MatchType(ExpectedType: TffFieldType); - function GetType: TffFieldType; override; - function GetDecimals: Integer; override; - function GetSize: Integer; override; - procedure ResetConstant; override; - function Reduce: Boolean; - function AsBooleanLevel(Level: Integer): Boolean; - procedure SetLevelDep(List: TFFSqlTableProxySubsetList); - function GetTitle(const Qualified : boolean): string; {!!.11} - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - function AddCondTerm(Term : TffSqlCondTerm): TffSqlCondTerm; - property CondTermCount : Integer read GetCondTermCount; - property CondTerm[Index: Integer] : TffSqlCondTerm - read GetCondTerm write SetCondTerm; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function AsBoolean: Boolean; - function GetValue: Variant; - procedure BindHaving; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffComp = array[0..7] of Byte; - - TffSqlFloatLiteral = class(TffSqlNode) - protected - FValue : string; - SingleValue : single; - DoubleValue : double; - ExtendedValue : extended; - CompValue : TffComp; - CurrencyValue : currency; - Converted: Boolean; - procedure ConvertToNative; - procedure MatchType(ExpectedType: TffFieldType); - function GetType: TffFieldType; override; - function GetDecimals: Integer; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - property Value : string read FValue write FValue; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Variant; - end; - - TffSqlIntegerLiteral = class(TffSqlNode) - protected - FValue : string; - Int32Value: Integer; - Converted: Boolean; - procedure ConvertToNative; - procedure MatchType(ExpectedType: TffFieldType); - function GetType: TffFieldType; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - property Value : string read FValue write FValue; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Variant; - end; - - TffSqlStringLiteral = class(TffSqlNode) - protected - FValue : string; - FType : TffFieldType; - Converted : Boolean; - CharValue : Char; - WideCharValue : WideChar; - ShortStringValue : ShortString; - ShortAnsiStringValue : ShortString; - NullStringValue : string; - NullAnsiStrValue : string; - WideStringValue : WideString; - procedure ConvertToNative; - procedure MatchType(ExpectedType: TffFieldType); - function GetSize: Integer; override; - function GetType: TffFieldType; override; - public - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure Assign(const Source: TffSqlNode); override; - constructor Create(AParent: TffSqlNode); - property Value : string read FValue write FValue; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Variant; - end; - - TffSqlIntervalDef = (iUnspec, iYear, iMonth, iDay, iHour, iMinute, iSecond); - TffSqlIntervalLiteral = class(TffSqlNode) - protected - FValue : string; - FStartDef : TffSqlIntervalDef; - FEndDef : TffSqlIntervalDef; - Y1, M1, D1, H1, S1 : Integer; - Converted: Boolean; - procedure ConvertToNative; - procedure MatchType(ExpectedType: TffFieldType); - function GetType: TffFieldType; override; - function AddIntervalTo(Target: TDateTime): TDateTime; - function SubtractIntervalFrom(Target: TDateTime): TDateTime; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - property Value : string read FValue write FValue; - property StartDef : TffSqlIntervalDef read FStartDef write FStartDef; - property EndDef : TffSqlIntervalDef read FEndDef write FEndDef; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Variant; - end; - - TffSqlTimestampLiteral = class(TffSqlNode) - protected - FValue : string; - DateTimeValue: TDateTime; - Converted: Boolean; - procedure ConvertToNative; - procedure MatchType(ExpectedType: TffFieldType); - function GetType: TffFieldType; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - property Value : string read FValue write FValue; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Variant; - end; - - TffSqlTimeLiteral = class(TffSqlNode) - protected - FValue : string; - TimeValue : TDateTime; - Converted : Boolean; - procedure ConvertToNative; - procedure MatchType(ExpectedType: TffFieldType); - function GetType: TffFieldType; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - property Value : string read FValue write FValue; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Variant; - end; - - TffSqlDateLiteral = class(TffSqlNode) - protected - FValue : string; - DateValue : TDateTime; - Converted : Boolean; - procedure ConvertToNative; - procedure MatchType(ExpectedType: TffFieldType); - function GetType: TffFieldType; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - property Value : string read FValue write FValue; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Variant; - end; - - TffSqlBooleanLiteral = class(TffSqlNode) - protected - FValue : Boolean; - procedure MatchType(ExpectedType: TffFieldType); - function GetType: TffFieldType; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - property Value : Boolean read FValue write FValue; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Boolean; - end; - - TffSqlLiteral = class(TffSqlNode) - protected - FFloatLiteral: TffSqlFloatLiteral; - FIntegerLiteral: TffSqlIntegerLiteral; - FStringLiteral: TffSqlStringLiteral; - FDateLiteral : TffSqlDateLiteral; - FTimeLiteral : TffSqlTimeLiteral; - FTimeStampLiteral : TffSqlTimestampLiteral; - FIntervalLiteral : TffSqlIntervalLiteral; - FBooleanLiteral: TffSqlBooleanLiteral; - procedure Clear; - procedure MatchType(ExpectedType: TffFieldType); - function GetSize: Integer; override; - function GetType: TffFieldType; override; - function GetDecimals: Integer; override; - function AddIntervalTo(Target: TDateTime): TDateTime; - function SubtractIntervalFrom(Target: TDateTime): TDateTime; - public - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure Assign(const Source: TffSqlNode); override; - destructor Destroy; override; - property BooleanLiteral : TffSqlBooleanLiteral - read FBooleanLiteral write FBooleanLiteral; - property FloatLiteral : TffSqlFloatLiteral - read FFloatLiteral write FFloatLiteral; - property IntegerLiteral : TffSqlIntegerLiteral - read FIntegerLiteral write FIntegerLiteral; - property StringLiteral : TffSqlStringLiteral - read FStringLiteral write FStringLiteral; - property DateLiteral : TffSqlDateLiteral - read FDateLiteral write FDateLiteral; - property TimeLiteral : TffSqlTimeLiteral - read FTimeLiteral write FTimeLiteral; - property TimeStampLiteral : TffSqlTimestampLiteral - read FTimestampLiteral write FTimestampLiteral; - property IntervalLiteral : TffSqlIntervalLiteral - read FIntervalLiteral write FIntervalLiteral; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue : Variant; - end; - - TffSqlParam = class(TffSqlNode) - protected - FParmIndex: Integer; - function GetSize: Integer; override; - function GetTitle(const Qualified : boolean): string; {!!.11} - function GetType: TffFieldType; override; - procedure MatchType(ExpectedType: TffFieldType); - function GetDecimals: Integer; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - property ParmIndex: Integer read FParmIndex; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Variant; - end; - - TffSqlCoalesceExpression = class(TffSqlNode) - protected - ArgList : TList; - procedure Clear; - function GetArg(Index: Integer): TffSqlSimpleExpression; - function GetArgCount: Integer; - function GetSize: Integer; override; - function GetType: TffFieldType; override; - function Reduce: Boolean; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - property ArgCount : Integer read GetArgCount; - property Arg[Index: Integer]: TffSqlSimpleExpression read GetArg; - function AddArg(Value: TffSqlSimpleExpression): TffSqlSimpleExpression; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Variant; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffSqlWhenClause = class(TffSqlNode) - protected - FWhenExp : TffSqlCondExp; - FThenExp : TffSqlSimpleExpression; - FIsConstant: Boolean; - FIsConstantChecked: Boolean; - procedure CheckIsConstant; - function IsConstant: Boolean; - procedure ResetConstant; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - destructor Destroy; override; - property WhenExp : TffSqlCondExp read FWhenExp write FWhenExp; - property ThenExp : TffSqlSimpleExpression read FThenExp write FThenExp; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffSqlWhenClauseList = class(TffSqlNode) - protected - WhenClauseList : TList; - FIsConstant: Boolean; - FIsConstantChecked: Boolean; - procedure Clear; - procedure CheckIsConstant; - function IsConstant: Boolean; - function GetWhenClause(Index: Integer): TffSqlWhenClause; - function GetWhenClauseCount: Integer; - procedure ResetConstant; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - property WhenClauseCount : Integer read GetWhenClauseCount; - property WhenClause[Index: Integer]: TffSqlWhenClause read GetWhenClause; - function AddWhenClause(Value: TffSqlWhenClause): TffSqlWhenClause; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffSqlCaseExpression = class(TffSqlNode) - protected - FWhenClauseList : TffSqlWhenClauseList; - FElseExp : TffSqlSimpleExpression; - FIsConstant: Boolean; - FIsConstantChecked: Boolean; - ConstantValue: Variant; - procedure CheckIsConstant; - function GetSize: Integer; override; - function GetType: TffFieldType; override; - function IsConstant: Boolean; - function Reduce: Boolean; - procedure ResetConstant; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - destructor Destroy; override; - property WhenClauseList : TffSqlWhenClauseList - read FWhenClauseList write FWhenClauseList; - property ElseExp : TffSqlSimpleExpression read FElseExp write FElseExp; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Variant; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffSqlScalarFunction = (sfCase, sfCharlen, sfCoalesce, sfCurrentDate, sfCurrentTime, - sfCurrentTimestamp, sfCurrentUser, sfLower, sfUpper, sfPosition, - sfSessionUser, sfSubstring, sfSystemUser, sfTrim, sfExtract, sfNullIf, - sfAbs, sfCeil, sfFloor, sfExp, sfLog, sfPower, sfRand, sfRound); {!!.11} - TffSqlLTB = (ltbBoth, ltbLeading, ltbTrailing); - TffSqlScalarFunc = class(TffSqlNode) - protected - FSQLFunction : TffSqlScalarFunction; - FArg1 : TffSqlSimpleExpression; - FArg2 : TffSqlSimpleExpression; - FArg3 : TffSqlSimpleExpression; - FLTB : TffSqlLTB; - FXDef : TffSqlIntervalDef; - FCaseExp : TffSqlCaseExpression; - FCoalesceExp : TffSqlCoalesceExpression; - FIsConstant: Boolean; - FIsConstantChecked: Boolean; - FType : TffFieldType; - TypeKnown : Boolean; - ConstantValue: Variant; - procedure Clear; - procedure CheckIsConstant; - function IsConstant: Boolean; - function IsFieldFrom(Table: TFFSqlTableProxy; - var FieldReferenced: TFFSqlFieldProxy): Boolean; - function GetTitle(const Qualified : boolean): string; {!!.11} - procedure MatchType(ExpectedType: TffFieldType); - function GetDecimals: Integer; override; - function GetSize: Integer; override; - function GetType: TffFieldType; override; - procedure CheckType; - function Reduce: Boolean; - procedure ResetConstant; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - destructor Destroy; override; - property SQLFunction : TffSqlScalarFunction - read FSQLFunction write FSQLFunction; - property Arg1 : TffSqlSimpleExpression read FArg1 write FArg1; - property Arg2 : TffSqlSimpleExpression read FArg2 write FArg2; - property Arg3 : TffSqlSimpleExpression read FArg3 write FArg3; - property LTB : TffSqlLTB read FLTB write FLTB; - property XDef : TffSqlIntervalDef read FXDef write FXDef; - property CaseExp : TffSqlCaseExpression read FCaseExp write FCaseExp; - property CoalesceExp : TFFSqlCoalesceExpression - read FCoalesceExp write FCoalesceExp; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Variant; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffSqlMulOp = (moMul, moDiv); - TffSqlFactor = class(TffSqlNode) - protected - TypeKnown : Boolean; - FType : TffFieldType; - FMulOp: TffSqlMulOp; - FUnaryMinus : Boolean; - FCondExp: TffSqlCondExp; - FFieldRef: TffSqlFieldRef; - FLiteral: TffSqlLiteral; - FParam: TffSqlParam; - FAggregate : TffSqlAggregate; - FSubQuery : TffSqlSELECT; - FScalarFunc : TffSqlScalarFunc; - FIsConstant: Boolean; - FIsConstantChecked: Boolean; - ConstantValue: Variant; - procedure Clear; - procedure CheckIsConstant; - function IsConstant: Boolean; - function GetDecimals: Integer; override; - function GetSize: Integer; override; - function GetType: TffFieldType; override; - procedure CheckType; - function GetTitle(const Qualified : boolean): string; {!!.11} - procedure MatchType(ExpectedType: TffFieldType); - function IsAggregate: Boolean; override; - function AddIntervalTo(Target: TDateTime): TDateTime; - function Reduce: Boolean; - function SubtractIntervalFrom(Target: TDateTime): TDateTime; - procedure ResetConstant; override; - public - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure Assign(const Source: TffSqlNode); override; - destructor Destroy; override; - property MulOp :TffSqlMulOp read FMulOp write FMulOp; - property UnaryMinus : Boolean read FUnaryMinus write FUnaryMinus; - property CondExp : TffSqlCondExp read FCondExp write FCondExp; - property FieldRef : TffSqlFieldRef read FFieldRef write FFieldRef; - property Literal : TffSqlLiteral read FLiteral write FLiteral; - property Param : TffSqlParam read FParam write FParam; - property Aggregate : TffSqlAggregate read FAggregate write FAggregate; - property SubQuery : TffSqlSELECT read FSubQuery write FSubQuery; - property ScalarFunc : TffSqlScalarFunc read FScalarFunc write FScalarFunc; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Variant; - function HasFieldRef: Boolean; - function IsField(var FieldReferenced: TFFSqlFieldProxy): Boolean; - function IsFieldFrom(Table: TFFSqlTableProxy; - var FieldReferenced: TFFSqlFieldProxy; var SameCase: Boolean): Boolean; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - function IsNull: Boolean; - function WasWildcard : Boolean; {!!.11} - end; - - TffSqlAddOp = (aoPlus, aoMinus, aoConcat); - TffSqlTerm = class(TffSqlNode) - protected - TypeKnown : Boolean; - FType : TffFieldType; - FAddOp: TffSqlAddOp; - FactorList : TList; - FIsConstantChecked: Boolean; - FIsConstant: Boolean; - ConstantValue: Variant; - procedure Clear; - procedure CheckIsConstant; - function IsConstant: Boolean; - function GetFactor(Index: Integer): TffSqlFactor; - procedure SetFactor(Index: Integer; const Value: TffSqlFactor); - function GetFactorCount: Integer; - function GetDecimals: Integer; override; - function GetSize: Integer; override; - function GetType: TffFieldType; override; - procedure CheckType; - function GetTitle(const Qualified : boolean): string; {!!.11} - procedure MatchType(ExpectedType: TffFieldType); - function IsAggregate: Boolean; override; - //function GetAgg: TffSqlAggregate; override; - function AddIntervalTo(Target: TDateTime): TDateTime; - function SubtractIntervalFrom(Target: TDateTime): TDateTime; - function Reduce: Boolean; - procedure ResetConstant; override; - public - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure Assign(const Source: TffSqlNode); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - function AddFactor(Factor: TffSqlFactor): TffSqlFactor; - property FactorCount : Integer read GetFactorCount; - property Factor[Index: Integer] : TffSqlFactor read GetFactor write SetFactor; - property AddOp :TffSqlAddOp read FAddOp write FAddOp; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Variant; - function HasFieldRef: Boolean; - function IsField(var FieldReferenced: TFFSqlFieldProxy): Boolean; - function IsFieldFrom(Table: TFFSqlTableProxy; - var FieldReferenced: TFFSqlFieldProxy; var SameCase: Boolean): Boolean; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - function IsAggregateExpression: Boolean; - function IsNull: Boolean; - function WasWildcard : Boolean; {!!.11} - end; - - TffSqlSimpleExpression = class(TffSqlNode) - protected - TypeKnown : Boolean; - FType : TffFieldType; - BoundHaving : Boolean; - BoundHavingField : TFFSqlFieldProxy; - FIsConstant : Boolean; - FIsConstantChecked: Boolean; - ConstantValue: Variant; - BindingHaving: Boolean; - procedure BindHaving; - procedure Clear; - function ConcatBLOBValues(const Value1, Value2 : Variant) : Variant; {!!.13} - function GetTerm(Index: Integer): TffSqlTerm; - procedure SetTerm(Index: Integer; const Value: TffSqlTerm); - function GetTermCount: Integer; - function GetSize: Integer; override; - function GetDecimals: Integer; override; - function GetType: TffFieldType; override; - procedure CheckType; - function GetTitle(const Qualified : boolean): string; {!!.11} - procedure MatchType(ExpectedType: TffFieldType); - function IsAggregate: Boolean; override; - function IsConstant: Boolean; - function IsParameter: Boolean; - procedure CheckIsConstant; - function Reduce: Boolean; - procedure ResetConstant; override; - protected - TermList : TList; - public - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure Assign(const Source: TffSqlNode); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - function AddTerm(Term : TffSqlTerm): TffSqlTerm; - property TermCount : Integer read GetTermCount; - property Term[Index: Integer] : TffSqlTerm read GetTerm write SetTerm; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetValue: Variant; - function HasFieldRef: Boolean; - function IsField(var FieldReferenced: TFFSqlFieldProxy): Boolean; - function IsFieldFrom(Table: TFFSqlTableProxy; - var FieldReferenced: TFFSqlFieldProxy; var SameCase: Boolean): Boolean; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - function IsAggregateExpression: Boolean; - function IsNull: Boolean; - function WasWildcard : Boolean; {!!.11} - end; - - TffSqlSimpleExpressionList = class(TffSqlNode) - protected - FExpressionList : TList; - FIsConstant: Boolean; - FIsConstantChecked: Boolean; - procedure CheckIsConstant; - procedure Clear; - function IsConstant: Boolean; - function GetExpression(Index: Integer): TffSqlSimpleExpression; - function GetExpressionCount: Integer; - procedure SetExpression(Index: Integer; - const Value: TffSqlSimpleExpression); - procedure MatchType(ExpectedType: TffFieldType); - function Contains(const TestValue: Variant): Boolean; - function Reduce: Boolean; - procedure ResetConstant; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - function AddExpression(Expression: TffSqlSimpleExpression): - TffSqlSimpleExpression; - property ExpressionCount : Integer read GetExpressionCount; - property Expression[Index: Integer] : TffSqlSimpleExpression - read GetExpression write SetExpression; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - end; - - TffSqlSelection = class(TffSqlNode) - protected - FColumn: TffSqlColumn; - FSimpleExpression: TffSqlSimpleExpression; - AddedByWildcard: Boolean; - procedure AddColumnDef(Target: TffSqlColumnListOwner); override; - function GetIndex: Integer; - function Reduce: Boolean; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - destructor Destroy; override; - property SimpleExpression : TffSqlSimpleExpression - read FSimpleExpression write FSimpleExpression; - property Column : TffSqlColumn read FColumn write FColumn; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - property Index: Integer read GetIndex; - function IsAggregateExpression: Boolean; - end; - - TffSqlSelectionList = class(TffSqlNode) - protected - FSelections : TList; - procedure Clear; - function GetSelection(Index: Integer): TffSqlSelection; - procedure SetSelection(Index: Integer; - const Value: TffSqlSelection); - function GetSelectionCount: Integer; - function Reduce: Boolean; -// procedure ResetConstant; override; - function GetNonWildSelection(Index: Integer): TffSqlSelection; - property NonWildSelection[Index: Integer]: TffSqlSelection - read GetNonWildSelection; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - function AddSelection(NewSelection: TffSqlSelection): TffSqlSelection; - procedure InsertSelection(Index: Integer; NewSelection: TffSqlSelection); - property SelectionCount : Integer read GetSelectionCount; - property Selection[Index: Integer]: TffSqlSelection - read GetSelection write SetSelection; - function FindSelection(GroupCol : TffSqlGroupColumn): TffSqlSelection; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function NonWildSelectionCount: Integer; - end; - - TffSqlInsertColumnList = class; - - TffSqlTableRef = class(TffSqlNode) - protected - FAlias : string; - FTableName : string; - FTableExp: TffSqlTableExp; - FColumnList: TFFSqlInsertColumnList; - FDatabaseName: string; - FTable: TffSqlTableProxy; - procedure AddTableReference(Select: TffSqlSELECT); override; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - procedure Execute( - var aLiveResult: Boolean; var aCursorID: TffCursorID; - var RecordsRead: Integer); - function GetResultTable: TFFSqlTableProxy; - function GetSQLName: string; - function BindFieldDown(const TableName, - FieldName: string): TFFSqlFieldProxy; - function BindTable(AOwner: TObject; const TableName: string): TFFSqlTableProxy; - function Reduce: Boolean; {!!.11} - function TargetFieldFromSourceField(const F: TffSqlFieldProxy): TffSqlFieldProxy; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - property TableName : string read FTableName write FTableName; - property DatabaseName: string read FDatabaseName write FDatabaseName; - property Alias : string read FAlias write FAlias; - property TableExp: TffSqlTableExp read FTableExp write FTableExp; - property ColumnList : TFFSqlInsertColumnList - read FColumnList write FColumnList; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - procedure Clear; - destructor Destroy; override; - property SQLName: string read GetSQLName; - function GetTable(AOwner: TObject; const ExclContLock : Boolean): TffSqlTableProxy; - property ResultTable: TFFSqlTableProxy read GetResultTable; - end; - - TffSqlTableRefList = class(TffSqlNode) - protected - FTableRefList : TList; - function BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; - procedure Clear; - function GetTableRef(Index: Integer): TffSqlTableRef; - procedure SetTableRef(Index: Integer; - const Value: TffSqlTableRef); - function GetTableRefCount: Integer; - function Reduce: Boolean; - function BindFieldDown(const TableName, - FieldName: string): TFFSqlFieldProxy; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - function AddTableRef(NewTableRef: TffSqlTableRef): TffSqlTableRef; - function GetNameForAlias(const Alias : string) : string; - property TableRefCount : Integer read GetTableRefCount; - property TableRef[Index: Integer]: TffSqlTableRef - read GetTableRef write SetTableRef; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function GetFieldsFromTable(const TableName: string; List: TList): TffSqlTableProxy; - end; - - TffSqlOrderItem = class(TffSqlNode) - protected - FColumn: TFFSqlOrderColumn; - FIndex: string; - FDescending: Boolean; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - property Column: TFFSqlOrderColumn read FColumn write FColumn; - property Index: string read FIndex write FIndex; - property Descending: Boolean read FDescending write FDescending; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - end; - - TffSqlOrderList = class(TffSqlNode) - protected - FOrderItemList : TList; - procedure Clear; - function GetOrderItem(Index: Integer): TffSqlOrderItem; - procedure SetOrderItem(Index: Integer; - const Value: TffSqlOrderItem); - function GetOrderCount: Integer; - function Reduce: Boolean; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - function AddOrderItem(NewOrder: TffSqlOrderItem): TffSqlOrderItem; - property OrderCount : Integer read GetOrderCount; - property OrderItem[Index: Integer]: TffSqlOrderItem - read GetOrderItem write SetOrderItem; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - end; - - TffSqlOuterJoinMode = (jmNone, jmLeft, jmRight, jmFull); - TffSqlJoiner = class(TffObject) - protected - FSources : TFFSqlTableProxySubsetList; - FTargetTable : TFFSqlTableProxy; - Level : integer; - FRecordsRead : Longint; - {$IFDEF CountWrites} - FRecordsWritten : Longint; - {$ENDIF} - FieldCopier : TffFieldCopier; - FSX, FT : TList; - FCondExpWhere: TffSqlCondExp; - RecListL, RecListR, - DupList : TffNRecordHash; - FirstCondTerm, LastCondTerm : Boolean; - OptimizeCalled: Boolean; - WasOptimized: Boolean; - P: procedure of object; - FOwner: TffSqlStatement; - procedure CreateResultRecord; - function ProcessLevel(Cookie1: TffWord32): Boolean; - procedure ReadSources; - function FindRelation(Term: TffSqlCondTerm; CurFactor, - CurFactor2: TffSqlCondFactor; Table : TFFSqlTableProxy; - TargetField : TFFSqlFieldProxy; - var Operator: TffSqlRelOp; - var ArgExpression: TffSqlSimpleExpression; - var SameCase: Boolean): TffSqlCondFactor; - procedure Optimize(UseIndex: Boolean); - function WriteNull(Cookie: TffWord32): Boolean; - public - constructor Create(AOwner: TffSqlStatement; CondExp: TffSqlCondExp); - destructor Destroy; override; - procedure Execute(UseIndex: Boolean; LoopProc: TFFObjectProc; - OuterJoinMode: TffSqlOuterJoinMode); - property Sources : TFFSqlTableProxySubsetList read FSources; - procedure AddColumn( - SourceExpression: TffSqlSimpleExpression; - SourceField : TffSqlFieldProxy; - Target: TFFSqlFieldProxy); - procedure ClearColumnList; - property RecordsRead : Longint read FRecordsRead; - {$IFDEF CountWrites} - property RecordsWritten: Longint read FRecordsWritten; - {$ENDIF} - property CondExpWhere : TffSqlCondExp read FCondExpWhere write FCondExpWhere; - property Target : TFFSqlTableProxy read FTargetTable write FTargetTable; - property Owner: TffSqlStatement read FOwner; - end; - - TffSqlColumnListOwner = class(TffSqlNode) - protected - T : TffSqlTableProxy; {!!.11} - Columns : TStringList; - public - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - end; - - TffSqlJoinTableExp = class; - TffSqlNonJoinTableExp = class; - - TffSqlTableExp = class(TffSqlNode) - protected - FJoinTableExp: TffSqlJoinTableExp; - FNonJoinTableExp: TffSqlNonJoinTableExp; - FNestedTableExp: TffSqlTableExp; - procedure EnsureResultTable(NeedData: Boolean); - function CheckNoDups: Boolean; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - function BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; - function BindFieldDown(const TableName, - FieldName: string): TFFSqlFieldProxy; - function TargetFieldFromSourceField( - const F: TffSqlFieldProxy): TffSqlFieldProxy; - public - function GetResultTable: TFFSqlTableProxy; - property JoinTableExp: TffSqlJoinTableExp - read FJoinTableExp write FJoinTableExp; - property NonJoinTableExp: TffSqlNonJoinTableExp - read FNonJoinTableExp write FNonJoinTableExp; - property NestedTableExp: TffSqlTableExp - read FNestedTableExp write FNestedTableExp; - function Equals(Other: TffSqlNode): Boolean; override; - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure Clear; - destructor Destroy; override; - procedure Execute( - var aLiveResult: Boolean; var aCursorID: TffCursorID; - var RecordsRead: Integer); - function Reduce: Boolean; - procedure EmitSQL(Stream : TStream); override; - property ResultTable: TFFSqlTableProxy read GetResultTable; - function GetFieldsFromTable(const TableName: string; List: TList): - TffSqlTableProxy; {!!.11} - end; - - TFFSqlUsingItem = class(TffSqlNode) - protected - FColumnName: string; - public - property ColumnName: string read FColumnName write FColumnName; - function Equals(Other: TffSqlNode): Boolean; override; - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure EmitSQL(Stream : TStream); override; - end; - - TffSqlUsingList = class(TffSqlNode) - protected - FUsingItemList : TList; - procedure Clear; - function GetUsingItem(Index: Integer): TffSqlUsingItem; - procedure SetUsingItem(Index: Integer; - const Value: TffSqlUsingItem); - function GetUsingCount: Integer; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - function AddItem(NewUsing: TffSqlUsingItem): TffSqlUsingItem; - property UsingCount : Integer read GetUsingCount; - property UsingItem[Index: Integer]: TffSqlUsingItem - read GetUsingItem write SetUsingItem; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - end; - - TffSqlJoinType = (jtCross, jtInner, jtLeftOuter, jtRightOuter, - jtFullOuter, jtUnion); - TffSqlJoinTableExp = class(TffSqlNode) - protected - FTableRef1: TffSqlTableRef; - FTableRef2: TffSqlTableRef; - FCondExp: TFFSqlCondExp; - FJoinType: TffSqlJoinType; - FNatural: Boolean; - Bound: Boolean; - TL, TR : TffSqlTableProxy; - Columns: TStringList; - Joiner : TffSqlJoiner; - FUsingList: TFFSqlUsingList; - UsingCondExp: TFFSqlCondExp; - FResultTable : TFFSqlTableProxy; - HaveData: Boolean; - function BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; - function GetResultTable: TffSqlTableProxy; - function Execute2(NeedData: Boolean): TffSqlTableProxy; - procedure Bind; - procedure ClearBindings(Node: TffSqlNode); - procedure ClearColumns; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - function DoJoin(NeedData: Boolean): TffSqlTableProxy; - function BuildSimpleFieldExpr(AOwner: TffSqlNode; const ATableName, - AFieldName: string; - AField: TffSqlFieldProxy): TffSqlSimpleExpression; - procedure EnsureResultTable(NeedData: Boolean); - function BindFieldDown(const TableName, - FieldName: string): TFFSqlFieldProxy; - function TargetFieldFromSourceField( - const F: TffSqlFieldProxy): TffSqlFieldProxy; - public - function BindField(const TableName, - FieldName: string): TFFSqlFieldProxy; override; - property JoinType: TffSqlJoinType read FJoinType write FJoinType; - property Natural: Boolean read FNatural write FNatural; - property TableRef1: TffSqlTableRef read FTableRef1 write FTableRef1; - property TableRef2: TffSqlTableRef read FTableRef2 write FTableRef2; - property CondExp: TFFSqlCondExp read FCondExp write FCondExp; - property UsingList : TFFSqlUsingList read FUsingList write FUsingList; - function Equals(Other: TffSqlNode): Boolean; override; - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure Clear; - destructor Destroy; override; - procedure Execute(var aLiveResult: Boolean; - var aCursorID: TffCursorID; var RecordsRead: Integer); - function Reduce: Boolean; - procedure EmitSQL(Stream : TStream); override; - constructor Create(AParent: TffSqlNode); - property ResultTable: TffSqlTableProxy read GetResultTable; - function GetFieldsFromTable(const TableName: string; List: TList): - TffSqlTableProxy; {!!.11} - end; - - TffSqlValueList = class; - - TffSqlNonJoinTablePrimary = class(TffSqlNode) - protected - FSelectSt: TFFSqlSELECT; - FValueList: TffSqlValueList; - FNonJoinTableExp: TffSqlNonJoinTableExp; - FTableRef: TffSqlTableRef; - function BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - procedure EnsureResultTable(NeedData: Boolean); - function GetResultTable: TffSqlTableProxy; - function BindFieldDown(const TableName, - FieldName: string): TFFSqlFieldProxy; - function TargetFieldFromSourceField( - const F: TffSqlFieldProxy): TffSqlFieldProxy; - public - destructor Destroy; override; - property SelectSt: TFFSqlSELECT read FSelectSt write FSelectSt; - property ValueList: TffSqlValueList read FValueList write FValueList; - property NonJoinTableExp: TffSqlNonJoinTableExp - read FNonJoinTableExp write FNonJoinTableExp; - property TableRef: TffSqlTableRef read FTableRef write FTableRef; - procedure Clear; - function Equals(Other: TffSqlNode): Boolean; override; - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure Execute( - var aLiveResult: Boolean; var aCursorID: TffCursorID; - var RecordsRead: Integer); - function Reduce: Boolean; - procedure EmitSQL(Stream : TStream); override; - property ResultTable: TffSqlTableProxy read GetResultTable; - end; - - TffSqlNonJoinTableTerm = class(TffSqlNode) - protected - FNonJoinTablePrimary: TffSqlNonJoinTablePrimary; - function BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - procedure EnsureResultTable(NeedData: Boolean); - function GetResultTable: TffSqlTableProxy; - function BindFieldDown(const TableName, - FieldName: string): TFFSqlFieldProxy; - function TargetFieldFromSourceField( - const F: TffSqlFieldProxy): TffSqlFieldProxy; - public - property NonJoinTablePrimary: TffSqlNonJoinTablePrimary - read FNonJoinTablePrimary write FNonJoinTablePrimary; - function Equals(Other: TffSqlNode): Boolean; override; - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure Clear; - destructor Destroy; override; - procedure Execute( - var aLiveResult: Boolean; var aCursorID: TffCursorID; - var RecordsRead: Integer); - function Reduce: Boolean; - procedure EmitSQL(Stream : TStream); override; - property ResultTable: TffSqlTableProxy read GetResultTable; - end; - - TffSqlNonJoinTableExp = class(TffSqlNode) - protected - FNonJoinTableTerm: TffSqlNonJoinTableTerm; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - function GetResultTable: TffSqlTableProxy; - procedure EnsureResultTable(NeedData: Boolean); - function BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; - function BindFieldDown(const TableName, - FieldName: string): TFFSqlFieldProxy; - function TargetFieldFromSourceField( - const F: TffSqlFieldProxy): TffSqlFieldProxy; - public - property NonJoinTableTerm: TffSqlNonJoinTableTerm - read FNonJoinTableTerm write FNonJoinTableTerm; - function Equals(Other: TffSqlNode): Boolean; override; - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure Clear; - destructor Destroy; override; - procedure Execute(var aLiveResult: Boolean; - var aCursorID: TffCursorID; var RecordsRead: Integer); - function Reduce: Boolean; - procedure EmitSQL(Stream : TStream); override; - property ResultTable: TffSqlTableProxy read GetResultTable; - function GetFieldsFromTable(const TableName: string; List: TList): - TffSqlTableProxy; {!!.11} - end; - - TffSqlValueItem = class(TffSqlNode) - protected - FDefault : Boolean; - FSimplex: TffSqlSimpleExpression; - function GetType: TffFieldType; override; - function GetSize: Integer; override; - function GetDecimals: Integer; override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - destructor Destroy; override; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - property Default : Boolean read FDefault write FDefault; - property Simplex: TffSqlSimpleExpression read FSimplex write FSimplex; - end; - - TffSqlValueList = class(TffSqlNode) - protected - FValueItemList : TList; - FResultTable: TFFSqlTableProxy; - procedure Clear; - function GetValueItem(Index: Integer): TffSqlValueItem; - procedure SetValueItem(Index: Integer; - const Value: TffSqlValueItem); - function GetValueCount: Integer; - function GetResultTable: TFFSqlTableProxy; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - function AddItem(NewValue: TffSqlValueItem): TffSqlValueItem; - property ValueCount : Integer read GetValueCount; - property ValueItem[Index: Integer]: TffSqlValueItem - read GetValueItem write SetValueItem; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - procedure Execute( - var aLiveResult: Boolean; var aCursorID: TffCursorID; - var RecordsRead: Integer); - function Reduce: Boolean; - property ResultTable: TFFSqlTableProxy read GetResultTable; - end; - - TffSqlSELECT = class(TffSqlColumnListOwner) - protected - FDistinct : Boolean; - FSelectionList : TffSqlSelectionList; - FTableRefList : TffSqlTableRefList; - FGroupColumnList : TffSqlGroupColumnList; - FCondExpWhere: TffSqlCondExp; - FCondExpHaving: TffSqlCondExp; - FOrderList : TffSqlOrderList; - FGrpTable : TffSqlTableProxy; - AggList : TList; - FResultTable : TFFSqlTableProxy; - TablesReferencedByOrder : TStringList; - TableAliases : TStringList; - HaveAggregates : Boolean; - AggQueryMode : TffSqlAggQueryMode; - HavingTable: TffSqlTableProxy; - IsDependent: Boolean; - Bound: Boolean; - Joiner : TffSqlJoiner; - FInWhere: Boolean; - WasStar: Boolean; - HaveData: Boolean; - RequestLive: Boolean; - TypeKnown: Boolean; - FType: TffFieldType; - FDecimals: Integer; - FSize: Integer; {!!.13} - BindingDown: Boolean; {!!.11} - procedure AddTableFields(Table : TffSqlTableProxy; - const StartPoint : Integer; - FieldRef : TffSqlFieldRef); - procedure AddTableFieldsFromList(Table : TffSqlTableProxy; - const StartPoint : Integer; - FieldRef : TffSqlFieldRef; - List: TList); {!!.11} - procedure Bind; - function BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; - procedure AddTableRefs(Node: TffSqlNode); - procedure AddColumns(Node: TffSqlNode); - procedure BuildSortList(Table: TffSqlTableProxy; - var SortList: TffSqlSortArray); {!!.11} - procedure DoGroupCopy(GroupColumnsIn: Integer; AggExpList, - GroupColumnTargetField: TList); - procedure DoAggOrderBy; - procedure DoHaving; - procedure DoSortOnAll; - procedure DoRemoveDups(NeedData: Boolean); - procedure DoBuildGroupingTable(GroupColumnsIn : Integer; FSF, FSX, - GroupColumnTargetField: TList); - procedure DoOrderBy(NeedData: Boolean; Table: TffSqlTableProxy); - procedure DoCheckAggregates; - function CheckAnyValue(RelOp: TffSqlRelOp; - const Val: Variant): Boolean; - function CheckAllValues(RelOp: TffSqlRelOp; - const Val: Variant): Boolean; - {procedure CheckTableList;} {!!.12 debug code} - procedure Clear; - procedure ClearBindings(Node: TffSqlNode); - procedure ResetIsConstant(Node: TffSqlNode); - procedure FlagAggregates(Node: TffSqlNode); - procedure EnumAggregates(Node: TffSqlNode); - function BindField(const TableName, - FieldName: string): TFFSqlFieldProxy; override; - function FindField(const FieldName: string): TFFSqlFieldProxy; - procedure ExpandWildcards; - procedure MatchType(ExpectedType: TffFieldType; AllowMultiple: Boolean); - function NormalQueryResult(NeedData: Boolean): TffSqlTableProxy; - function CheckForValue(Value: Variant):Boolean; - function Match(Value: Variant; Unique: Boolean; - MatchOption: TffSqlMatchOption): Boolean; - function AggregateQueryResult(NeedData: Boolean): TffSqlTableProxy; - function CheckHaving: Boolean; - function Execute2(NeedData: Boolean): TffSqlTableProxy; - procedure EnsureResultTable(NeedData: Boolean); - procedure ClearTableList; - function Reduce: Boolean; - function GetValue: Variant; - function CheckNonEmpty: Boolean; - function IsSubQuery: Boolean; - function GetType: TffFieldType; override; - function GetDecimals: Integer; override; - function GetSize: Integer; override; {!!.13} - function GetResultTable: TFFSqlTableProxy; - function TargetFieldFromSourceField( - const F: TffSqlFieldProxy): TffSqlFieldProxy; - function TableWithCount(const ColumnName: string): TffSqlTableProxy; {!!.12} - public - property InWhere: Boolean read FInWhere write FInWhere; //used only during parsing - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - property Distinct: Boolean read FDistinct write FDistinct; - property SelectionList : TffSqlSelectionList - read FSelectionList write FSelectionList; - property TableRefList : TffSqlTableRefList - read FTableRefList write FTableRefList; - property CondExpWhere : TffSqlCondExp read FCondExpWhere write FCondExpWhere; - property GroupColumnList : TffSqlGroupColumnList - read FGroupColumnList write FGroupColumnList; - property CondExpHaving : TffSqlCondExp - read FCondExpHaving write FCondExpHaving; - property OrderList : TffSqlOrderList read FOrderList write FOrderList; - procedure EmitSQL(Stream : TStream); override; - procedure Execute( - var aLiveResult: Boolean; var aCursorID: TffCursorID; - var RecordsRead: Integer); - function Equals(Other: TffSqlNode): Boolean; override; - function DependsOn(Table: TFFSqlTableProxy): Boolean; - property ResultTable : TFFSqlTableProxy read GetResultTable; - end; - - TffSqlInsertItem = class(TffSqlNode) - protected - FColumnName: string; - procedure AddColumnDef(Target: TffSqlColumnListOwner); override; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - property ColumnName: string read FColumnName write FColumnName; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - end; - - TffSqlInsertColumnList = class(TffSqlNode) - protected - FInsertColumnItemList : TList; - procedure Clear; - function GetInsertColumnItem(Index: Integer): TffSqlInsertItem; - procedure SetInsertColumnItem(Index: Integer; - const Value: TffSqlInsertItem); - function GetInsertColumnCount: Integer; - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - function AddItem(NewInsertColumn: TffSqlInsertItem): TffSqlInsertItem; - property InsertColumnCount : Integer read GetInsertColumnCount; - property InsertColumnItem[Index: Integer]: TffSqlInsertItem - read GetInsertColumnItem write SetInsertColumnItem; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - end; - - TffSqlINSERT = class(TffSqlColumnListOwner) - protected - FTableName: string; - FInsertColumnList: TFFSqlInsertColumnList; - FDefaultValues: Boolean; - Bound: Boolean; -// T : TffSqlTableProxy; {!!.11} - FTableExp: TffSqlTableExp; - procedure AddColumns(Node: TffSqlNode); - procedure Bind; - procedure ClearBindings(Node: TffSqlNode); - function Reduce: Boolean; {!!.11} - public - destructor Destroy; override; - property TableName : string read FTableName write FTableName; - property InsertColumnList: TFFSqlInsertColumnList - read FInsertColumnList write FInsertColumnList; - property TableExp: TffSqlTableExp read FTableExp write FTableExp; - property DefaultValues: Boolean read FDefaultValues write FDefaultValues; - procedure Assign(const Source: TffSqlNode); override; - procedure Clear; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function Execute(var RowsAffected: Integer) : TffResult; {!!.11} - end; - - TffSqlDELETE = class(TffSqlColumnListOwner) {!!.11} - protected - FTableRef: TffSqlTableRef; - FCondExpWhere: TffSqlCondExp; - Bound: Boolean; -// T : TffSqlTableProxy; {!!.11} - Joiner : TffSqlJoiner; - DeleteList: TList; - procedure Bind; - function BindField(const TableName, - FieldName: string): TFFSqlFieldProxy; override; - procedure DeleteRecord; - function Reduce: Boolean; {!!.11} - public - destructor Destroy; override; - property TableRef: TffSqlTableRef read FTableRef write FTableRef; - property CondExpWhere : TffSqlCondExp - read FCondExpWhere write FCondExpWhere; - procedure Assign(const Source: TffSqlNode); override; - procedure Clear; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function Execute(var RowsAffected: Integer) : TffResult; {!!.11} - end; - - TffSqlUpdateItem = class(TffSqlNode) - protected - FSimplex: TffSqlSimpleExpression; - FColumnName: string; - FDefault: Boolean; - F: TffSqlFieldProxy; - procedure AddColumnDef(Target: TffSqlColumnListOwner); override; - function Reduce: Boolean; {!!.11} - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - destructor Destroy; override; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - property ColumnName: string read FColumnName write FColumnName; - property Default: Boolean read FDefault write FDefault; - property Simplex: TffSqlSimpleExpression read FSimplex write FSimplex; - procedure Update; - end; - - TffSqlUpdateList = class(TffSqlNode) - protected - FUpdateItemList : TList; - procedure Clear; - function GetUpdateItem(Index: Integer): TffSqlUpdateItem; - function GetUpdateCount: Integer; - function Reduce: Boolean; {!!.11} - public - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - constructor Create(AParent: TffSqlNode); - destructor Destroy; override; - function AddItem(NewValue: TffSqlUpdateItem): TffSqlUpdateItem; - property UpdateCount : Integer read GetUpdateCount; - property UpdateItem[Index: Integer]: TffSqlUpdateItem - read GetUpdateItem; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function Update : TffResult; {!!.11} - end; - - TffSqlUPDATE = class(TffSqlColumnListOwner) - protected - FTableRef: TffSqlTableRef; - FCondExpWhere: TffSqlCondExp; - FUpdateList: TFFSqlUpdateList; - Bound: Boolean; -// T : TffSqlTableProxy; {!!.11} - Joiner : TffSqlJoiner; - FRowsAffected: Integer; - UpdateRecList: TList; - procedure AddColumns(Node: TffSqlNode); - procedure Bind; - function BindField(const TableName, - FieldName: string): TFFSqlFieldProxy; override; - procedure ClearBindings(Node: TffSqlNode); - function Reduce: Boolean; {!!.11} - procedure UpdateRecord; - public - destructor Destroy; override; - property TableRef: TffSqlTableRef read FTableRef write FTableRef; - property CondExpWhere : TffSqlCondExp read FCondExpWhere write FCondExpWhere; - property UpdateList: TFFSqlUpdateList read FUpdateList write FUpdateList; - procedure Assign(const Source: TffSqlNode); override; - procedure Clear; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - procedure EmitSQL(Stream : TStream); override; - function Equals(Other: TffSqlNode): Boolean; override; - function Execute(var RowsAffected: Integer) : TffResult; {!!.11} - end; - - TffSqlStatement = class(TffSqlNode) - protected - FClientID: TffClientID; - FSessionID: TffSessionID; - FInsert: TffSqlINSERT; - StartDate, - StartDateTime, - StartTime : TDateTime; - ParmCount : Integer; - ParmList : TFFVariantList; - FUseIndex: Boolean; - FUpdate: TffSqlUPDATE; - FDelete: TffSqlDELETE; - FReduce: Boolean; - FDatabase : TffSqlDatabaseProxy; - RecordsRead: Integer; - FTableExp: TffSqlTableExp; - public - property UseIndex: Boolean read FUseIndex write FUseIndex; - property Reduce: Boolean read FReduce write FReduce; - procedure Assign(const Source: TffSqlNode); override; - procedure EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); override; - property Insert: TffSqlINSERT read FInsert write FInsert; - property Update: TffSqlUPDATE read FUpdate write FUpdate; - property Delete: TffSqlDELETE read FDelete write FDelete; - property TableExp: TffSqlTableExp read FTableExp write FTableExp; - constructor Create; - destructor Destroy; override; -{Begin !!.11} - procedure Bind(const ClientID: TffClientID; - const SessionID: TffSessionID; - Database : TffSqlDatabaseProxy); -{End !!.11} - procedure EmitSQL(Stream : TStream); override; - {- write the SQL statement represented by this hierarchy} -{Begin !!.11} - function Execute(var aLiveResult: Boolean; - var aCursorID: TffCursorID; - var RowsAffected, - aRecordsRead: integer) : TffResult; -{End !!.11} - function Equals(Other: TffSqlNode): Boolean; override; - procedure SetParameter(Index: Integer; Value: Variant); - procedure ReduceStrength; - property Owner: TffSqlStatement read FOwner; - procedure Clear; - end; - - TffGroupColumnTargetInfo = class(TffObject) - { This class helps correlate a selection field to a slot in the - LastValues list that is created when grouping fields. There - is not a one-to-one correspondence between the two lists - because the Group By clause may reference fields not in the - selection list. } - public - SelFldIndex, - LastValueIndex : Longint; - end; - -{$IFDEF ExposeLastStatement} -var - LastStatement : TffSqlStatement; {debug hook} -{$ENDIF} - -implementation - -uses - ffllExcp, - ffsrbase, - ffsrbde, - ffsrlock, - Math; {!!.11} - -{$I ffconst.inc} - -var - TimeDelta : double; - -const - RelOpStr : array[TffSqlRelOp] of string = - ('', '=', '<=', '<', '>', '>=', '<>'); - DefStr : array[TffSqlIntervalDef] of string = ( - 'Unspec', 'YEAR', 'MONTH', 'DAY', 'HOUR', 'MINUTE', 'SECOND'); - CanOptimizeOnOperator: array[TffSqlRelOp] of Boolean = ( - {roNone, roEQ, roLE, roL, roG, roGE, roNE} - FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE); - AgString : array[TffSqlAggFunction] of string = - ('COUNT','MIN','MAX','SUM','AVG'); - ffSqlInConvThreshold = 8; {maximum length of expression list in - an IN clause to convert to simple expressions} - -function PosCh(const SearchCh: Char; const SearchString: string): Integer; -{-same as POS but searches for a single Char} -var - Len: Integer; -begin - Len := length(SearchString); - if Len <> 0 then begin - Result := 1; - repeat - if SearchString[Result] = SearchCh then - exit; - inc(Result); - until Result > Len; - end; - Result := 0; -end; - -function PosChI(const SearchCh: Char; const SearchString: string): Integer; -{-same as PosCh above, but ignores case} -var - Len: Integer; - SearchChU: Char; -begin - Len := length(SearchString); - if Len <> 0 then begin - SearchChU := UpCase(SearchCh); - Result := 1; - repeat - if SearchString[Result] = SearchCh then - exit; - if UpCase(SearchString[Result]) = SearchChU then - exit; - inc(Result); - until Result > Len; - end; - Result := 0; -end; - -function PosI(const SearchFor, SearchIn: string): Integer; -{-same as POS but ignores case on both strings} -var - LenFor, LenIn, j: Integer; - FirstCh: Char; -begin - LenFor := length(SearchFor); - if LenFor = 0 then begin - Result := 0; - exit; - end; - Result := PosChI(SearchFor[1], SearchIn); - if (Result = 0) or (LenFor = 1) then - exit; - LenIn := length(SearchIn); - if LenIn <> 0 then begin - dec(LenIn, LenFor); - FirstCh := UpCase(SearchFor[1]); - repeat - if UpCase(SearchIn[Result]) = FirstCh then begin - J := 1; - repeat - inc(J); - until (J > LenFor) or (UpCase(SearchIn[Result + J - 1]) <> UpCase(SearchFor[J])); - if J > LenFor then - exit; - end; - inc(Result); - until Result > LenIn; - end; - Result := 0; -end; - -{$IFNDEF DCC5OrLater} -function CompareText(const S1, S2: string): Integer; assembler; -asm - PUSH ESI - PUSH EDI - PUSH EBX - MOV ESI,EAX - MOV EDI,EDX - OR EAX,EAX - JE @@0 - MOV EAX,[EAX-4] -@@0: OR EDX,EDX - JE @@1 - MOV EDX,[EDX-4] -@@1: MOV ECX,EAX - CMP ECX,EDX - JBE @@2 - MOV ECX,EDX -@@2: CMP ECX,ECX -@@3: REPE CMPSB - JE @@6 - MOV BL,BYTE PTR [ESI-1] - CMP BL,'a' - JB @@4 - CMP BL,'z' - JA @@4 - SUB BL,20H -@@4: MOV BH,BYTE PTR [EDI-1] - CMP BH,'a' - JB @@5 - CMP BH,'z' - JA @@5 - SUB BH,20H -@@5: CMP BL,BH - JE @@3 - MOVZX EAX,BL - MOVZX EDX,BH -@@6: SUB EAX,EDX - POP EBX - POP EDI - POP ESI -end; - -function SameText(const S1, S2: string): Boolean; assembler; -asm - CMP EAX,EDX - JZ @1 - OR EAX,EAX - JZ @2 - OR EDX,EDX - JZ @3 - MOV ECX,[EAX-4] - CMP ECX,[EDX-4] - JNE @3 - CALL CompareText - TEST EAX,EAX - JNZ @3 -@1: MOV AL,1 -@2: RET -@3: XOR EAX,EAX -end; -{$ENDIF} - -type - TReadSourceEvent = procedure(Sender: TObject; - var OkToCopy: boolean) of object; - TEvaluateFieldEvent = procedure(Sender: TObject; - ColumnIndex : Integer; var Res : variant) of object; - -function CreateLiteralStringExp(Parent: TffSqlNode; const S: string): TffSqlSimpleExpression; -var - T : TffSqlTerm; - F : TffSqlFactor; - L : TffSqlLiteral; - SL : TffSqlStringLiteral; -begin - Result := TffSqlSimpleExpression.Create(Parent); - T := TffSqlTerm.Create(Result); - F := TffSqlFactor.Create(T); - L := TffSqlLiteral.Create(F); - SL := TffSqlStringLiteral.Create(L); - SL.Value := '''' + S + ''''; - L.StringLiteral := SL; - F.Literal := L; - T.AddFactor(F); - Result.AddTerm(T); -end; - -constructor TffSqlJoiner.Create(AOwner: TffSqlStatement; - CondExp: TffSqlCondExp); -begin - Assert(AOwner <> nil); - inherited Create; - FOwner := AOwner; - FCondExpWhere := CondExp; - FSources := TFFSqlTableProxySubsetList.Create(AOwner); - FieldCopier := TffFieldCopier.Create; - FSX := TList.Create; - FT := TList.Create; -end; - -destructor TffSqlJoiner.Destroy; -begin - FieldCopier.Free; - FSX.Free; - FT.Free; - FSources.Free; - inherited Destroy; -end; - -procedure TffSqlJoiner.AddColumn( - SourceExpression: TffSqlSimpleExpression; - SourceField : TffSqlFieldProxy; - Target: TFFSqlFieldProxy); -begin - Assert((SourceExpression = nil) or (SourceField = nil)); - if (SourceExpression = nil) and (SourceField = nil) then {!!.13} - FSX.Add(Pointer(1)) // flag - see CreateResultRecord {!!.13} - else {!!.13} - FSX.Add(SourceExpression); - Target.IsTarget := True; - if SourceField <> nil then begin - FieldCopier.Add(SourceField, Target); - Target.SrcField := SourceField; - end - else - Target.SrcIndex := Pred(FSX.Count); - FT.Add(Target); -end; - -procedure TffSqlJoiner.ClearColumnList; -begin - FSX.Clear; - FT.Clear; - FieldCopier.Free; - FieldCopier := TffFieldCopier.Create; -end; - -function TffSqlJoiner.ProcessLevel(Cookie1: TffWord32): Boolean; -begin - inc(FRecordsRead); - inc(Owner.RecordsRead); - { Time to check for timeout? } - if FRecordsRead mod 1000 = 0 then - FFCheckRemainingTime; - if Level > 0 then begin - if (CondExpWhere = nil) or CondExpWhere.AsBooleanLevel(Level) then begin - dec(Level); - ReadSources; - inc(Level); - end; - end else - if (CondExpWhere = nil) or CondExpWhere.AsBoolean then - P; - Result := True; {continue} -end; - -procedure TffSqlJoiner.CreateResultRecord; -var - i : Integer; - V : Variant; -begin - if (DupList <> nil) - and not FirstCondTerm - and DupList.Exists then exit; - FTargetTable.Insert; - for i := 0 to pred(FTargetTable.FieldCount) do - if FSX[i] <> nil then begin - if Integer(FSX[i]) = 1 then {!!.13} - TFFSqlFieldProxy(Ft[i]).SetValue(1) {!!.13} - else begin {!!.13} - V := TFFSqlSimpleExpression(FSX[i]).GetValue; - TFFSqlFieldProxy(Ft[i]).SetValue(V); - end; {!!.13} - end; - FieldCopier.Execute; - FTargetTable.Post; - if (DupList <> nil) - and not LastCondTerm then - DupList.Add; - {$IFDEF CountWrites} - inc(FRecordsWritten); - {$ENDIF} - if assigned(RecListL) then - if not RecListL.Exists then - RecListL.Add; - if assigned(RecListR) then - if not RecListR.Exists then - RecListR.Add; -end; - -function TffSqlJoiner.WriteNull(Cookie: TffWord32): Boolean; -begin - if not TffNRecordHash(Cookie).Exists then - CreateResultRecord; - Result := True; {continue} -end; - -procedure TffSqlJoiner.ReadSources; -begin - with Sources.Item[Level] do - Iterate(ProcessLevel, 0); -end; - -function TffSqlJoiner.FindRelation( - Term: TffSqlCondTerm; - CurFactor, CurFactor2: TffSqlCondFactor; - Table : TFFSqlTableProxy; - TargetField : TFFSqlFieldProxy; - var Operator: TffSqlRelOp; - var ArgExpression: TffSqlSimpleExpression; - var SameCase: Boolean): TffSqlCondFactor; -var - k, l : Integer; - F : TFFSqlFieldProxy; - DepFound : Boolean; -begin - with Term do begin - for k := 0 to pred(CondFactorCount) do - if (CondFactor[k] <> CurFactor) - and (CondFactor[k] <> CurFactor2) - and not OrderedSources.RelationUsed(CondFactor[k]) then - with CondFactor[k] do - if IsRelationTo(Table, - F, Operator, ArgExpression, SameCase) - and CanOptimizeOnOperator[Operator] then begin - if F = TargetField then begin - {check that it doesn't depend on something we haven't seen - at this point} - DepFound := False; - - for l := 0 to pred(OrderedSources.Count) do - if ArgExpression.DependsOn(OrderedSources.Item[l].Table) then begin - DepFound := True; - break; - end; - - if not DepFound then begin - Result := CondFactor[k]; - exit; - end; - end; - end; - end; - Result := nil; -end; - -procedure TffSqlJoiner.Execute(UseIndex: Boolean; LoopProc: TFFObjectProc; - OuterJoinMode: TffSqlOuterJoinMode); -var - i : Integer; -begin - FRecordsRead := 0; - {$IFDEF CountWrites} - FRecordsWritten := 0; - {$ENDIF} - - if assigned(LoopProc) then - P := LoopProc - else - P := CreateResultRecord; - - case OuterJoinMode of - jmLeft, jmFull : - begin - Sources.Item[0].Outer := True; - Sources.Item[0].Opposite := Sources.Item[1].Table; - Sources.OuterJoin := True; - end; - jmRight : - begin - Sources.Item[1].Outer := True; - Sources.Item[1].Opposite := Sources.Item[0].Table; - Sources.OuterJoin := True; - end; - end; - - Optimize(UseIndex); - - if WasOptimized then begin - - if CondExpWhere.GetCondTermCount > 1 then begin - DupList := TffNRecordHash.Create; - for i := 0 to pred(Sources.Count) do - Duplist.AddTable(Sources.Item[i].Table); - end else - DupList := nil; - - {process each term separately} - FirstCondTerm := True; - for i := 0 to pred(CondExpWhere.GetCondTermCount) do begin - LastCondTerm := i = pred(CondExpWhere.GetCondTermCount); - with CondExpWhere.CondTerm[i] do begin - OrderedSources.OuterJoin := OuterJoinMode <> jmNone; - OrderedSources.Join(CondExpWhere.CondTerm[i], P); - end; - FirstCondTerm := False; - end; - - DupList.Free; - DupList := nil; - - if OuterJoinMode = jmFull then begin - Sources.Item[0].Outer := False; - Sources.Item[1].Outer := True; - Sources.Item[1].Opposite := Sources.Item[0].Table; - - OptimizeCalled := False; - Optimize(UseIndex); - - if WasOptimized then begin - - if CondExpWhere.GetCondTermCount > 1 then begin - DupList := TffNRecordHash.Create; - for i := 0 to pred(Sources.Count) do - Duplist.AddTable(Sources.Item[i].Table); - end else - DupList := nil; - - {process each term separately} - FirstCondTerm := True; - for i := 0 to pred(CondExpWhere.GetCondTermCount) do begin - LastCondTerm := i = pred(CondExpWhere.GetCondTermCount); - with CondExpWhere.CondTerm[i] do begin - OrderedSources.OuterJoin := True; - OrderedSources.SkipInner := True; - OrderedSources.Join(CondExpWhere.CondTerm[i], P); - end; - FirstCondTerm := False; - end; - - DupList.Free; - DupList := nil; - - end else begin - if CondExpWhere <> nil then - CondExpWhere.SetLevelDep(Sources); - Level := Sources.Count - 1; - ReadSources; - end; - OptimizeCalled := False; - - end; - - end else begin - case OuterJoinMode of - jmLeft : - begin - RecListL := TffNRecordHash.Create; - ReclistL.AddTable(Sources.Item[0].Table); - end; - jmRight : - begin - RecListR := TffNRecordHash.Create; - ReclistR.AddTable(Sources.Item[1].Table); - end; - jmFull : - begin - RecListL := TffNRecordHash.Create; - ReclistL.AddTable(Sources.Item[0].Table); - RecListR := TffNRecordHash.Create; - ReclistR.AddTable(Sources.Item[1].Table); - end; - end; - if CondExpWhere <> nil then - CondExpWhere.SetLevelDep(Sources); - Level := Sources.Count - 1; - ReadSources; - case OuterJoinMode of - jmLeft : - begin - Sources.Item[1].Table.NullRecord; - Sources.Item[0].Table.Iterate(WriteNull, TffWord32(RecListL)); - RecListL.Free; - RecListL := nil; - end; - jmRight : - begin - Sources.Item[0].Table.NullRecord; - Sources.Item[1].Table.Iterate(WriteNull, TffWord32(RecListR)); - RecListR.Free; - RecListR := nil; - end; - jmFull : - begin - Sources.Item[1].Table.NullRecord; - Sources.Item[0].Table.Iterate(WriteNull, TffWord32(RecListL)); - Sources.Item[0].Table.NullRecord; - Sources.Item[1].Table.Iterate(WriteNull, TffWord32(RecListR)); - RecListL.Free; - RecListL := nil; - RecListR.Free; - RecListR := nil; - end; - end; - end; -end; - -function CompareRelations(const R1, R2: TFFSqlTableProxySubset): Boolean; -{ Returns True if R1 is 'better' than R2, e.g. it is likely to better - limit the number of rows we have to read to produce a result} -var - U1, U2: Boolean; - I1, I2: Integer; -begin - if R2 = nil then begin - Result := True; - exit; - end; - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' Comparing relations'); - writeln(IALog, ' Rel1:'); - writeln(IALog, ' Table name:',R1.Table.Name, ' (', R1.Table.Alias,')'); - writeln(IALog, ' Unique:',R1.UniqueValue); - writeln(IALog, ' Closed segment:',R1.ClosedSegment); - writeln(IALog, ' Equal key depth:',R1.EqualKeyDepth); - writeln(IALog, ' Key depth:',R1.KeyDepth); - writeln(IALog, ' Relation key is unique:',R1.KeyRelation.RelationKeyIsUnique); - writeln(IALog, ' Relation key is case insensitive:',R1.KeyRelation.RelationKeyIsCaseInsensitive); - writeln(IALog, ' Record count:',R1.Table.GetRecordCount); - writeln(IALog, ' Expression:',R1.KeyRelation.CondF.SqlText); - writeln(IALog, ' Rel2:'); - writeln(IALog, ' Table name:',R2.Table.Name, ' (', R2.Table.Alias,')'); - writeln(IALog, ' Unique:',R2.UniqueValue); - writeln(IALog, ' Closed segment:',R2.ClosedSegment); - writeln(IALog, ' Equal key depth:',R2.EqualKeyDepth); - writeln(IALog, ' Key depth:',R2.KeyDepth); - writeln(IALog, ' Relation key is unique:',R2.KeyRelation.RelationKeyIsUnique); - writeln(IALog, ' Relation key is case insensitive:',R2.KeyRelation.RelationKeyIsCaseInsensitive); - writeln(IALog, ' Record count:',R2.Table.GetRecordCount); - writeln(IALog, ' Expression:',R2.KeyRelation.CondF.SqlText); - {$ENDIF} - U1 := R1.UniqueValue; - U2 := R2.UniqueValue; - if U1 then - if not U2 then begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' 1 is unique but 2 is not'); - {$ENDIF} - Result := True; - exit; - end else - else - if U2 then begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' 2 is unique but 1 is not'); - {$ENDIF} - Result := False; - exit; - end; - U1 := R1.ClosedSegment; - U2 := R2.ClosedSegment; - if U1 then - if U2 then - if R1.EqualKeyDepth > R2.EqualKeyDepth then begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' EqualKeyDepth(1) > EqualKeyDepth(2)'); - {$ENDIF} - Result := True; - exit; - end else - if R1.EqualKeyDepth < R2.EqualKeyDepth then begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' EqualKeyDepth(1) < EqualKeyDepth(2)'); - {$ENDIF} - Result := False; - exit; - end else - if R1.KeyDepth > R2.KeyDepth then begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' KeyDepth(1) > KeyDepth(2)'); - {$ENDIF} - Result := True; - exit; - end else - if R1.KeyDepth < R2.KeyDepth then begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' KeyDepth(1) < KeyDepth(2)'); - {$ENDIF} - Result := False; - exit; - end else - else begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' Closed(1) and not Closed(2)'); - {$ENDIF} - Result := True; - exit; - end - else - if U2 then begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' not Closed(1) and Closed(2)'); - {$ENDIF} - Result := False; - exit; - end; - U1 := R1.KeyRelation.RelationKeyIsUnique; - U2 := R2.KeyRelation.RelationKeyIsUnique; - if U1 then - if not U2 then begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' RelationKeyIsUnique(1) and not RelationKeyIsUnique(2)'); - {$ENDIF} - Result := True; - exit; - end else - else - if U2 then begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' not RelationKeyIsUnique(1) and RelationKeyIsUnique(2)'); - {$ENDIF} - Result := False; - exit; - end; - U1 := R1.KeyRelation.RelationKeyIsCaseInsensitive; - U2 := R2.KeyRelation.RelationKeyIsCaseInsensitive; - if U1 then - if not U2 then begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' RelationKeyIsCaseInsensitive(1) and not RelationKeyIsCaseInsensitive(2)'); - {$ENDIF} - Result := True; - exit; - end else - else - if U2 then begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' not RelationKeyIsCaseInsensitive(1) and RelationKeyIsCaseInsensitive(2)'); - {$ENDIF} - Result := False; - exit; - end; - I1 := R1.Table.GetRecordCount; - I2 := R2.Table.GetRecordCount; - {$IFDEF LogIndexAnalysis} - if I1 > I2 then - writeln(IALog, ' RecordCount(1) > RecordCount(2)') - else - writeln(IALog, ' RecordCount(1) < RecordCount(2)'); - {$ENDIF} - if I1 > I2 then - Result := True - else - Result := False; -end; - -function CompareKeyRelations(const K1, K2: TFFSqlKeyRelation): Boolean; -{ Returns True if K1 is 'better' than K2, e.g. it is likely to better - limit the number of rows we have to read to produce a result} -var - U1, U2: Boolean; - - function UniqueValue(const K: TFFSqlKeyRelation): Boolean; - begin - Result := - (K.RelationFieldCount = K.RelationKeyFieldCount) - and (K.RelationOperators[K.RelationKeyFieldCount - 1] = roEQ); - end; - - function ClosedSegment(const K: TFFSqlKeyRelation): Boolean; - begin - Result := - (K.RelationOperators[K.RelationFieldCount - 1] = roEQ) or - (K.RelationOperatorB[K.RelationFieldCount - 1] <> roNone); {!!.11} - end; - - function KeyDepth(const K: TFFSqlKeyRelation): Integer; - begin - Result := K.RelationFieldCount; - end; - - function EqualKeyDepth(const K: TFFSqlKeyRelation): Integer; - begin - Result := 0; - while (Result < K.RelationFieldCount) - and (K.RelationOperators[Result] = roEQ) do - inc(Result); - end; - -begin - U1 := UniqueValue(K1); - U2 := UniqueValue(K2); - if U1 then - if not U2 then begin - Result := True; - exit; - end - else - if U2 then begin - Result := False; - exit; - end; - U1 := ClosedSegment(K1); - U2 := ClosedSegment(K2); - if U1 then - if U2 then - if EqualKeyDepth(K1) > EqualKeyDepth(K2) then begin - Result := True; - exit; - end else - if EqualKeyDepth(K1) < EqualKeyDepth(K2) then begin - Result := False; - exit; - end else - if KeyDepth(K1) > KeyDepth(K2) then begin - Result := True; - exit; - end else - if KeyDepth(K1) < KeyDepth(K2) then begin - Result := False; - exit; - end else - else begin - Result := True; - exit; - end - else - if U2 then begin - Result := False; - exit; - end; - U1 := K1.RelationKeyIsUnique; - U2 := K2.RelationKeyIsUnique; - if U1 then - if not U2 then begin - Result := True; - exit; - end - else - if U2 then begin - Result := False; - exit; - end; - U1 := K1.RelationKeyIsCaseInsensitive; - U2 := K2.RelationKeyIsCaseInsensitive; - if U1 then - if not U2 then begin - Result := True; - exit; - end - else - if U2 then begin - Result := False; - exit; - end; - Result := False; -end; - -{$IFDEF LogIndexAnalysis} -procedure ShowComparison(const K1, K2: TFFSqlKeyRelation); -var - U1, U2: Boolean; - - function UniqueValue(const K: TFFSqlKeyRelation): Boolean; - begin - Result := - (K.RelationFieldCount = K.RelationKeyFieldCount) - and (K.RelationOperators[K.RelationKeyFieldCount - 1] = roEQ); - end; - - function ClosedSegment(const K: TFFSqlKeyRelation): Boolean; - begin - Result := (K.RelationOperators[K.RelationFieldCount - 1] = roEQ) - or (K.RelationOperatorB[K.RelationFieldCount - 1] <> roNone); {!!.11} - end; - - function KeyDepth(const K: TFFSqlKeyRelation): Integer; - begin - Result := K.RelationFieldCount; - end; - - function EqualKeyDepth(const K: TFFSqlKeyRelation): Integer; - begin - Result := 0; - while (Result < K.RelationFieldCount) - and (K.RelationOperators[Result] = roEQ) do - inc(Result); - end; - -begin - U1 := UniqueValue(K1); - U2 := UniqueValue(K2); - if U1 then - if not U2 then begin - writeln(IALog,' New is unique value'); - exit; - end - else - if U2 then begin - raise Exception.Create('Internal error'); - end; - U1 := ClosedSegment(K1); - U2 := ClosedSegment(K2); - if U1 then - if U2 then - if EqualKeyDepth(K1) > EqualKeyDepth(K2) then begin - writeln(IALog,'New has deeper equal key'); - exit; - end else - if KeyDepth(K1) > KeyDepth(K2) then begin - writeln(IALog,'New is deeper'); - exit; - end else - if KeyDepth(K1) < KeyDepth(K2) then begin - raise Exception.Create('Internal error'); - end else - else begin - writeln(IALog, 'New is closed interval'); - exit; - end - else - if U2 then begin - raise Exception.Create('Internal error'); - end; - U1 := K1.RelationKeyIsUnique; - U2 := K2.RelationKeyIsUnique; - if U1 then - if not U2 then begin - writeln(IALog, 'New has unique key'); - exit; - end - else - if U2 then begin - raise Exception.Create('Internal error'); - end; - U1 := K1.RelationKeyIsCaseInsensitive; - U2 := K2.RelationKeyIsCaseInsensitive; - if U1 then - if not U2 then begin - writeln(IALog, 'New has case insensitive key'); - exit; - end - else - if U2 then begin - raise Exception.Create('Internal error'); - end; - raise Exception.Create('Internal error'); -end; -{$ENDIF} - -procedure TffSqlJoiner.Optimize; -var - IndexAsc : Boolean; - RestSources : TFFSqlTableProxySubsetList; - - {$IFDEF LogIndexAnalysis} - - procedure DumpOrderedList(OrderedSources : TFFSqlTableProxySubsetList; const Title: string); - var - j, y: integer; - begin - writeln(IALog, Title); - for j := 0 to pred(OrderedSources.Count) do begin - write(IALog, OrderedSources.Item[j].Table.Name, ' (', OrderedSources.Item[j].Table.Alias, ')'); - if OrderedSources.Item[j].KeyRelation.CondF <> nil then begin - write(IALog, ' relation fields: ',OrderedSources.Item[j].KeyRelation.RelationFieldCount); - write(IALog, '('); - for y := 0 to pred(OrderedSources.Item[j].KeyRelation.RelationFieldCount) do begin - write(IALog, ' field:', OrderedSources.Item[j].KeyRelation.RelationFields[y].Name); - write(IALog, ' argexp:',OrderedSources.Item[j].KeyRelation.ArgExpressions[y].SQLText); - write(IALog, ' Operator:',RelOpStr[OrderedSources.Item[j].KeyRelation.RelationOperators[y]]); - {!!.11 begin} - if (OrderedSources.Item[j].KeyRelation.ArgExpressionB[y] <> nil) - and (OrderedSources.Item[j].KeyRelation.RelationOperatorB[y] <> roNone) - and (OrderedSources.Item[j].KeyRelation.RelationB[y] <> nil) then - write(IALog, 'secondary expression:',OrderedSources.Item[j].KeyRelation.ArgExpressionB[y].SQLText, - ' operator:',RelOpStr[OrderedSources.Item[j].KeyRelation.RelationOperatorB[y]]); - {!!.11 end} - end; - write(IALog, ')'); - write(IALog, ' index:',OrderedSources.Item[j].KeyRelation.NativeKeyIndex{RelationKeyIndexNative}); - (* !!.11 - if (OrderedSources.Item[j].KeyRelation.ArgExpressionB <> nil) - and (OrderedSources.Item[j].KeyRelation.RelationOperatorB <> roNone) - and (OrderedSources.Item[j].KeyRelation.RelationB <> nil) then - write(IALog, 'secondary expression:',OrderedSources.Item[j].KeyRelation.ArgExpressionB.SQLText, - ' operator:',RelOpStr[OrderedSources.Item[j].KeyRelation.RelationOperatorB]); - *) - writeln(IALog); - end else - writeln(IALog, ' no relation'); - end; - end; - - {$ENDIF} - - function FindRelations(CondTerm: TffSqlCondTerm; - MoreThanOne: Boolean): Boolean; - var - l, j, k, y : Integer; - Best, x : Integer; - F, F2 : TFFSqlFieldProxy; - IndexRefs : array[0..pred(ffcl_MaxIndexes)] of Integer; - IgnoreCase: Boolean; - IndexFields : array[0..pred(ffcl_MaxIndexFlds)] of Integer; - IndxFldCnt : Integer; - Found: Boolean; - CF : TFFSqlCondFactor; - CurIgnoreCase : Boolean; - DepFound: Integer; - BestRelation: TFFSqlTableProxySubset; - BestKeyRelation, CurKeyRelation: TFFSqlKeyRelation; - HaveKeyRelation: Boolean; - SameCase: Boolean; - - {$IFDEF LogIndexAnalysis} - procedure DumpBest; - var - i : Integer; - begin - with BestKeyRelation do begin - writeln(IALog,' condition:',CondF.SQLText); - writeln(IALog,' key:',NativeKeyIndex); - writeln(IALog,' Fields in key:',RelationKeyFieldCount); - writeln(IALog,' Fields:',RelationFieldCount); - for i := 0 to pred(RelationFieldCount) do begin - writeln(IALog, ' ',RelationFields[i].Name,' ',RelOpStr[RelationOperators[i]], ' ', - ArgExpressions[i].SQLText); - {!!.11 begin} - if RelationOperatorB[i] <> roNone then - writeln(IALog, ' Secondary relation:', - RelOpStr[RelationOperatorB[i]], ' ', - ArgExpressionB[i].SQLText); - {!!.11 end} - end; - {!!.11 begin - if RelationOperatorB <> roNone then - writeln(IALog, ' Secondary relation on last key field:', - RelOpStr[RelationOperatorB], ' ', - ArgExpressionB.SQLText); - !!.11 end} - end; - end; - - - {$ENDIF} - var - z: Integer; - begin - Result := False; - {CurKeyRelation.ArgExpressionB := nil;} {!!.11} - for z := 0 to pred(ffcl_MaxIndexFlds) do begin {!!.11} - CurKeyRelation.ArgExpressionB[z] := nil; {!!.11} - CurKeyRelation.RelationOperatorB[z] := roNone; {!!.11} - end; {!!.11} - - with CondTerm do - repeat - - //KeyState := ksNone; - //Depth := 0; - - for j := 0 to pred(RestSources.Count) do begin - RestSources.Item[j].Relations := 0; - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' looking for relations on ', - RestSources.Item[j].Table.Name, ' (', RestSources.Item[j].Table.Alias,')'); - {$ENDIF} - - {we select among multiple keys as follows:} - {if we find a unique key on the available field(s) we use that - otherwise, - we use the deepest key we can find, i.e. the key where the - most segments can be satisfied. - among keys with the same depth, we pick the ones with - the tightest or the most relations, e.g. - = is better than > - > and < is better than only > - ties could be further settled based on the number of - key values in an index, but we don't currently do that} - - HaveKeyRelation := False; - CurKeyRelation.RelationFieldCount := 0; - - for k := 0 to pred(CondFactorCount) do begin - if not OrderedSources.RelationUsed(CondFactor[k]) then - with CondFactor[k] do begin - if IsRelationTo(RestSources.Item[j].Table, - F, CurKeyRelation.RelationOperators[0], - CurKeyRelation.ArgExpressions[0], SameCase) - and CanOptimizeOnOperator[CurKeyRelation. - RelationOperators[0]] then begin - - if RestSources.Item[j].Outer - and CurKeyRelation.ArgExpressions[0].DependsOn( - RestSources.Item[j].Opposite) then begin - - {$IFDEF LogIndexAnalysis} - writeln(IALOG,' ',CondFactor[k].SQLText,' is a relation to ', - RestSources.Item[j].Table.Name,' (',RestSources.Item[j].Table.Alias,'). Arg expression:', CurKeyRelation.ArgExpressions[0].SQLText); - writeln(IALOG,' but using would violate the outer join, so we can''t use it. Skipped.'); - {$ENDIF} - - end else begin - - {$IFDEF LogIndexAnalysis} - writeln(IALOG,' ',CondFactor[k].SQLText,' is a relation to ', - RestSources.Item[j].Table.Name,' (',RestSources.Item[j].Table.Alias,'). Arg expression:', - CurKeyRelation.ArgExpressions[0].SQLText); - {$ENDIF} - - CurKeyRelation.CondF := CondFactor[k]; - {CurKeyRelation.RelationB := nil;} {!!.11} - for z := 0 to pred(ffcl_MaxIndexFlds) do begin {!!.11} - CurKeyRelation.ArgExpressionB[z] := nil; {!!.11} - CurKeyRelation.RelationOperatorB[z] := roNone; {!!.11} - end; {!!.11} - - {Check that this relation does not depend on something - we can't determine at this level. For example, if we - have table1 at the deepest level, then table2 at the - next, we are looking for conditional expressions on - table2 that will limit the number of rows we need to - read but we can't use conditions whose other side - refer to anything in table1.} - - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' Checking dependencies on deeper tables for :' + - CurKeyRelation.ArgExpressions[0].SQLText); - {$ENDIF} - - DepFound := -1; - - for l := pred(OrderedSources.Count) downto 0 do - if CurKeyRelation.ArgExpressions[0].DependsOn( - OrderedSources.Item[l].Table) then begin - DepFound := l; - break; - end; - - {$IFDEF LogIndexAnalysis} - if DepFound <> -1 then - writeln(IALog, ' Deeper dependency found:', - CurKeyRelation.ArgExpressions[0].SQLText,' : ', - OrderedSources.Item[l].Table.Name,' (',OrderedSources.Item[l].Table.Alias,')') - else - writeln(IALog, ' No deeper dependency found on ', - CurKeyRelation.ArgExpressions[0].SQLText); - {$ENDIF} - - {Part of the expression opposite our field is from a table, which - has already been put in the list. We can still use this relation - by putting it below that other table *unless* something in the - existing list depends on us (the table we're looking at now)} - - if (DepFound <> -1) - and OrderedSources.DependencyExists(RestSources. - Item[j].Table) then begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' Can''t use this - something else depends on it'); - {$ENDIF} - CurKeyRelation.CondF := nil; - end else begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' Relation found:', SQLText); - writeln(IALog, ' field:',F.Name); - writeln(IALog, ' same case:', SameCase); {!!.10} - writeln(IALog, ' operator:', RelOpStr[CurKeyRelation.RelationOperators[0]]); - writeln(IALog, ' arg expression:', CurKeyRelation.ArgExpressions[0].SQLTExt); - writeln(IALog, ' looking for indexes on that field'); - {$ENDIF} - - x := RestSources.Item[j].Table.IndexesOnField(F, - not SameCase, IndexRefs); - - CurKeyRelation.RelationFieldCount := 1; - - {$IFDEF LogIndexAnalysis} - CurKeyRelation.RelationFields[0] := F; - {$ENDIF} - - if x <> 0 then begin - - case CurKeyRelation.RelationOperators[0] of - roEQ : - begin - for y := 0 to pred(x) do begin - RestSources.Item[j].Table.GetIndexProperties - (IndexRefs[y], CurKeyRelation.RelationKeyIsUnique, - CurIgnoreCase, IndexAsc, IndxFldCnt, - IndexFields); - - CurKeyRelation.RelationFieldCount := 1; - CurKeyRelation.RelationKeyFieldCount := IndxFldCnt; - CurKeyRelation.RelationOperators[0] := roEQ; - CurKeyRelation.RelationOperatorB[0] := roNone; {!!.11} - CurKeyRelation.RelationKeyIsCaseInsensitive := - CurIgnoreCase; {!!.11} - CurKeyRelation.RelationKeyIndexAsc := IndexAsc; - CurKeyRelation.NativeKeyIndex := IndexRefs[y]; - CurKeyRelation.DepIndex := DepFound; - - (* !!.11 actually, whether relation key is unique is irrelevant here - if CurKeyRelation.RelationKeyIsUnique then begin - if IndxFldCnt = 1 then begin - IgnoreCase := CurIgnoreCase; - end else begin - {Multi-segment key. - See if we have other relations that satisfy - the following fields in the key} - CurKeyRelation.RelationFieldCount := 1; - repeat - F2 := RestSources.Item[j].Table. - Field(IndexFields[CurKeyRelation. - RelationFieldCount]); - CF := FindRelation(CondTerm, CondFactor[k], - nil, RestSources.Item[j].Table, F2, - CurKeyRelation.RelationOperators[ - CurKeyRelation.RelationFieldCount], - CurKeyRelation.ArgExpressions[ - CurKeyRelation.RelationFieldCount], - CurKeyRelation.SameCases[ - CurKeyRelation.RelationFieldCount]); - if CF = nil then begin - {No further fields found. - We have a key, but not a unique one} - IgnoreCase := CurIgnoreCase; - break; - end else begin - {we have a relation on this key segment} - {$IFDEF LogIndexAnalysis} - CurKeyRelation.RelationFields[ - CurKeyRelation.RelationFieldCount] := F2; - {$ENDIF} - - if CurKeyRelation.RelationOperators[ - CurKeyRelation.RelationFieldCount] = roEQ then begin - {operator is = which means we can continue searching if - there are more fields in the key. Otherwise, we have a full - key} - IgnoreCase := CurIgnoreCase; - end else begin - {Operator wasn't =, so we can't continue. - We can use this field, though, as the last one} - IgnoreCase := CurIgnoreCase; - {See if we have a secondary expression to close the interval} - CF := FindRelation(CondTerm, CondFactor[k], - CF, RestSources.Item[j].Table, F2, - CurKeyRelation.RelationOperatorB, - CurKeyRelation.ArgExpressionB, - CurKeyRelation.SameCaseB); - if CF <> nil then begin - {we do - record data and update key state} - - CurKeyRelation.RelationB := CF; - IgnoreCase := CurIgnoreCase; - - end else begin - CurKeyRelation.ArgExpressionB := nil; - CurKeyRelation.RelationOperatorB := roNone; - end; - inc(CurKeyRelation.RelationFieldCount); - break; - end; - end; - inc(CurKeyRelation.RelationFieldCount); - until CurKeyRelation.RelationFieldCount >= - IndxFldCnt; - end; - end else begin {not a unique key} - *) - if IndxFldCnt = 1 then begin - IgnoreCase := CurIgnoreCase; - end else begin - {Multi-segment key. - See if we have other relations that satisfy - the following fields in the key} - CurKeyRelation.RelationFieldCount := 1; - repeat - F2 := RestSources.Item[j].Table. - Field(IndexFields[ - CurKeyRelation.RelationFieldCount]); - CF := FindRelation(CondTerm, CondFactor[k], - nil, RestSources.Item[j].Table, F2, - CurKeyRelation.RelationOperators[ - CurKeyRelation.RelationFieldCount], - CurKeyRelation.ArgExpressions[ - CurKeyRelation.RelationFieldCount], - CurKeyRelation.SameCases[ - CurKeyRelation.RelationFieldCount]); - if CF = nil then begin - {No further fields found, but - we have a key but not a full one} - IgnoreCase := CurIgnoreCase; - break; - end else begin - {we have a relation on this key segment} - {$IFDEF LogIndexAnalysis} - CurKeyRelation.RelationFields[CurKeyRelation.RelationFieldCount] := F2; - {$ENDIF} - - if CurKeyRelation.RelationOperators[ - CurKeyRelation.RelationFieldCount] = roEQ then begin - {operator is = which means we can continue searching if - there are more fields in the key. Otherwise, we have a full - key} - IgnoreCase := CurIgnoreCase; - CurKeyRelation.RelationOperatorB[CurKeyRelation.RelationFieldCount] := roNone; {!!.11} - end else begin - {Operator wasn't =, so we can't continue. - We can use this field, though, as the last one} - IgnoreCase := CurIgnoreCase; - {see if we have other relations on this same segment} - CF := FindRelation(CondTerm, CondFactor[k], - CF, RestSources.Item[j].Table, - F2, CurKeyRelation.RelationOperatorB[CurKeyRelation.RelationFieldCount], {!!.11} - CurKeyRelation.ArgExpressionB[CurKeyRelation.RelationFieldCount], {!!.11} - CurKeyRelation.SameCaseB[CurKeyRelation.RelationFieldCount]); {!!.11} - if CF <> nil then begin - {we do - record data and update key state} - - CurKeyRelation.RelationB[CurKeyRelation.RelationFieldCount] := CF; {!!.11} - IgnoreCase := CurIgnoreCase; - - end else begin - CurKeyRelation.ArgExpressionB[CurKeyRelation.RelationFieldCount] := nil; {!!.11} - CurKeyRelation.RelationOperatorB[CurKeyRelation.RelationFieldCount] := roNone; {!!.11} - end; - inc(CurKeyRelation.RelationFieldCount); - break; - end; - end; - inc(CurKeyRelation.RelationFieldCount); - until CurKeyRelation.RelationFieldCount >= - IndxFldCnt; - end; - {end;} {!!.11} - if HaveKeyRelation then - if CompareKeyRelations(CurKeyRelation, BestKeyRelation) then begin - {$IFDEF LogIndexAnalysis} - writeln(IALog,' New best key relation'); - ShowComparison(CurKeyRelation, BestKeyrelation); - {$ENDIF} - BestKeyRelation := CurKeyRelation; - {$IFDEF LogIndexAnalysis} - DumpBest; - {$ENDIF} - end else - else begin - BestKeyRelation := CurKeyRelation; - {$IFDEF LogIndexAnalysis} - writeln(IALog,' initial key relation'); - DumpBest; - {$ENDIF} - HaveKeyRelation := True; - end; - end; - end; - else {~ Op <> roEQ} - {non equal join operator} - for y := 0 to pred(x) do begin - RestSources.Item[j].Table.GetIndexProperties - (IndexRefs[y], CurKeyRelation.RelationKeyIsUnique, - IgnoreCase, IndexAsc, IndxFldCnt, IndexFields); - - CurKeyRelation.RelationFieldCount := 1; - CurKeyRelation.RelationKeyFieldCount := IndxFldCnt; - CurKeyRelation.RelationOperatorB[CurKeyRelation.RelationFieldCount-1] := roNone; {!!.11} - CurKeyRelation.RelationKeyIsCaseInsensitive := - CurIgnoreCase; {!!.11} - CurKeyRelation.RelationKeyIndexAsc := IndexAsc; - CurKeyRelation.NativeKeyIndex := IndexRefs[y]; - CurKeyRelation.DepIndex := DepFound; - - IgnoreCase := CurIgnoreCase; - - {see if we have other relations on this same segment} - CF := FindRelation(CondTerm, CondFactor[k], nil, - RestSources.Item[j].Table, F, CurKeyRelation. - RelationOperatorB[CurKeyRelation.RelationFieldCount-1], {!!.11} - CurKeyRelation.ArgExpressionB[CurKeyRelation.RelationFieldCount-1], {!!.11} - CurKeyRelation.SameCaseB[CurKeyRelation.RelationFieldCount-1]); {!!.11} - - if CF <> nil then begin - {we do - record data and update key state} - - IgnoreCase := CurIgnoreCase; - - CurKeyrelation.RelationB[CurKeyRelation.RelationFieldCount-1] := CF; {!!.11} - - {!!.11 begin} - {check for more interval segments} - if (IndxFldCnt > 1) - and (CurKeyRelation.RelationOperators[0] in [roEQ, roGE, roLE]) - and (CurKeyRelation.RelationOperatorB[CurKeyRelation.RelationFieldCount-1] in [roEQ, roGE, roLE]) then begin - {Multi-segment key. - See if we have other relations that satisfy - the following fields in the key} - repeat - F2 := RestSources.Item[j].Table. - Field(IndexFields[ - CurKeyRelation.RelationFieldCount]); - CF := FindRelation(CondTerm, CondFactor[k], - nil, RestSources.Item[j].Table, F2, - CurKeyRelation.RelationOperators[ - CurKeyRelation.RelationFieldCount], - CurKeyRelation.ArgExpressions[ - CurKeyRelation.RelationFieldCount], - CurKeyRelation.SameCases[ - CurKeyRelation.RelationFieldCount]); - if CF = nil then begin - {No further fields found, but - we have a key but not a full one} - IgnoreCase := CurIgnoreCase; - break; - end else - if CurKeyRelation.RelationOperators[ - CurKeyRelation.RelationFieldCount] in [roEQ, roGE, roLE] then - begin - {we have a relation on this key segment} - {$IFDEF LogIndexAnalysis} - CurKeyRelation.RelationFields[CurKeyRelation.RelationFieldCount] := F2; - {$ENDIF} - - if CurKeyRelation.RelationOperators[ - CurKeyRelation.RelationFieldCount] = roEQ then begin - {operator is = which means we can continue searching if - there are more fields in the key. Otherwise, we have a full - key} - IgnoreCase := CurIgnoreCase; - CurKeyRelation.RelationOperatorB[CurKeyRelation.RelationFieldCount] := roNone; {!!.11} - end else begin - {Operator wasn't =} - IgnoreCase := CurIgnoreCase; - {see if we have other relations on this same segment} - CF := FindRelation(CondTerm, CondFactor[k], - CF, RestSources.Item[j].Table, - F2, CurKeyRelation.RelationOperatorB[CurKeyRelation.RelationFieldCount], {!!.11} - CurKeyRelation.ArgExpressionB[CurKeyRelation.RelationFieldCount], {!!.11} - CurKeyRelation.SameCaseB[CurKeyRelation.RelationFieldCount]); {!!.11} - if CF <> nil then begin - if not (CurKeyRelation.RelationOperatorB[ - CurKeyRelation.RelationFieldCount] in [roEQ, roGE, roLE]) then - break; - - {we do - record data and update key state} - - CurKeyRelation.RelationB[CurKeyRelation.RelationFieldCount] := CF; {!!.11} - IgnoreCase := CurIgnoreCase; - - end else begin - CurKeyRelation.ArgExpressionB[CurKeyRelation.RelationFieldCount] := nil; {!!.11} - CurKeyRelation.RelationOperatorB[CurKeyRelation.RelationFieldCount] := roNone; {!!.11} - inc(CurKeyRelation.RelationFieldCount); - break; - end; - end; - end; - inc(CurKeyRelation.RelationFieldCount); - until CurKeyRelation.RelationFieldCount >= - IndxFldCnt; - end; - {!!.11 end} - end else begin - CurKeyRelation.ArgExpressionB[CurKeyRelation.RelationFieldCount-1] := nil; {!!.11} - CurKeyRelation.RelationOperatorB[CurKeyRelation.RelationFieldCount-1] := roNone; {!!.11} - end; - - if HaveKeyRelation then - if CompareKeyRelations(CurKeyRelation, - BestKeyRelation) then begin - {$IFDEF LogIndexAnalysis} - ShowComparison(CurKeyRelation, BestKeyrelation); - {$ENDIF} - BestKeyRelation := CurKeyRelation; - {$IFDEF LogIndexAnalysis} - writeln(IALog,' new best key relation'); - DumpBest; - {$ENDIF} - end else - else begin - BestKeyRelation := CurKeyRelation; - {$IFDEF LogIndexAnalysis} - writeln(IALog,' initial key relation'); - DumpBest; - {$ENDIF} - HaveKeyRelation := True; - end; - - end; - end; - - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' ', x, ' found!'); - for y := 0 to pred(x) do begin - RestSources.Item[j].Table.GetIndexProperties - (IndexRefs[y], CurKeyRelation.RelationKeyIsUnique, - IgnoreCase, IndexAsc, IndxFldCnt, IndexFields); - writeln(IALog, ' key', y, ': ', - ' Unique:', CurKeyRelation.RelationKeyIsUnique, - ' IgnoreCase:', IgnoreCase, - ' IndexAsc:', IndexAsc, - ' Segments:',IndxFldCnt); - if IndxFldCnt <> 0 then begin - write(IALog, ' ('); - for z := 0 to pred(IndxFldCnt) do begin - write(IALog, RestSources.Item[j].Table. - Field(IndexFields[z]).Name,' '); - end; - writeln(IALog, ')'); - end; - end; - {$ENDIF} - - inc(RestSources.Item[j].Relations); - - end else - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' none found'); - {$ENDIF} - end; - end; - end; - end; - end; - - if HaveKeyRelation then - RestSources.Item[j].KeyRelation := BestKeyRelation; - end; - - Found := False; - Best := -1; - - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' Comparing relations'); - {$ENDIF} - - BestRelation := nil; - for j := 0 to pred(RestSources.Count) do begin - if (not MoreThanOne and (RestSources.Item[j].Relations = 1)) - or (MoreThanOne and (RestSources.Item[j].Relations > 0)) then begin - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' ', RestSources.Item[j].Table.Name,' (', - RestSources.Item[j].Table.Alias,') relations:', - RestSources.Item[j].Relations); - {$ENDIF} - if CompareRelations(RestSources.Item[j], BestRelation) then begin - BestRelation := RestSources.Item[j]; - Best := j; - end; - - end; - end; - - if BestRelation <> nil then begin - - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' Best:', BestRelation.Table.Name,' (',BestRelation.Table.Alias,')'); - {$ENDIF} - if BestRelation.KeyRelation.DepIndex = -1 then - OrderedSources.Add(RestSources.Item[Best]) - else - OrderedSources.Insert(RestSources.Item[Best]); - RestSources.Delete(Best); - Found := True; - {$IFDEF LogIndexAnalysis} - DumpOrderedList(OrderedSources, ' Ordered list so far(inner to outer):'); - {$ENDIF} - Result := True; - end; - - until not Found; - end; - -var - i, j : Integer; - {$IFDEF LogIndexAnalysis} - y : Integer; - {$ENDIF} -begin - if OptimizeCalled then exit; - - WasOptimized := False; - - if (CondExpWhere <> nil) and UseIndex then begin - - {$IFDEF LogIndexAnalysis} - AssignFile(IALog, IALogFile); - {$I-} - Append(IALog); - if IOResult <> 0 then - Rewrite(IALog); - writeln(IALog); - writeln(IALog, 'Analyzing ' + CondExpWhere.Owner.SQLText); - writeln(IALog, 'Analysis started at :',DateTimeToStr(Now)); - {$ENDIF} - - {look for relations that might be used for optimizing the join} - - {$IFDEF LogIndexAnalysis} - writeln(IALog, 'Scanning for relations'); - {$ENDIF} - - for i := 0 to pred(CondExpWhere.GetCondTermCount) do begin - - {process each term separately} - with CondExpWhere.CondTerm[i] do begin - - {$IFDEF LogIndexAnalysis} - writeln(IALog, 'Term ', i, ' : ',SQLText); - {$ENDIF} - - OrderedSources.Free; - - OrderedSources := TFFSqlTableProxySubsetList.Create(Owner); - RestSources := TFFSqlTableProxySubsetList.Create(Owner); - try - {We build an ordered list of tables to process so that - the inner-most table in the list is first.} - - {Specifically, we do this by looking for key relations - which will limit the number of rows we need to read from - each table.} - - {RestSources are the tables at any time which have not - yet been selected for processing. - When RestSources.Count = 0, we're done.} - - RestSources.Assign(Sources); - - {First, find and process the relations with - exactly one key resolution.} - - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' Looking for relations with exactly one resolution'); - {$ENDIF} - - if FindRelations(CondExpWhere.CondTerm[i], False) then - WasOptimized := True; - - {$IFDEF LogIndexAnalysis} - DumpOrderedList(OrderedSources, 'Final ordered list (inner to outer):'); - {$ENDIF} - - {Then, find and process the relations with - more than one key resolution, if any.} - - {$IFDEF LogIndexAnalysis} - writeln(IALog, ' Looking for relations with more than one resolution'); - {$ENDIF} - - if FindRelations(CondExpWhere.CondTerm[i], True) then - WasOptimized := True; - - {Finally, add the sources with no key relations - if any} - - for j := pred(RestSources.Count) downto 0 do begin - RestSources.Item[j].KeyRelation.CondF := nil; - OrderedSources.Add(RestSources.Item[j]); - RestSources.Delete(j); - end; - - Assert(RestSources.Count = 0); - - {done re-ordering} - - {$IFDEF LogIndexAnalysis} - writeln(IALog, 'Ordered list (inner to outer):'); - for j := 0 to pred(OrderedSources.Count) do begin - write(IALog, OrderedSources.Item[j].Table.Name,' (',OrderedSources.Item[j].Table.Alias,')'); - if OrderedSources.Item[j].KeyRelation.CondF <> nil then begin - write(IALog, ' relation fields: ',OrderedSources.Item[j].KeyRelation.RelationFieldCount); - write(IALog, '('); - for y := 0 to pred(OrderedSources.Item[j].KeyRelation.RelationFieldCount) do begin - write(IALog, ' field:', OrderedSources.Item[j].KeyRelation.RelationFields[y].Name); - write(IALog, ' argexp:',OrderedSources.Item[j].KeyRelation.ArgExpressions[y].SQLText); - write(IALog, ' Operator:',RelOpStr[OrderedSources.Item[j].KeyRelation.RelationOperators[y]]); - {!!.11 begin} - if (OrderedSources.Item[j].KeyRelation.ArgExpressionB[y] <> nil) - and (OrderedSources.Item[j].KeyRelation.RelationOperatorB[y] <> roNone) - and (OrderedSources.Item[j].KeyRelation.RelationB[y] <> nil) then - write(IALog, 'secondary expression:',OrderedSources.Item[j].KeyRelation.ArgExpressionB[y].SQLText, - ' operator:',RelOpStr[OrderedSources.Item[j].KeyRelation.RelationOperatorB[y]]); - {!!.11 end} - end; - write(IALog, ')'); - write(IALog, ' index:',OrderedSources.Item[j].KeyRelation.NativeKeyIndex); - {!!.11 begin - if (OrderedSources.Item[j].KeyRelation.ArgExpressionB <> nil) - and (OrderedSources.Item[j].KeyRelation.RelationOperatorB <> roNone) - and (OrderedSources.Item[j].KeyRelation.RelationB <> nil) then - write(IALog, 'secondary expression:',OrderedSources.Item[j].KeyRelation.ArgExpressionB.SQLText, - ' operator:',RelOpStr[OrderedSources.Item[j].KeyRelation.RelationOperatorB]); - !!.11 end} - writeln(IALog); - end else - writeln(IALog, ' no relation'); - end; - {$ENDIF} - finally - RestSources.Free; - end; - - end; - - end; - - {$IFDEF LogIndexAnalysis} - writeln(IALog); - writeln(IALog, 'Analysis ended at :',DateTimeToStr(Now)); - CloseFile(IALog); - {$ENDIF} - - end; - - OptimizeCalled := True; -end; - -{===Utility routines=================================================} -function BothNil(O1, O2: TffSqlNode): Boolean; -begin - Result := (O1 = nil) and (O2 = nil); -end; -{--------} -function BothNonNil(O1, O2: TffSqlNode): Boolean; -begin - Result := (O1 <> nil) and (O2 <> nil); -end; -{====================================================================} - -{===TffSqlNode=======================================================} -{--------} -procedure TffSqlNode.AddAggregate(Target: TList); -begin -end; -{--------} -procedure TffSqlNode.FlagAggregate; -begin -end; -{--------} -function TffSqlNode.GetDecimals: Integer; -begin - raise Exception.CreateFmt('Internal error:GetDecimals not implemented for %s', - [ClassName]); -end; -{--------} -function TffSqlNode.GetSize: Integer; -begin - Result := 0; -end; -{--------} -function TffSqlNode.GetType: TffFieldType; -begin - raise Exception.CreateFmt('Internal error:GetType not implemented for %s', - [ClassName]); -end; -{--------} -function TffSqlNode.IsAggregate: Boolean; -begin - raise Exception.CreateFmt('Internal error:IsAggregate not implemented for %s', - [ClassName]); -end; -{--------} -function TffSqlNode.GetOwner: TffSqlStatement; -begin - if (FOwner = nil) - and not (Self is TffSqlStatement) then begin - Assert(Parent <> nil); - FOwner := TffSqlStatement(Parent); - while FOwner.Parent <> nil do - FOwner := TffSqlStatement(FOwner.Parent); - Assert(Owner is TffSqlStatement); - end; - Result := FOwner; -end; -{--------} -{Begin !!.11} -function TffSqlNode.GetOwnerStmt: TFFSqlColumnListOwner; -begin - if (FOwnerStmt = nil) then begin - FOwnerStmt := TFFSqlColumnListOwner(Self); - while (FOwnerStmt <> nil) - and not (TObject(FOwnerStmt) is TFFSqlColumnListOwner) do - FOwnerStmt := TFFSqlColumnListOwner(FOwnerStmt.Parent); - if not (TObject(FOwnerStmt) is TFFSqlColumnListOwner) then - FOwnerStmt := nil; - end; - Result := FOwnerStmt; -end; -{--------} -function TffSqlNode.GetOwnerSelect: TFFSqlSelect; -begin - if (FOwnerStmt = nil) then begin - FOwnerStmt := TFFSqlSelect(Self); - while (FOwnerStmt <> nil) - and not (TObject(FOwnerStmt) is TFFSqlSelect) do - FOwnerStmt := TFFSqlSelect(FOwnerStmt.Parent); - if not (TObject(FOwnerStmt) is TFFSqlSelect) then - FOwnerStmt := nil; - end; - Result := TffSqlSelect(FOwnerStmt); -end; -{End !!.11} -{--------} -procedure TffSqlNode.TypeMismatch; -begin - SQLError('Type mismatch'); -end; -{--------} -procedure TffSqlNode.WriteEOF(Stream: TStream); -const - NullChar : Char = #0; -begin - Stream.Write(NullChar, 1); -end; -{--------} -procedure TffSqlNode.WriteStr(Stream: TStream; const S: string); -begin - if S <> '' then - Stream.Write(S[1], length(S)); -end; -{--------} -procedure TffSqlNode.AddTableReference; -begin -end; -{--------} -procedure TffSqlNode.AddColumnDef; -begin -end; -{--------} -procedure TffSqlNode.AssignError(Source: TffSqlNode); -begin - raise Exception.Create(Source.ClassName + ' not compatible with ' + ClassName); -end; -{--------} -function TffSqlNode.BindField(const TableName, - FieldName: string): TFFSqlFieldProxy; -begin - if Parent <> nil then - Result := Parent.BindField(TableName, FieldName) - else - raise Exception.CreateFmt('No node could resolve the field %s.%s', {!!.11} - [TableName, FieldName]); {!!.11} -end; -{--------} -procedure TffSqlNode.ClearBinding; -begin -end; -{--------} -function TffSqlNode.IsAncestor(const Node : TffSqlNode) : Boolean; -var - aParent : TffSqlNode; -begin - aParent := FParent; - repeat - Result := (aParent = Node); - aParent := aParent.Parent; - until Result or (aParent = nil); -end; -{--------} -procedure TffSqlNode.ResetConstant; -begin -end; -{--------} -function TffSqlNode.SQLText: string; -var - M : TMemoryStream; -begin - M := TMemoryStream.Create; - try - EmitSQL(M); - SetLength(Result, M.Size); - M.Seek(0, 0); - M.Read(Result[1], M.Size); - finally - M.Free; - end; -end; -{--------} -procedure TffSqlNode.SQLError(const ErrorMsg: string); -begin - raise Exception.CreateFmt('Error in statement: %s', [ErrorMsg]); -end; -{--------} -constructor TffSqlNode.Create(AParent: TffSqlNode); -begin - inherited Create; - FParent := AParent; -end; -{--------} -procedure TffSqlNode.EmitSQL(Stream: TStream); -begin - raise Exception.CreateFmt('Internal error:EmitSQL not implemented for %s', - [ClassName]); -end; -{====================================================================} - -{===TffSqlSelectionList==============================================} -function TffSqlSelectionList.AddSelection( - NewSelection: TffSqlSelection): TffSqlSelection; -begin - FSelections.Add(NewSelection); - Result := NewSelection; -end; -{--------} -procedure TffSqlSelectionList.Assign(const Source: TffSqlNode); -var - i : Integer; -begin - if Source is TffSqlSelectionList then begin - Clear; - for i := 0 to pred(TffSqlSelectionList(Source).SelectionCount) do - AddSelection(TffSqlSelection.Create(Self)).Assign( - TffSqlSelectionList(Source).Selection[i]); - end else - AssignError(Source); -end; - -{--------} -constructor TffSqlSelectionList.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); - FSelections := TList.Create; -end; -{--------} -procedure TffSqlSelectionList.Clear; -var - i : Integer; -begin - for i := 0 to pred(SelectionCount) do - Selection[i].Free; - FSelections.Clear; -end; - -{--------} -destructor TffSqlSelectionList.Destroy; -begin - Clear; - FSelections.Free; - inherited; -end; -{--------} -procedure TffSqlSelectionList.EmitSQL(Stream: TStream); -var - i : Integer; - First: Boolean; -begin - if SelectionCount > 0 then begin - First := True; - for i := 0 to pred(SelectionCount) do begin - if not First then - WriteStr(Stream, ', '); - if not Selection[i].AddedByWildcard then begin - Selection[i].EmitSQL(Stream); - First := False; - end; - end; - end; -end; -{--------} -procedure TffSqlSelectionList.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -var - i : Integer; -begin - Assert(TObject(Self) is TffSqlSelectionList); - EnumMethod(Self); - for i := 0 to pred(SelectionCount) do - Selection[i].EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlSelectionList.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if Other is TffSqlSelectionList then begin - if NonWildSelectionCount <> TffSqlSelectionList(Other).NonWildSelectionCount then - exit; - for i := 0 to pred(NonWildSelectionCount) do - if not NonWildSelection[i].Equals(TffSqlSelectionList(Other). - NonWildSelection[i]) then - exit; - Result := True; - end; -end; -{--------} -function TffSqlSelectionList.FindSelection(GroupCol : - TffSqlGroupColumn) : TffSqlSelection; -var - i : Integer; - F : TffSqlFieldProxy; - Name : string; -begin - Name := GroupCol.QualColumnName; - - for i := 0 to pred(SelectionCount) do - if Assigned(Selection[i].SimpleExpression.Term[0].Factor[0].FieldRef) and - (AnsiCompareText(Trim(Selection[i].SimpleExpression.Term[0].Factor[0]. - FieldRef.QualName), Name) = 0) then begin - Result := Selection[i]; - exit; - end else - if AnsiCompareText(Trim(Selection[i].SQLText), Name) = 0 then begin - Result := Selection[i]; - exit; - end else - if Selection[i].Column <> nil then - if AnsiCompareText(Selection[i].Column.ColumnName, Name) = 0 then begin - Result := Selection[i]; - exit; - end else - else - if Selection[i].SimpleExpression.IsField(F) then - if (AnsiCompareText(F.Name, Name) = 0) or - (AnsiCompareText(F.QualName, Name) = 0) then begin - Result := Selection[i]; - exit; - end; - Result := nil; -end; -{--------} -function TffSqlSelectionList.GetNonWildSelection( - Index: Integer): TffSqlSelection; -var - i: Integer; -begin - for i := 0 to pred(SelectionCount) do - if not Selection[i].AddedByWildcard then begin - dec(Index); - if Index < 0 then begin - Result := Selection[i]; - exit; - end; - end; - Result := nil; -end; -{--------} -function TffSqlSelectionList.GetSelection( - Index: Integer): TffSqlSelection; -begin - Result := TffSqlSelection(FSelections[Index]); - Assert(TObject(Result) is TffSqlSelection); -end; -{--------} -function TffSqlSelectionList.GetSelectionCount: Integer; -begin - Result := FSelections.Count; -end; -{--------} -procedure TffSqlSelectionList.InsertSelection(Index: Integer; - NewSelection: TffSqlSelection); -begin - FSelections.Insert(Index, NewSelection); -end; -{--------} -function TffSqlSelectionList.NonWildSelectionCount: Integer; -var - i : Integer; -begin - Result := 0; - for i := 0 to pred(SelectionCount) do - if not Selection[i].AddedByWildcard then - inc(Result); -end; - -function TffSqlSelectionList.Reduce: Boolean; -var - i : Integer; -begin - Result := False; - for i := 0 to pred(SelectionCount) do - Result := Result or Selection[i].Reduce; -end; - -procedure TffSqlSelectionList.SetSelection(Index: Integer; - const Value: TffSqlSelection); -begin - FSelections[Index] := Value; -end; -{====================================================================} - -{===TffSqlSimpleExpression===========================================} -function TffSqlSimpleExpression.AddTerm(Term: TffSqlTerm): TffSqlTerm; -begin - TermList.Add(Term); - Result := Term; -end; -{--------} -procedure TffSqlSimpleExpression.Assign(const Source: TffSqlNode); -var - i : Integer; -begin - if Source is TffSqlSimpleExpression then begin - Clear; - for i := 0 to pred(TffSqlSimpleExpression(Source).TermCount) do begin - AddTerm(TffSqlTerm.Create(Self)).Assign( - TffSqlSimpleExpression(Source).Term[i]); - end; - end else - AssignError(Source); -end; -{--------} -constructor TffSqlSimpleExpression.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); - TermList := TList.Create; -end; -{--------} -procedure TffSqlSimpleExpression.Clear; -var - i : Integer; -begin - for i := 0 to pred(TermCount) do - Term[i].Free; - TermList.Clear; - inherited; -end; -{--------} -{Begin !!.13} -function TffSqlSimpleExpression.ConcatBLOBValues(const Value1, Value2 : Variant) : Variant; -var - VPtr1, VPtr2 : PAnsiChar; - VStr1, VStr2 : string; - VLen1, VLen2 : Integer; - VPtrResult : PAnsiChar; -begin - try - if VarType(Value1) and VarTypeMask = varByte then begin - VPtr1 := VarArrayLock(Value1); - VStr1 := ''; - VLen1 := VarArrayHighBound(Value1, 1); - end - else begin - VStr1 := VarToStr(Value1); - VPtr1 := PAnsiChar(VStr1); - VLen1 := Length(VStr1); - end; - - if VarType(Value2) and VarTypeMask = varByte then begin - VPtr2 := VarArrayLock(Value2); - VStr2 := ''; - VLen2 := VarArrayHighBound(Value2, 1); - end - else begin - VStr2 := VarToStr(Value2); - VPtr2 := PAnsiChar(VStr2); - VLen2 := Length(VStr2); - end; - - { Assumption: The result may always be returned as a BLOB value. } - Result := VarArrayCreate([1, VLen1 + VLen2], varByte); - VPtrResult := VarArrayLock(Result); - try - Move(VPtr1^, VPtrResult^, VLen1); - inc(VPtrResult, VLen1); - Move(VPtr2^, VPtrResult^, VLen2); - finally - VarArrayUnlock(Result); - end; - - finally - if VStr1 = '' then - VarArrayUnlock(Value1); - if VStr2 = '' then - VarArrayUnlock(Value2); - end; -end; -{End !!.13} -{--------} -function TffSqlSimpleExpression.DependsOn( - Table: TFFSqlTableProxy): Boolean; -var - i : Integer; -begin - for i := 0 to pred(TermCount) do - if Term[i].DependsOn(Table) then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -destructor TffSqlSimpleExpression.Destroy; -begin - Clear; - TermList.Free; - inherited; -end; -{--------} -procedure TffSqlSimpleExpression.EmitSQL(Stream: TStream); -const - AddOpStr : array[TffSqlAddOp] of string = (' + ', ' - ', ' || '); -var - i : Integer; -begin - Term[0].EmitSQL(Stream); - for i := 1 to pred(TermCount) do begin - WriteStr(Stream, AddOpStr[Term[i].AddOp]); - Term[i].EmitSQL(Stream); - end; -end; -{--------} -procedure TffSqlSimpleExpression.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -var - i : Integer; -begin - EnumMethod(Self); - for i := 0 to pred(TermCount) do - Term[i].EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlSimpleExpression.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if Other is TffSqlSimpleExpression then begin - if TermCount <> TffSqlSimpleExpression(Other).TermCount then - exit; - for i := 0 to pred(TermCount) do - if not Term[i].Equals(TffSqlSimpleExpression(Other).Term[i]) then - exit; - Result := True; - end; -end; -{--------} -function TffSqlSimpleExpression.GetValue: Variant; -var - i : Integer; - Op: Variant; - Type1, Type2 : TffFieldType; {!!.13} -begin - if assigned(OwnerSelect) and - (OwnerSelect.AggQueryMode = aqmHaving) and not IsConstant - and not IsParameter then begin - Assert(BoundHaving); - Result := BoundHavingField.GetValue; - exit; - end; - if IsConstant then begin - Result := ConstantValue; - exit; - end; - Result := Term[0].GetValue; - if VarIsNull(Result) then exit; - for i := 1 to pred(TermCount) do begin - Op := Term[i].GetValue; - if VarIsNull(Op) then begin - Result := Null; - exit; - end; - Type1 := Term[0].GetType; - Type2 := Term[i].GetType; - case Term[i].AddOp of - aoPlus : - if (Type1 in [fftStDate, fftStTime, fftDateTime]) and - (Type2 = fftInterval) then - Result := Term[i].AddIntervalTo(Result) - else if (Type1 in [fftBLOB..fftBLOBTypedBin]) or - (Type2 in [fftBLOB..fftBLOBTypedBin]) then - Result := ConcatBLOBValues(Result, Op) - else - Result := Result + Op; - aoMinus : - if (Type1 in [fftStDate, fftStTime, fftDateTime]) and - (Type2 = fftInterval) then - Result := Term[i].SubtractIntervalFrom(Result) - else - Result := Result - Op; - aoConcat : - if (Type1 in [fftBLOB..fftBLOBTypedBin]) or - (Type2 in [fftBLOB..fftBLOBTypedBin]) then - Result := ConcatBLOBValues(Result, Op) - else - Result := Result + Op; - end; - end; -end; -{--------} -function TffSqlSimpleExpression.HasFieldRef: Boolean; -var - i : Integer; -begin - for i := 0 to pred(TermCount) do - if Term[i].HasFieldRef then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -function TffSqlSimpleExpression.IsAggregateExpression: Boolean; -var - i : Integer; -begin - for i := 0 to pred(TermCount) do - if Term[i].IsAggregateExpression then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -function TffSqlSimpleExpression.IsField(var FieldReferenced: - TFFSqlFieldProxy): Boolean; -begin - Result := (TermCount = 1) and Term[0].IsField(FieldReferenced); -end; -{--------} -function TffSqlSimpleExpression.IsFieldFrom( - Table: TFFSqlTableProxy; var FieldReferenced: TFFSqlFieldProxy; - var SameCase: Boolean): Boolean; -begin - Result := (TermCount = 1) and Term[0].IsFieldFrom(Table, - FieldReferenced, SameCase); -end; -{--------} -function TffSqlSimpleExpression.IsNull: Boolean; -var - i: Integer; -begin - for i := 0 to pred(TermCount) do - if Term[i].IsNull then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -function TffSqlSimpleExpression.GetTerm( - Index: Integer): TffSqlTerm; -begin - Result := TffSqlTerm(TermList[Index]); -end; -{--------} -function TffSqlSimpleExpression.GetTermCount: Integer; -begin - Result := TermList.Count; -end; -{--------} -function TffSqlSimpleExpression.GetTitle(const Qualified : Boolean): string; {!!.11} -begin - if TermCount = 1 then - Result := Term[0].GetTitle(Qualified) {!!.11} - else - Result := 'EXP'; -end; -{--------} -function TffSqlSimpleExpression.IsParameter: Boolean; -begin - Result := (TermCount = 1) - and (Term[0].FactorCount = 1) - and (Term[0].Factor[0].Param <> nil); -end; -{--------} -procedure TffSqlSimpleExpression.BindHaving; -var - i: Integer; -begin - BindingHaving := True; - try - if IsConstant - or IsParameter then - exit; - finally - BindingHaving := False; - end; - for i := 0 to pred(OwnerSelect.SelectionList.SelectionCount) do - if OwnerSelect.SelectionList.Selection[i].SimpleExpression.Equals( - Self) then begin - BoundHavingField := OwnerSelect.HavingTable.Field(i); - BoundHaving := True; - exit; - end; - (* test code - {attempt to bind to aliased expression} - else - if OwnerSelect.SelectionList.Selection[i].Column <> nil then begin - if SameText(OwnerSelect.SelectionList.Selection[i].Column.ColumnName, - trim(Self.SQLText)) then begin - BoundHavingField := OwnerSelect.HavingTable.Field(i); - BoundHaving := True; - exit; - end; - end; - *) - SQLError('Expression in HAVING clause doesn''t match any columns'); -end; -{--------} -function PropagateType(Type1, Type2: TffFieldType): TffFieldType; - - function IsInt(Type1: TffFieldType): Boolean; - begin - Result := Type1 in [fftByte, fftWord16, fftWord32, - fftInt8, fftInt16, fftInt32, fftAutoInc]; - end; - - function IsSigned(Type1: TffFieldType): Boolean; - begin - Result := Type1 in [fftInt8, fftInt16, fftInt32]; - end; - -begin - if Type1 = Type2 then - Result := Type1 - else - if IsInt(Type1) then - if IsInt(Type2) then - if IsSigned(Type1) then - if IsSigned(Type2) then - Result := fftInt32 - else - Result := fftSingle - else - if IsSigned(Type2) then - Result := fftSingle - else - Result := fftWord32 - else - Result := Type2 - else - if IsInt(Type2) then - Result := Type1 - else - Result := fftExtended; -end; -{--------} -procedure TffSqlSimpleExpression.CheckType; -var - i : Integer; - Type2: TffFieldType; -begin - FType := Term[0].GetType; - if TermCount > 1 then begin - case Term[1].AddOp of - aoPlus : - case FType of - fftByte, - fftWord16, - fftWord32, - fftInt8, - fftInt16, - fftInt32, - fftAutoInc, - fftSingle, - fftDouble, - fftExtended, - fftComp, - fftCurrency, - fftStDate, - fftStTime, - fftDateTime, - fftChar, - fftWideChar, - fftShortString, - fftShortAnsiStr, - fftNullString, - fftNullAnsiStr, - fftWideString : - ; - else - SQLError('Operator/operand mismatch'); - end; - aoMinus : - case FType of - fftByte, - fftWord16, - fftWord32, - fftInt8, - fftInt16, - fftInt32, - fftAutoInc, - fftSingle, - fftDouble, - fftExtended, - fftComp, - fftCurrency: - ; - fftStDate, - fftStTime, - fftDateTime : - case Term[1].GetType of - fftStDate, fftStTime, fftDateTime : - FType := fftDouble; - end; { case } - else - SQLError('Operator/operand mismatch'); - end; - aoConcat : - case FType of - fftChar, - fftWideChar, - fftShortString, - fftShortAnsiStr, - fftNullString, - fftNullAnsiStr, - fftWideString : - ; - else - SQLError('Operator/operand mismatch'); - end; - end; - for i := 1 to pred(TermCount) do begin - Type2 := Term[i].GetType; - case Term[i].AddOp of - aoPlus : - case Type2 of - fftByte, - fftWord16, - fftWord32, - fftInt8, - fftInt16, - fftInt32, - fftAutoInc, - fftSingle, - fftDouble, - fftExtended, - fftComp, - fftCurrency, - fftChar, - fftWideChar, - fftShortString, - fftShortAnsiStr, - fftNullString, - fftNullAnsiStr, - fftWideString, - fftStDate, - fftStTime, - fftDateTime, - fftInterval: - else - SQLError('Operator/operand mismatch'); - end; - aoMinus : - case Type2 of - fftByte, - fftWord16, - fftWord32, - fftInt8, - fftInt16, - fftInt32, - fftAutoInc, - fftSingle, - fftDouble, - fftExtended, - fftComp, - fftCurrency, - fftStDate, - fftStTime, - fftDateTime, - fftInterval: - ; - else - SQLError('Operator/operand mismatch'); - end; - aoConcat : - case Type2 of - fftChar, - fftWideChar, - fftShortString, - fftShortAnsiStr, - fftNullString, - fftNullAnsiStr, - fftWideString : - ; - else - SQLError('Operator/operand mismatch'); - end; - end; - case Type2 of - fftByte, fftWord16, fftWord32, fftInt8, fftInt16, fftInt32, - fftAutoInc, fftSingle, fftDouble, fftExtended, fftComp, fftCurrency : - FType := PropagateType(FType, Type2); - end; - end; - end; - TypeKnown := True; -end; -{--------} -function TffSqlSimpleExpression.GetDecimals: Integer; -var - i, j : Integer; -begin - Result := Term[0].GetDecimals; - for i := 1 to pred(TermCount) do begin - j := Term[i].GetDecimals; - if j > Result then - Result := j; - end; -end; -{--------} -function TffSqlSimpleExpression.GetSize: Integer; -var - i : Integer; -begin - Result := Term[0].GetSize; - {operator here can only be aoConcat - (because GetSize is only called for text fields)} - for i := 1 to pred(TermCount) do - inc(Result, Term[i].GetSize); -end; -{--------} -function TffSqlSimpleExpression.GetType: TffFieldType; -begin - if not TypeKnown then - CheckType; - Result := FType -end; -{--------} -function TffSqlSimpleExpression.IsAggregate: Boolean; -begin - Result := (TermCount = 1) and Term[0].IsAggregate; -end; -{--------} -procedure TffSqlSimpleExpression.CheckIsConstant; -var - i : Integer; - Save : TffSqlAggQueryMode; -begin - FIsConstantChecked := True; - for i := 0 to pred(TermCount) do - if not Term[i].IsConstant then begin - FIsConstant := False; - exit; - end; - if not BindingHaving then begin - Save := aqmIdle; - if assigned(OwnerSelect) then begin - Save := OwnerSelect.AggQueryMode; - OwnerSelect.AggQueryMode := aqmIdle; - end; - ConstantValue := GetValue; - if assigned(OwnerSelect) then - OwnerSelect.AggQueryMode := Save; - end; - FIsConstant := True; -end; -{--------} -function TffSqlSimpleExpression.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; -{--------} -procedure TffSqlSimpleExpression.MatchType(ExpectedType: TffFieldType); -var - i : Integer; -begin - for i := 0 to pred(TermCount) do - Term[i].MatchType(ExpectedType); -end; -{--------} -function TffSqlSimpleExpression.Reduce: Boolean; -var - i : Integer; -begin - for i := 0 to pred(TermCount) do - if Term[i].Reduce then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -procedure TffSqlSimpleExpression.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; -{--------} -procedure TffSqlSimpleExpression.SetTerm(Index: Integer; - const Value: TffSqlTerm); -begin - TermList[Index] := Value; -end; -{Begin !!.11} -{--------} -function TffSqlSimpleExpression.WasWildcard : Boolean; -begin - if TermCount = 1 then - Result := Term[0].WasWildcard - else - Result := False; -end; -{End !!.11} -{====================================================================} - -{===TffSqlTerm=======================================================} -function TffSqlTerm.AddFactor(Factor: TffSqlFactor): TffSqlFactor; -begin - FactorList.Add(Factor); - Result := Factor; -end; -{--------} -function TffSqlTerm.AddIntervalTo(Target: TDateTime): TDateTime; -begin - Result := Factor[0].AddIntervalTo(Target); -end; -{--------} -function TffSqlTerm.SubtractIntervalFrom(Target: TDateTime): TDateTime; -begin - Result := Factor[0].SubtractIntervalFrom(Target); -end; -{--------} -procedure TffSqlTerm.CheckIsConstant; -var - i : Integer; -begin - FIsConstantChecked := True; - for i := 0 to pred(FactorCount) do - if not Factor[i].IsConstant then begin - FIsConstant := False; - exit; - end; - ConstantValue := GetValue; - FIsConstant := True; -end; -{--------} -procedure TffSqlTerm.CheckType; -var - i : Integer; - Type2: TffFieldType; -begin - FType := Factor[0].GetType; - if FactorCount > 1 then begin - case Factor[1].MulOp of - moMul, moDiv : - case FType of - fftByte, - fftWord16, - fftWord32, - fftInt8, - fftInt16, - fftInt32, - fftAutoInc, - fftSingle, - fftDouble, - fftExtended, - fftComp, - fftCurrency : - ; - else - SQLError('Operator/operand mismatch'); - end; - end; - for i := 1 to pred(FactorCount) do begin - case Factor[i].MulOp of - moMul, moDiv : - begin - Type2 := Factor[i].GetType; - case Type2 of - fftByte, - fftWord16, - fftWord32, - fftInt8, - fftInt16, - fftInt32, - fftAutoInc, - fftSingle, - fftDouble, - fftExtended, - fftComp, - fftCurrency : - ; - else - SQLError('Operator/operand mismatch'); - end; - case Type2 of - fftByte, fftWord16, fftWord32, fftInt8, fftInt16, fftInt32, - fftAutoInc, fftSingle, fftDouble, fftExtended, fftComp, - fftCurrency : - FType := PropagateType(FType, Type2); - end; - end; - end; - end; - end; - TypeKnown := True; -end; -{--------} -procedure TffSqlTerm.Assign(const Source: TffSqlNode); -var - i : Integer; -begin - if Source is TffSqlTerm then begin - Clear; - for i := 0 to pred(TffSqlTerm(Source).FactorCount) do begin - AddFactor(TffSqlFactor.Create(Self)).Assign( - TffSqlTerm(Source).Factor[i]); - end; - AddOp := TffSqlTerm(Source).AddOp; - end else - AssignError(Source); -end; -{--------} -constructor TffSqlTerm.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); - FactorList := TList.Create; -end; -{--------} -procedure TffSqlTerm.Clear; -var - i : Integer; -begin - for i := 0 to pred(FactorCount) do - Factor[i].Free; - FactorList.Clear; -end; -{--------} -function TffSqlTerm.DependsOn(Table: TFFSqlTableProxy): Boolean; -var - i : Integer; -begin - for i := 0 to pred(FactorCount) do - if Factor[i].DependsOn(Table) then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -destructor TffSqlTerm.Destroy; -begin - Clear; - FactorList.Free; - inherited; -end; -{--------} -procedure TffSqlTerm.EmitSQL(Stream: TStream); -const - MulOpStr : array[TffSqlMulOp] of string = (' * ', ' / '); -var - i : Integer; -begin - Factor[0].EmitSQL(Stream); - for i := 1 to pred(FactorCount) do begin - WriteStr(Stream, MulOpStr[Factor[i].MulOp]); - Factor[i].EmitSQL(Stream); - end; -end; -{--------} -procedure TffSqlTerm.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -var - i : Integer; -begin - EnumMethod(Self); - for i := 0 to pred(FactorCount) do - Factor[i].EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlTerm.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if (Other is TffSqlTerm) - and (AddOp = TffSqlTerm(Other).AddOp) then begin - if FactorCount <> TffSqlTerm(Other).FactorCount then - exit; - for i := 0 to pred(FactorCount) do - if not Factor[i].Equals(TffSqlTerm(Other).Factor[i]) then - exit; - Result := True; - end; -end; -{--------} -function TffSqlTerm.GetFactor(Index: Integer): TffSqlFactor; -begin - Result := TffSqlFactor(FactorList[Index]); -end; -{--------} -function TffSqlTerm.GetFactorCount: Integer; -begin - Result := FactorList.Count; -end; -{--------} -function TffSqlTerm.GetDecimals: Integer; -var - i, j : Integer; -begin - Result := Factor[0].GetDecimals; - for i := 1 to pred(FactorCount) do begin - j := Factor[i].GetDecimals; - if j > Result then - Result := j; - end; -end; -{--------} -function TffSqlTerm.GetSize: Integer; -begin - Result := Factor[0].GetSize; -end; -{--------} -function TffSqlTerm.GetTitle(const Qualified : Boolean): string; {!!.11} -begin - if FactorCount = 1 then - Result := Factor[0].GetTitle(Qualified) {!!.11} - else - Result := 'EXP'; -end; -{--------} -function TffSqlTerm.GetType: TffFieldType; -begin - if not TypeKnown then - CheckType; - Result := FType -end; -{--------} -function TffSqlTerm.GetValue: Variant; -var - i : Integer; - Op: Variant; -begin - if IsConstant then begin - Result := ConstantValue; - exit; - end; - Result := Factor[0].GetValue; - if VarIsNull(Result) then exit; - for i := 1 to pred(FactorCount) do begin - Op := Factor[i].GetValue; - if VarIsNull(Op) then begin - Result := Null; - exit; - end; - case Factor[i{1}].MulOp of {!!.11} - moMul : - Result := Result * Op; - moDiv : - Result := Result / Op; - end; - end; -end; -{--------} -function TffSqlTerm.IsAggregate: Boolean; -begin - Result := (FactorCount = 1) and Factor[0].IsAggregate; -end; -{--------} -function TffSqlTerm.HasFieldRef: Boolean; -var - i : Integer; -begin - for i := 0 to pred(FactorCount) do - if Factor[i].HasFieldRef then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -function TffSqlTerm.IsAggregateExpression: Boolean; -var - i : Integer; -begin - for i := 0 to pred(FactorCount) do - if Factor[i].IsAggregate then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -function TffSqlTerm.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; -{--------} -function TffSqlTerm.IsField(var FieldReferenced: TFFSqlFieldProxy): Boolean; -begin - Result := (FactorCount = 1) and Factor[0].IsField(FieldReferenced); -end; -{--------} -function TffSqlTerm.IsFieldFrom(Table: TFFSqlTableProxy; - var FieldReferenced: TFFSqlFieldProxy; var SameCase: Boolean): Boolean; -begin - Result := (FactorCount = 1) and Factor[0].IsFieldFrom(Table, FieldReferenced, - SameCase); -end; -{--------} -function TffSqlTerm.IsNull: Boolean; -var - i : Integer; -begin - for i := 0 to pred(FactorCount) do - if Factor[i].IsNull then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -procedure TffSqlTerm.MatchType(ExpectedType: TffFieldType); -var - i : Integer; -begin - for i := 0 to pred(FactorCount) do - Factor[i].MatchType(ExpectedType); -end; -{--------} -function TffSqlTerm.Reduce: Boolean; -var - i : Integer; -begin - for i := 0 to pred(FactorCount) do - if Factor[i].Reduce then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -procedure TffSqlTerm.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; -{--------} -procedure TffSqlTerm.SetFactor(Index: Integer; - const Value: TffSqlFactor); -begin - FactorList[Index] := Value; -end; -{Begin !!.11} -{--------} -function TffSqlTerm.WasWildcard : Boolean; -begin - if FactorCount = 1 then - Result := Factor[0].WasWildcard - else - Result := False; -end; -{End !!.11} -{====================================================================} - -{===TffSqlCondExp====================================================} -function TffSqlCondExp.AddCondTerm(Term: TffSqlCondTerm): TffSqlCondTerm; -begin - CondTermList.Add(Term); - Result := Term; -end; -{--------} -function TffSqlCondExp.AsBooleanLevel(Level: Integer): Boolean; -var - i : Integer; -begin - if IsConstant then begin - Result := ConstantValue; - exit; - end; - for i := 0 to pred(CondTermCount) do - if CondTerm[i].AsBooleanLevel(Level) then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -function TffSqlCondExp.AsBoolean: Boolean; -var - i : Integer; -begin - if IsConstant then begin - Result := ConstantValue; - exit; - end; - for i := 0 to pred(CondTermCount) do - if CondTerm[i].AsBoolean then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -procedure TffSqlCondExp.Assign(const Source: TffSqlNode); -var - i : Integer; -begin - if Source is TffSqlCondExp then begin - Clear; - for i := 0 to pred(TffSqlCondExp(Source).CondTermCount) do - AddCondTerm(TffSqlCondTerm.Create(Self)).Assign( - TffSqlCondExp(Source).CondTerm[i]); - end else - AssignError(Source); -end; - -procedure TffSqlCondExp.BindHaving; -var - i : Integer; -begin - for i := 0 to pred(CondTermCount) do - CondTerm[i].BindHaving; -end; - -procedure TffSqlCondExp.CheckIsConstant; -var - i : Integer; -begin - FIsConstantChecked := True; - for i := 0 to pred(CondTermCount) do - if not CondTerm[i].IsConstant then begin - FIsConstant := False; - exit; - end; - ConstantValue := GetValue; - FIsConstant := True; -end; - -constructor TffSqlCondExp.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); - CondTermList := TList.Create; -end; -{--------} -procedure TffSqlCondExp.Clear; -var - i : Integer; -begin - for i := 0 to pred(CondTermCount) do - CondTerm[i].Free; - CondTermList.Clear; -end; -{--------} -function TffSqlCondExp.DependsOn(Table: TFFSqlTableProxy): Boolean; -var - i : Integer; -begin - for i := 0 to pred(CondTermCount) do - if CondTerm[i].DependsOn(Table) then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -destructor TffSqlCondExp.Destroy; -begin - Clear; - CondTermList.Free; - inherited; -end; -{--------} -procedure TffSqlCondExp.EmitSQL(Stream: TStream); -var - i : Integer; -begin - CondTerm[0].EmitSQL(Stream); - for i := 1 to pred(CondTermCount) do begin - WriteStr(Stream, ' OR'); - CondTerm[i].EmitSQL(Stream); - end; -end; -{--------} -procedure TffSqlCondExp.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -var - i : Integer; -begin - EnumMethod(Self); - for i := 0 to pred(CondTermCount) do - CondTerm[i].EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlCondExp.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if Other is TffSqlCondExp then begin - if CondTermCount <> TffSqlCondExp(Other).CondTermCount then - exit; - for i := 0 to pred(CondTermCount) do - if not CondTerm[i].Equals(TffSqlCondExp(Other).CondTerm[i]) then - exit; - Result := True; - end; -end; -{--------} -function TffSqlCondExp.GetCondTerm( - Index: Integer): TffSqlCondTerm; -begin - Result := TffSqlCondTerm(CondTermList[Index]); -end; -{--------} -function TffSqlCondExp.GetCondTermCount: Integer; -begin - Result := CondTermList.Count; -end; -{--------} -function TffSqlCondExp.GetDecimals: Integer; -begin - if CondTermCount > 1 then - TypeMismatch; - Result := CondTerm[0].GetDecimals; -end; -{--------} -{!!.10 new} -function TffSqlCondExp.GetSize: Integer; -begin - if CondTermCount > 1 then - Result := 1 - else - Result := CondTerm[0].GetSize; -end; -{--------} -function TffSqlCondExp.GetTitle(const Qualified : Boolean): string; {!!.11} -begin - if CondTermCount > 1 then - Result := 'COND' - else - Result := CondTerm[0].GetTitle(Qualified); {!!.11} -end; -{--------} -function TffSqlCondExp.GetType: TffFieldType; -var - i: Integer; -begin - if CondTermCount > 1 then begin - {force type conversion at lower level if necessary} - for i := 0 to pred(CondTermCount) do - CondTerm[i].GetType; - Result := fftBoolean - end else - Result := CondTerm[0].GetType; -end; -{--------} -function TffSqlCondExp.GetValue: Variant; -begin - if IsConstant then begin - Result := ConstantValue; - exit; - end; - if CondTermCount > 1 then - Result := AsBoolean - else - Result := CondTerm[0].GetValue; -end; -{--------} -function TffSqlCondExp.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; - -procedure TffSqlCondExp.MatchType(ExpectedType: TffFieldType); -begin - if CondTermCount = 1 then {!!.11} - CondTerm[0].MatchType(ExpectedType) {!!.11} - else {!!.11} - if GetType <> ExpectedType then - TypeMismatch; -end; -{--------} -function TffSqlCondExp.Reduce: Boolean; -var - i,j : Integer; - InFactIX, - InTermIX: Integer; - NewTerm, LiftTerm : TffSqlCondTerm; - NewFactor: TffSqlCondFactor; - NewPrimary: TffSqlCondPrimary; - LiftInClause: TffSqlInClause; - LiftInExp: TffSqlSimpleExpression; - LiftExp : TffSqlCondExp; -begin - Result := False; - LiftInClause := nil; - LiftInExp := nil; - LiftExp := nil; - InTermIX := -1; //just to make the compiler happy - InFactIX := -1; //just to make the compiler happy - for i := 0 to pred(CondTermCount) do begin - {look for conditional terms nested inside redundant parens} - {eliminate parens when found} - LiftTerm := nil; - LiftExp := nil; - with CondTerm[i] do begin - if CondFactorCount = 1 then begin - with CondFactor[0] do - if not UnaryNot then - if (CondPrimary.RelOp = roNone) then - if CondPrimary.SimpleExp1 <> nil then - if CondPrimary.JustSimpleExpression then - with CondPrimary.SimpleExp1 do - if TermCount = 1 then begin - with Term[0] do - if FactorCount = 1 then - with Factor[0] do - if CondExp <> nil then - with CondExp do - if CondTermCount = 1 then begin - LiftTerm := TffSqlCondTerm.Create(Self); - LiftTerm.Assign(CondTerm[0]); - end; - end; - end; - if LiftTerm <> nil then begin - Clear; - Assign(LiftTerm); - LiftTerm.Free; - Result := True; - {Get out. We may have more to do here, but Global Logic will - call us again, and there may be other transformations that can - be applied first.} - break; - end; - if Reduce then begin - {term itself was reduced} - Result := True; - break; - end; - if not Result then begin - {look for IN expressions to be converted to simple comparisons} - for j := 0 to pred(CondFactorCount) do - with CondFactor[j] do - if not UnaryNot then {can't handle negated expressions} - if CondPrimary.RelOp = roNone then - if (CondPrimary.InClause <> nil) - and not (CondPrimary.InClause.Negated) - and (CondPrimary.InClause.SubQuery = nil) - and (CondPrimary.InClause.SimpleExpList.ExpressionCount <= - ffSqlInConvThreshold) then begin - {Here's one. Make a copy of it and get up to the - root level since we'll be doing surgery on this - very node hierarchy we're current looking at} - LiftInClause := TffSqlInClause.Create(Self); - LiftInClause.Assign(CondPrimary.InClause); - LiftInExp := TffSqlSimpleExpression.Create(Self); - LiftInExp.Assign(CondPrimary.SimpleExp1); - InTermIX := i; // just a reference back to here - if CondFactorCount > 1 then - {we have other factors that need to be copied - - make note of where the IN is - we should copy - everything BUT} - InFactIX := j - {we're the only factor, make a note of that by - setting the InFactIX flag to -1 indicating no - other factors should be copied} - else - InFactIX := -1; - break; - end; - end; - if not Result then begin - {look for nested conditional expressions to be lifted out, like - (A OR B) AND C to be converted to A AND C OR B AND C} - for j := 0 to pred(CondFactorCount) do - with CondFactor[j] do - if not UnaryNot then - if (CondPrimary.RelOp = roNone) then - if CondPrimary.SimpleExp1 <> nil then - if CondPrimary.JustSimpleExpression then - with CondPrimary.SimpleExp1 do - if TermCount = 1 then begin - with Term[0] do - if FactorCount = 1 then - with Factor[0] do - if CondExp <> nil then begin - LiftExp := TffSqlCondExp.Create(Self); - LiftExp.Assign(CondExp); - InTermIX := i; // A reference back to here - InFactIX := j; // A reference back to here - end; - end; - end; - if LiftInClause <> nil then - break; - if LiftExp <> nil then - break; - end; - end; - if LiftExp <> nil then begin - {create a top-level conditional term for each nested term, - then copy each conditional factor except the one we're converting - to each new term:} - for i := 0 to pred(LiftExp.CondTermCount) do begin - NewTerm := TffSqlCondTerm.Create(Self); - NewTerm.Assign(LiftExp.CondTerm[i]); - for j := 0 to pred(CondTerm[InTermIX].CondFactorCount) do - if j <> InFactIX then begin - NewFactor := TffSqlCondFactor.Create(NewTerm); - NewFactor.Assign(CondTerm[InTermIX].CondFactor[j]); - NewTerm.AddCondFactor(NewFactor); - end; - AddCondTerm(NewTerm); - end; - LiftInClause.Free; - LiftInExp.Free; - LiftExp.Free; - CondTerm[InTermIX].Free; - CondTermList.Delete(InTermIX); - Result := True; - exit; - end; - if (LiftInClause <> nil) - and (InFactIX = -1) then begin {only do this optimization if no other factors} {!!.11} - {Okay - that was the easy bit, finding the IN clause. - We now need to build conditional terms for each of the - alternatives - each with a simple comparison corresponding - to each entry in the IN clause list.} - for i := 0 to pred(LiftInClause.SimpleExpList.ExpressionCount) do begin - NewTerm := TffSqlCondTerm.Create(Self); - NewFactor := TffSqlCondFactor.Create(NewTerm); - NewPrimary := TffSqlCondPrimary.Create(NewFactor); - NewPrimary.SimpleExp1 := TffSqlSimpleExpression.Create(NewPrimary); - NewPrimary.SimpleExp1.Assign(LiftInExp); - NewPrimary.SimpleExp2 := TffSqlSimpleExpression.Create(NewPrimary); - NewPrimary.SimpleExp2.Assign(LiftInClause.SimpleExpList.Expression[i]); - NewPrimary.RelOp := roEQ; - NewFactor.CondPrimary := NewPrimary; - NewTerm.AddCondFactor(NewFactor); - {If we didn't have any other conditional factors - combined with the IN clause - IOW, we didn't have something like - Exp IN [blahblah] AND something else, - then we're actually done. All we need to do is add each term, then - finish off by deleting the original term which held the IN clause. - - On the other hand, if we did have other factors, they all need to - be copied to the new term:} - if InFactIX <> -1 then begin - with CondTerm[InTermIX] do - for j := 0 to pred(CondFactorCount) do - if j <> InFactIX then begin - NewFactor := TffSqlCondFactor.Create(NewTerm); - NewFactor.Assign(CondFactor[j]); - NewTerm.AddCOndFactor(NewFactor); - end; - end; - - AddCondTerm(NewTerm); - end; - {LiftInClause.Free;} {!!.12} - {LiftInExp.Free;} {!!.12} - //get rid of the original term with the IN clause - CondTerm[InTermIX].Free; - CondTermList.Delete(InTermIX); - Result := True; - end; - LiftInClause.Free; {!!.12} - LiftInExp.Free; {!!.12} - {!!.11 begin} - if not Result then - for i := 0 to pred(CondTermCount) do - if CondTerm[i].Reduce then begin - Result := True; - break; - end; - {!!.11 end} -end; - -procedure TffSqlCondExp.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; - -procedure TffSqlCondExp.SetCondTerm(Index: Integer; - const Value: TffSqlCondTerm); -begin - CondTermList[Index] := Value; -end; - -procedure TffSqlCondExp.SetLevelDep(List: TFFSqlTableProxySubsetList); -var - i : Integer; -begin - for i := 0 to pred(CondTermCount) do - CondTerm[i].SetLevelDep(List); -end; - -{====================================================================} - - -{===TffSqlCondTerm===================================================} -function TffSqlCondTerm.AddCondFactor(Factor: TffSqlCondFactor): TffSqlCondFactor; -begin - CondFactorList.Add(Factor); - Result := Factor; -end; -{--------} -function TffSqlCondTerm.InsertCondFactor(Index: Integer; - Factor : TffSqlCondFactor): TffSqlCondFactor; -begin - CondFactorList.Insert(Index, Factor); - Result := Factor; -end; -{--------} -procedure TffSqlCondTerm.SetLevelDep(List: TFFSqlTableProxySubsetList); -var - F, Level : Integer; -begin - for F := 0 to pred(CondFactorCount) do - with CondFactor[F] do begin - EvalLevel := List.Count; - for Level := pred(List.Count) downto 0 do - if DependsOn(List.Item[Level].Table) then - EvalLevel := Level; - end; -end; - -function TffSqlCondTerm.AsBoolean: Boolean; -var - i : Integer; -begin - if IsConstant then begin - Result := ConstantValue; - exit; - end; - for i := 0 to pred(CondFactorCount) do - if not CondFactor[i].AsBoolean then begin - Result := False; - exit; - end; - Result := True; -end; -{--------} -function TffSqlCondTerm.AsBooleanLevel(Level: Integer): Boolean; -var - i : Integer; -begin - if IsConstant then begin - Result := ConstantValue; - exit; - end; - for i := 0 to pred(CondFactorCount) do - if (CondFactor[i].EvalLevel >= Level) - and not CondFactor[i].AsBoolean then begin - Result := False; - exit; - end; - Result := True; -end; -{--------} -procedure TffSqlCondTerm.Assign(const Source: TffSqlNode); -var - i : Integer; -begin - if Source is TffSqlCondTerm then begin - Clear; - for i := 0 to pred(TffSqlCondTerm(Source).CondFactorCount) do begin - AddCondFactor(TffSqlCondFactor.Create(Self)).Assign( - TffSqlCondTerm(Source).CondFactor[i]); - end; - end else - AssignError(Source); -end; - -procedure TffSqlCondTerm.BindHaving; -var - i : Integer; -begin - for i := 0 to pred(CondFactorCount) do - CondFactor[i].BindHaving; -end; - -procedure TffSqlCondTerm.CheckIsConstant; -var - i : Integer; -begin - FIsConstantChecked := True; - for i := 0 to pred(CondFactorCount) do - if not CondFactor[i].IsConstant then begin - FIsConstant := False; - exit; - end; - ConstantValue := GetValue; - FIsConstant := True; -end; - -constructor TffSqlCondTerm.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); - CondFactorList := TList.Create; -end; -{--------} -procedure TffSqlCondTerm.Clear; -var - i : Integer; -begin - for i := 0 to pred(CondFactorCount) do - CondFactor[i].Free; - CondFactorList.Clear; -end; -{--------} -function TffSqlCondTerm.DependsOn(Table: TFFSqlTableProxy): Boolean; -var - i : Integer; -begin - for i := 0 to pred(CondFactorCount) do - if CondFactor[i].DependsOn(Table) then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -destructor TffSqlCondTerm.Destroy; -begin - Clear; - CondFactorList.Free; - OrderedSources.Free; - inherited; -end; -{--------} -procedure TffSqlCondTerm.EmitSQL(Stream: TStream); -var - i : Integer; -begin - CondFactor[0].EmitSQL(Stream); - for i := 1 to pred(CondFactorCount) do begin - WriteStr(Stream,' AND'); - CondFactor[i].EmitSQL(Stream); - end; -end; -{--------} -procedure TffSqlCondTerm.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -var - i : Integer; -begin - EnumMethod(Self); - for i := 0 to pred(CondFactorCount) do - CondFactor[i].EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlCondTerm.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if Other is TffSqlCondTerm then begin - if CondFactorCount <> TffSqlCondTerm(Other).CondFactorCount then - exit; - for i := 0 to pred(CondFactorCount) do - if not CondFactor[i].Equals(TffSqlCondTerm(Other).CondFactor[i]) then - exit; - Result := True; - end; -end; -{--------} -function TffSqlCondTerm.GetCondFactor( - Index: Integer): TffSqlCondFactor; -begin - Result := TffSqlCondFactor(CondFactorList[Index]); -end; -{--------} -function TffSqlCondTerm.GetCondFactorCount: Integer; -begin - Result := CondFactorList.Count; -end; -{--------} -function TffSqlCondTerm.GetDecimals: Integer; -begin - if CondFactorCount > 1 then - TypeMismatch; - Result := CondFactor[0].GetDecimals; -end; -{--------} -{!!.10 new} -function TffSqlCondTerm.GetSize: Integer; -begin - if CondFactorCount > 1 then - Result := 1 - else - Result := CondFactor[0].GetSize; -end; -{--------} -function TffSqlCondTerm.GetTitle(const Qualified : Boolean): string; {!!.11} -begin - if CondFactorCount > 1 then - Result := 'COND' - else - Result := CondFactor[0].GetTitle(Qualified); {!!.11} -end; -{--------} -function TffSqlCondTerm.GetType: TffFieldType; -var - i: Integer; -begin - if CondFactorCount > 1 then begin - {force type conversion at lower level if necessary} - for i := 0 to pred(CondFactorCount) do - CondFactor[i].GetType; - Result := fftBoolean - end else - Result := CondFactor[0].GetType; -end; -{--------} -function TffSqlCondTerm.GetValue: Variant; -begin - if IsConstant then begin - Result := ConstantValue; - exit; - end; - if CondFactorCount > 1 then - Result := AsBoolean - else - Result := CondFactor[0].GetValue; -end; -{--------} -function TffSqlCondTerm.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; - -{!!.11 new} -procedure TffSqlCondTerm.MatchType(ExpectedType: TffFieldType); -var - i: Integer; - T: TffFieldType; -begin - if CondFactorCount > 1 then begin - if ExpectedType <> fftBoolean then - TypeMismatch; - {force necessary type conversion at lower level} - T := CondFactor[0].GetType; - for i := 1 to CondFactorCount - 1 do - CondFactor[i].MatchType(T); - end else - CondFactor[0].MatchType(ExpectedType); -end; - -function TffSqlCondTerm.Reduce: Boolean; -var - i, j : Integer; - LiftFactor : TffSqlCondFactor; - LiftTerm: TffSqlCondTerm; - B : Boolean; -begin - {Look for conditional factors nested inside redundant parens} - { - eliminate parens when found} - {Look for BETWEEN expressions and convert them to two comparisons} - Result := False; - for i := 0 to pred(CondFactorCount) do begin - //LiftFactor := nil; - LiftTerm := nil; - with CondFactor[i] do begin - if (CondPrimary.RelOp = roNone) then - if CondPrimary.BetweenClause <> nil then begin - if not CondPrimary.BetweenClause.Negated xor UnaryNot then begin - {create a new CondPrimary to hold the >= comparison} - LiftFactor := TffSqlCondFactor.Create(Self); - LiftFactor.CondPrimary := TffSqlCondPrimary.Create(LiftFactor); - LiftFactor.CondPrimary.RelOp := roGE; - LiftFactor.CondPrimary.SimpleExp1 := - TffSqlSimpleExpression.Create(LiftFactor.CondPrimary); - LiftFactor.CondPrimary.SimpleExp1.Assign(CondPrimary.SimpleExp1); - LiftFactor.CondPrimary.SimpleExp2 := - TffSqlSimpleExpression.Create(LiftFactor.CondPrimary); - LiftFactor.CondPrimary.SimpleExp2.Assign( - CondPrimary.BetweenClause.SimpleLow); - InsertCondFactor(i, LiftFactor); - {convert current CondPrimary to a >= comparison} - CondPrimary.RelOp := roLE; - CondPrimary.SimpleExp2 := TffSqlSimpleExpression.Create(CondPrimary); - CondPrimary.SimpleExp2.Assign(CondPrimary.BetweenClause.SimpleHigh); - CondPrimary.BetweenClause.Free; - CondPrimary.BetweenClause := nil; - Result := True; - UnaryNot := False; - break; - end; - end else - if CondPrimary.LikeClause <> nil then begin - if not CondPrimary.LikeClause.Negated xor UnaryNot then begin - if CondPrimary.LikeClause.CanLimit then begin - {create a new CondPrimary to hold the >= comparison} - LiftFactor := TffSqlCondFactor.Create(Self); - LiftFactor.CondPrimary := TffSqlCondPrimary.Create(LiftFactor); - LiftFactor.CondPrimary.RelOp := roGE; - LiftFactor.CondPrimary.SimpleExp1 := TffSqlSimpleExpression.Create(LiftFactor.CondPrimary); - LiftFactor.CondPrimary.SimpleExp1.Assign(CondPrimary.SimpleExp1); - LiftFactor.CondPrimary.SimpleExp2 := CreateLiteralStringExp(LiftFactor, CondPrimary.LikeClause.GetLowLimit); - InsertCondFactor(i, LiftFactor); - {create a new CondPrimary to hold the <= comparison} - LiftFactor := TffSqlCondFactor.Create(Self); - LiftFactor.CondPrimary := TffSqlCondPrimary.Create(LiftFactor); - LiftFactor.CondPrimary.RelOp := roL; - LiftFactor.CondPrimary.SimpleExp1 := TffSqlSimpleExpression.Create(LiftFactor.CondPrimary); - LiftFactor.CondPrimary.SimpleExp1.Assign(CondPrimary.SimpleExp1); - LiftFactor.CondPrimary.SimpleExp2 := CreateLiteralStringExp(LiftFactor, CondPrimary.LikeClause.GetHighLimit); - InsertCondFactor(i, LiftFactor); - if CondPrimary.LikeClause.CanReplaceWithCompare then begin - {we no longer need the LIKE clause} - CondFactor[i + 2].Free; - CondFactorList.Delete(i + 2); // adjust for the two we just inserted - end else - CondPrimary.LikeClause.Limited := True; - Result := True; - break; - end; - end; - end else - if CondPrimary.InClause <> nil then - else - if CondPrimary.IsTest <> nil then - else - if CondPrimary.ExistsClause <> nil then - else - if CondPrimary.UniqueClause <> nil then - else - if CondPrimary.MatchClause <> nil then - else - if CondPrimary.SimpleExp1 <> nil then - with CondPrimary.SimpleExp1 do - if TermCount = 1 then begin - with Term[0] do - if FactorCount = 1 then - with Factor[0] do - if CondExp <> nil then - with CondExp do - if CondTermCount = 1 then - LiftTerm := CondTerm[0]; - end; - if LiftTerm <> nil then begin - //first lift all but the very first conditional factor to this level - for j := 1 to pred(LiftTerm.CondFactorCount) do - Self.AddCondFactor(TffSqlCondFactor.Create(Self)). - Assign(LiftTerm.CondFactor[j]); - //then copy the contents of the first conditional factor - // (possibly the only one) into this one - B := UnaryNot; // save UnaryNot setting - LiftFactor := TffSqlCondFactor.Create(Self); - LiftFactor.Assign(LiftTerm.CondFactor[0]); - Clear; - Assign(LiftFactor); - LiftFactor.Free; - UnaryNot := UnaryNot xor B; - Result := True; - {Get out. We may have more to do here, but Global Logic will - call us again, and there may be other transformations that can - be applied first.} - break; - end; - if Reduce then begin - {factor itself was reduced} - Result := True; - break; - end; - end; - end; - {!!.11 begin} - if not Result then - for i := 0 to pred(CondFactorCount) do - if CondFactor[i].Reduce then begin - Result := True; - break; - end; - {!!.11 end} -end; - -procedure TffSqlCondTerm.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; - -procedure TffSqlCondTerm.SetCondFactor(Index: Integer; - const Value: TffSqlCondFactor); -begin - CondFactorList[Index] := Value; -end; -{====================================================================} - -{===TffSqlGroupColumnList=================================================} -function TffSqlGroupColumnList.AddColumn(Column: TffSqlGroupColumn): - TffSqlGroupColumn; -begin - ColumnList.Add(Column); - Result := Column; -end; -{--------} -procedure TffSqlGroupColumnList.Assign(const Source: TffSqlNode); -var - i : Integer; -begin - if Source is TffSqlGroupColumnList then begin - Clear; - for i := 0 to pred(TffSqlGroupColumnList(Source).ColumnCount) do - AddColumn(TffSqlGroupColumn.Create(Self)).Assign( - TffSqlGroupColumnList(Source).Column[i]); - end else - AssignError(Source); -end; -{--------} -function TffSqlGroupColumnList.Contains(const aColName : string; - Se: TffSqlSelection): Boolean; -{Rewritten !!.06} -var - i : Integer; - aGrpColText, - aSelText : string; -begin - if Assigned(Se.SimpleExpression.Term[0].Factor[0].FieldRef) then - aSelText := Trim(Se.SimpleExpression.Term[0].Factor[0].FieldRef.QualName) - else - aSelText := Trim(Se.SQLText); - - for i := 0 to pred(ColumnCount) do begin - aGrpColText := Trim(Column[i].QualColumnName); - Result := (AnsiCompareText(aColName, aGrpColText) = 0) or - (AnsiCompareText(aSelText, aGrpColText) = 0); - if Result then - Exit; - end; { for } - Result := False; -end; -{--------} -constructor TffSqlGroupColumnList.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); - ColumnList := TList.Create; -end; -{--------} -procedure TffSqlGroupColumnList.Clear; -var - i : Integer; -begin - for i := 0 to pred(ColumnCount) do - Column[i].Free; - ColumnList.Clear; -end; -{--------} -destructor TffSqlGroupColumnList.Destroy; -begin - Clear; - ColumnList.Free; - inherited; -end; -{--------} -procedure TffSqlGroupColumnList.EmitSQL(Stream: TStream); -var - i: Integer; -begin - Column[0].EmitSQL(Stream); - for i := 1 to pred(ColumnCount) do begin - WriteStr(Stream,', '); - Column[i].EmitSQL(Stream); - end; -end; -{--------} -procedure TffSqlGroupColumnList.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -var - i : Integer; -begin - EnumMethod(Self); - for i := 0 to pred(ColumnCount) do - Column[i].EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlGroupColumnList.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if Other is TffSqlGroupColumnList then begin - if ColumnCount <> TffSqlGroupColumnList(Other).ColumnCount then - exit; - for i := 0 to pred(ColumnCount) do - if not Column[i].Equals(TffSqlGroupColumnList(Other).Column[i]) then - exit; - Result := True; - end; -end; -{--------} -function TffSqlGroupColumnList.GetColumn(Index: Integer): TffSqlGroupColumn; -begin - Result := TffSqlGroupColumn(ColumnList[Index]); -end; -{--------} -function TffSqlGroupColumnList.GetColumnCount: Integer; -begin - Result := ColumnList.Count; -end; -{--------} -function TffSqlGroupColumnList.Reduce: Boolean; -begin - Result := False; -end; - -procedure TffSqlGroupColumnList.SetColumn(Index: Integer; - const Value: TffSqlGroupColumn); -begin - ColumnList[Index] := VAlue; -end; -{====================================================================} - -{===TffSqlTableRefList===============================================} -function TffSqlTableRefList.AddTableRef( - NewTableRef: TffSqlTableRef): TffSqlTableRef; -begin - FTableRefList.Add(NewTableRef); - Result := NewTableRef; -end; -{--------} -procedure TffSqlTableRefList.Assign(const Source: TffSqlNode); -var - i: Integer; -begin - if Source is TffSqlTableRefList then begin - Clear; - for i := 0 to pred(TffSqlTableRefList(Source).TableRefCount) do - AddTableRef(TffSqlTableRef.Create(Self)).Assign( - TffSqlTableRefList(Source).TableRef[i]); - end else - AssignError(Source); -end; - -constructor TffSqlTableRefList.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); - FTableRefList := TList.Create; -end; -{--------} -function TffSqlTableRefList.BindFieldDown(const TableName, - FieldName: string): TFFSqlFieldProxy; -var - i : Integer; -begin - Result := nil; - for i := 0 to pred(TableRefCount) do begin - Result := TableRef[i].BindFieldDown(TableName, FieldName); - if Result <> nil then - exit; - end; -end; - -function TffSqlTableRefList.BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; -var - i : Integer; -begin - Result := nil; - for i := 0 to pred(TableRefCount) do begin - Result := TableRef[i].BindTable(AOwner, TableName); - if Result <> nil then - exit; - end; -end; - -procedure TffSqlTableRefList.Clear; -var - i : Integer; -begin - for i := 0 to pred(TableRefCount) do - TableRef[i].Free; - FTableRefList.Clear; - inherited; -end; -{--------} -destructor TffSqlTableRefList.Destroy; -begin - Clear; - FTableRefList.Free; - inherited; -end; -{--------} -procedure TffSqlTableRefList.EmitSQL(Stream: TStream); -var - i : Integer; -begin - if TableRefCount > 0 then begin - TableRef[0].EmitSQL(Stream); - for i := 1 to pred(TableRefCount) do begin - WriteStr(Stream,' ,'); - TableRef[i].EmitSQL(Stream); - end; - end; -end; -{--------} -procedure TffSqlTableRefList.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -var - i : Integer; -begin - EnumMethod(Self); - for i := 0 to pred(TableRefCount) do - TableRef[i].EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlTableRefList.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if Other is TffSqlTableRefList then begin - if TableRefCount <> TffSqlTableRefList(Other).TableRefCount then - exit; - for i := 0 to pred(TableRefCount) do - if not TableRef[i].Equals(TffSqlTableRefList(Other).TableRef[i]) then - exit; - Result := True; - end; -end; -{--------} -{!!.11 new} -function TffSqlTableRefList.GetFieldsFromTable(const TableName: string; - List: TList): TffSqlTableProxy; -{-returns fields from table that are ultimately coming from the table - specified in the TableName argument. NIL if not found.} -var - i, j: Integer; -begin - Result := nil; {!!.11} - for i := 0 to TableRefCount - 1 do - if SameText(TableRef[i].Alias, TableName) - or SameText(TableRef[i].TableName, TableName) then begin - Result := TableRef[i].ResultTable; - for j := 0 to Result.FieldCount - 1 do - List.Add(Result.Field(j)); - exit; - end; - {still here, which means that if there's a match, it's in a nested table} - for i := 0 to TableRefCount - 1 do begin - if TableRef[i].TableExp <> nil then {!!.11} - Result := TableRef[i].TableExp.GetFieldsFromTable(TableName, List); - if Result <> nil then - exit; - end; -// Result := nil; {Deleted !!.11} -end; -{--------} -function TffSqlTableRefList.GetNameForAlias(const Alias : string) : string; -var - Inx : Integer; -begin - Result := ''; - for Inx := 0 to Pred(FTableRefList.Count) do begin - if TffSqlTableRef(FTableRefList[Inx]).Alias = Alias then begin - Result := TffSqlTableRef(FTableRefList[Inx]).TableName; - Break; - end; - end; -end; -{--------} -function TffSqlTableRefList.GetTableRef( - Index: Integer): TffSqlTableRef; -begin - Result := TffSqlTableRef(FTableRefList[Index]); -end; -{--------} -function TffSqlTableRefList.GetTableRefCount: Integer; -begin - Result := FTableRefList.Count; -end; -{--------} -{!!.11 rewritten} -function TffSqlTableRefList.Reduce: Boolean; -var - i: Integer; -begin - for i := 0 to TableRefCount - 1 do - if TableRef[i].Reduce then begin - Result := True; - exit; - end; - Result := False; -end; - -procedure TffSqlTableRefList.SetTableRef(Index: Integer; - const Value: TffSqlTableRef); -begin - FTableRefList[Index] := Value; -end; -{====================================================================} - -{===TffSqlStatement==================================================} -procedure TffSqlStatement.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlStatement then begin - Clear; - if TffSqlStatement(Source).Insert <> nil then begin - Insert := TffSqlINSERT.Create(Self); - Insert.Assign(TffSqlStatement(Source).Insert); - end; - if TffSqlStatement(Source).Update <> nil then begin - Update := TffSqlUPDATE.Create(Self); - Update.Assign(TffSqlStatement(Source).Update); - end; - if TffSqlStatement(Source).Delete <> nil then begin - Delete := TffSqlDELETE.Create(Self); - Delete.Assign(TffSqlStatement(Source).Delete); - end; - if TffSqlStatement(Source).TableExp <> nil then begin - TableExp := TffSqlTableExp.Create(Self); - TableExp.Assign(TffSqlStatement(Source).TableExp); - end; - Reduce := TffSqlStatement(Source).Reduce; - UseIndex := TffSqlStatement(Source).UseIndex; - end else - AssignError(Source); -end; -{Begin !!.11} -{--------} -procedure TffSqlStatement.Bind(const ClientID: TffClientID; - const SessionID: TffSessionID; - Database : TffSqlDatabaseProxy); -begin - FClientID := ClientID; - FSessionID := SessionID; - FDatabase := Database; - if assigned(Insert) then - Insert.Bind - else if assigned(Update) then - Update.Bind - else if assigned(Delete) then - Delete.Bind; -end; -{--------} -{End !!.11} -procedure TffSqlStatement.Clear; -begin - Insert.Free; - Insert := nil; - Update.Free; - Update := nil; - Delete.Free; - Delete := nil; - TableExp.Free; - TableExp := nil; -end; -{--------} -constructor TffSqlStatement.Create; -begin - inherited Create(nil); - {$IFDEF ExposeLastStatement} - LastStatement := Self; {debug hook} - {$ENDIF} -end; -{--------} -destructor TffSqlStatement.Destroy; -begin - ParmList.Free; - Clear; - inherited; - {$IFDEF ExposeLastStatement} - LastStatement := nil; {debug hook} - {$ENDIF} -end; -{--------} -procedure TffSqlStatement.EmitSQL(Stream: TStream); -begin - if not UseIndex then - WriteStr(Stream,'NOINDEX '); - if not Reduce then - WriteStr(Stream,'NOREDUCE '); - if assigned(Insert) then - Insert.EmitSQL(Stream); - if assigned(Update) then - Update.EmitSQL(Stream); - if assigned(Delete) then - Delete.EmitSQL(Stream); - if assigned(TableExp) then - TableExp.EmitSQL(Stream); - WriteStr(Stream,';'); - WriteEOF(Stream); -end; -{--------} -procedure TffSqlStatement.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - if assigned(Insert) then - Insert.EnumNodes(EnumMethod, Deep); - if assigned(Update) then - Update.EnumNodes(EnumMethod, Deep); - if assigned(Delete) then - Delete.EnumNodes(EnumMethod, Deep); - if assigned(TableExp) then - TableExp.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlStatement.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlStatement) - and ((BothNil(Insert, TffSqlStatement(Other).Insert) - or (BothNonNil(Insert, TffSqlStatement(Other).Insert) - and Insert.Equals(TffSqlStatement(Other).Insert)))) - and ((BothNil(Update, TffSqlStatement(Other).Update) - or (BothNonNil(Update, TffSqlStatement(Other).Update) - and Update.Equals(TffSqlStatement(Other).Update)))) - and ((BothNil(Delete, TffSqlStatement(Other).Delete) - or (BothNonNil(Delete, TffSqlStatement(Other).Delete) - and Delete.Equals(TffSqlStatement(Other).Delete)))) - and ((BothNil(TableExp, TffSqlStatement(Other).TableExp) - or (BothNonNil(TableExp, TffSqlStatement(Other).TableExp) - and TableExp.Equals(TffSqlStatement(Other).TableExp)))); -end; -{--------} -{Begin !!.11} -function TffSqlStatement.Execute(var aLiveResult: Boolean; - var aCursorID: TffCursorID; - var RowsAffected, - aRecordsRead: integer) : TffResult; -{End !!.11} -begin - Result := DBIERR_NONE; {!!.11} - StartDate := Date; - StartTime := Time; - StartDateTime := Now; - aCursorID := 0; - RecordsRead := 0; - if assigned(TableExp) then - TableExp.Execute(aLiveResult, aCursorID, RecordsRead) -{Begin !!.11} - else if assigned(Insert) then - Result := Insert.Execute(RowsAffected) - else if assigned(Update) then - Result := Update.Execute(RowsAffected) - else if assigned(Delete) then - Result := Delete.Execute(RowsAffected) - else - raise Exception.Create('Statement is empty'); -{End !!.11} - aRecordsRead := RecordsRead; -end; -{-------} -procedure TffSqlStatement.ReduceStrength; -begin - {$IFDEF LogTransformations} - AssignFile(TRLog, TRLogFile); - {$I-} - Append(TRLog); - if IOResult <> 0 then - Rewrite(TRLog); - writeln(TRLog); - writeln(TRLog, 'Transforming ' + SQLText); - writeln(TRLog, 'started at :',DateTimeToStr(Now)); - {$ENDIF} - - if assigned(TableExp) then begin - while TableExp.Reduce do begin - {$IFDEF LogTransformations} - writeln(TRLog, 'new form:' + SQLText); - {$ENDIF} - end; - end else - {!!.11 begin} - if assigned(Insert) then begin - while Insert.Reduce do begin - {$IFDEF LogTransformations} - writeln(TRLog, 'new form:' + SQLText); - {$ENDIF} - end; - end - else - if assigned(Update) then begin - while Update.Reduce do begin - {$IFDEF LogTransformations} - writeln(TRLog, 'new form:' + SQLText); - {$ENDIF} - end; - end else - if assigned(Delete) then begin - while Delete.Reduce do begin - {$IFDEF LogTransformations} - writeln(TRLog, 'new form:' + SQLText); - {$ENDIF} - end; - end; - {!!.11 end} - - {$IFDEF LogTransformations} - writeln(TRLog); - writeln(TRLog, 'ended at :',DateTimeToStr(Now)); - CloseFile(TRLog); - {$ENDIF} -end; - -procedure TffSqlStatement.SetParameter(Index: Integer; Value: Variant); -begin - if ParmCount = 0 then - raise Exception.Create('Error: Attempt to set parameter on non-parameterized query'); - if ParmList = nil then - ParmList := TFFVariantList.Create(ParmCount); - ParmList.SetValue(Index, Value); -end; - -{====================================================================} - -{===TffSqlSelect=====================================================} -{--------} -procedure TffSqlSELECT.AddTableRefs(Node: TffSqlNode); -begin - Node.AddTableReference(Self); -end; -{--------} -procedure TffSqlSELECT.AddColumns(Node: TffSqlNode); -begin - Node.AddColumnDef(Self); -end; -{--------} -procedure TffSqlSELECT.ClearBindings(Node: TffSqlNode); -begin - Node.ClearBinding; -end; -{--------} -function TffSqlSELECT.Reduce: Boolean; -begin - if SelectionList <> nil then - Result := SelectionList.Reduce - else - Result := False; - Result := Result or TableRefList.Reduce; - if CondExpWhere <> nil then - Result := Result or CondExpWhere.Reduce; - if GroupColumnList <> nil then - Result := Result or GroupColumnList.Reduce; - if CondExpHaving <> nil then - Result := Result or CondExpHaving.Reduce; - if OrderList <> nil then - Result := Result or OrderList.Reduce; -end; -{--------} -procedure TffSqlSELECT.ResetIsConstant(Node: TffSqlNode); -begin - Node.ResetConstant; -end; -{--------} -procedure TffSqlSELECT.EmitSQL(Stream: TStream); -begin - WriteStr(Stream, 'SELECT'); - if Distinct then - WriteStr(Stream, ' DISTINCT') - else - WriteStr(Stream, ' ALL'); - if (SelectionList = nil) or WasStar then - WriteStr(Stream, ' *') - else - SelectionList.EmitSQL(Stream); - WriteStr(Stream, ' FROM'); - TableRefList.EmitSQL(Stream); - if CondExpWhere <> nil then begin - WriteStr(Stream,' WHERE'); - CondExpWhere.EmitSQL(Stream); - end; - if GroupColumnList <> nil then begin - WriteStr(Stream,' GROUP BY'); - GroupColumnList.EmitSQL(Stream); - end; - if CondExpHaving <> nil then begin - WriteStr(Stream,' HAVING'); - CondExpHaving.EmitSQL(Stream); - end; - if OrderList <> nil then - OrderList.EmitSQL(Stream); -end; -{--------} -procedure TffSqlSELECT.AddTableFields(Table : TffSqlTableProxy; - const StartPoint : Integer; - FieldRef : TffSqlFieldRef); -var - Factor : TFFSqlFactor; - j : Integer; - Selection : TFFSqlSelection; - StartVal : Integer; - Term : TFFSqlTerm; -begin - Assert(Table <> nil); - Assert(Table is TffSqlTableProxy); - if Table.FieldCount > 0 then begin - StartVal := Pred(Table.FieldCount); - { If passed a field reference then replace its field name with the - first field of the table. } - if FieldRef <> nil then begin - FieldRef.WasWildcard := True; - FieldRef.FieldName := Table.Field(StartVal).Name; - dec(StartVal); - end; - for j := StartVal downto 0 do begin - Selection := TffSqlSelection.Create(SelectionList); - Selection.SimpleExpression := - TffSqlSimpleExpression.Create(Selection); - Term := TFFSqlTerm.Create(Selection.SimpleExpression); - Factor := TFFSqlFactor.Create(Term); - Factor.FieldRef := TffSqlFieldRef.Create(Factor); - if Table.Alias <> '' then {!!.12} - Factor.FieldRef.TableName := Table.Alias {!!.12} - else {!!.12} - Factor.FieldRef.TableName := Table.Name; - Factor.FieldRef.FieldName := Table.Field(j).Name; - Term.AddFactor(Factor); - Selection.AddedByWildcard := True; - Selection.SimpleExpression.AddTerm(Term); - SelectionList.InsertSelection(StartPoint, Selection); - end; - end; -end; -{--------} -procedure TffSqlSELECT.AddTableFieldsFromList(Table : TffSqlTableProxy; - const StartPoint : Integer; - FieldRef : TffSqlFieldRef; - List: TList); -var - Factor : TFFSqlFactor; - j : Integer; - Selection : TFFSqlSelection; - StartVal : Integer; - Term : TFFSqlTerm; -begin - Assert(Table <> nil); - Assert(Table is TffSqlTableProxy); - if Table.FieldCount > 0 then begin - StartVal := Pred(List.Count); - { If passed a field reference then replace its field name with the - first field of the table. } - if FieldRef <> nil then begin - FieldRef.WasWildcard := True; - FieldRef.FieldName := TffSqlFieldProxy(List[StartVal]).Name; - dec(StartVal); - end; - for j := StartVal downto 0 do begin - Selection := TffSqlSelection.Create(SelectionList); - Selection.SimpleExpression := - TffSqlSimpleExpression.Create(Selection); - Term := TFFSqlTerm.Create(Selection.SimpleExpression); - Factor := TFFSqlFactor.Create(Term); - Factor.FieldRef := TffSqlFieldRef.Create(Factor); - Factor.FieldRef.TableName := Table.Name; - Factor.FieldRef.FieldName := TffSqlFieldProxy(List[j]).Name; - Term.AddFactor(Factor); - Selection.AddedByWildcard := True; - Selection.SimpleExpression.AddTerm(Term); - SelectionList.InsertSelection(StartPoint, Selection); - end; - end; -end; -{--------} -procedure TffSqlSELECT.ExpandWildcards; -var - i, j, ix : Integer; - T : TffSqlTableProxy; - Simp : TFFSqlSimpleExpression; - FR : TffSqlFieldRef; - List: TList; {!!.11} -begin - if SelectionList = nil then begin - { If the selectionlist is empty then only a wildcard was specified. - Note that with the fix of issue 481, this is dead code. } - WasStar := True; - SelectionList := TffSqlSelectionList.Create(Self); - Assert(Assigned(TablesReferencedByOrder)); - for i := Pred(TablesReferencedByOrder.Count) downto 0 do begin - T := TffSqlTableProxy(TablesReferencedByOrder.Objects[i]); - AddTableFields(T, 0, nil); - end; - end else begin - for i := pred(SelectionList.SelectionCount) downto 0 do begin - Simp := SelectionList.Selection[i].SimpleExpression; - if Simp <> nil then begin - FR := Simp.Term[0].Factor[0].FieldRef; - if FR <> nil then begin - if FR.FieldName = '' then begin - Assert(Assigned(TablesReferencedByOrder)); - { If no table name specified then add fields from all tables - referenced in the FROM clause. } - if FR.TableName = '' then begin - Assert(Assigned(TablesReferencedByOrder)); - for j := pred(TablesReferencedByOrder.Count) downto 0 do begin - T := TffSqlTableProxy(TablesReferencedByOrder.Objects[j]); - if j = 0 then - AddTableFields(T, i, FR) - else - AddTableFields(T, i, nil); - end; - end - else begin - { Otherwise the wildcard was qualified with a tablename. } - ix := TablesReferencedByOrder.IndexOf(FR.TableName); - if ix = -1 then begin - Assert(Assigned(TableAliases)); - with TableAliases do begin - ix := IndexOf(FR.TableName); - if ix <> -1 then - ix := Integer(Objects[ix]) - else begin - {!!.11 begin} - {might be part of a nested table expression} - List := TList.Create; - try - T := TableRefList.GetFieldsFromTable(FR.TableName, List); - if T <> nil then begin - AddTableFieldsFromList(T, i, FR, List); - ix := -1; - end else - {!!.11 end} - SQLError('Unknown table: ' + FR.TableName); - finally {!!.11} - List.Free; {!!.11} - end; {!!.11} - end; - end; - end; - if ix <> -1 then begin {!!.11} - T := TffSqlTableProxy(TablesReferencedByOrder.Objects[ix]); - AddTableFields(T, i, FR); - end; {!!.11} - end; - end; - end; - end; - end; - end; -end; -{--------} -procedure TffSqlSELECT.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - if Deep then begin - EnumMethod(Self); - if SelectionList <> nil then - SelectionList.EnumNodes(EnumMethod, Deep); - TableRefList.EnumNodes(EnumMethod, Deep); - if CondExpWhere <> nil then - CondExpWhere.EnumNodes(EnumMethod, Deep); - if GroupColumnList <> nil then - GroupColumnList.EnumNodes(EnumMethod, Deep); - if CondExpHaving <> nil then - CondExpHaving.EnumNodes(EnumMethod, Deep); - if OrderList <> nil then - OrderList.EnumNodes(EnumMethod, Deep); - end; -end; -{--------} -{!!.12 debug code -procedure TffSqlSELECT.CheckTableList; -var - i : Integer; -begin - if TablesReferencedByOrder <> nil then begin - for i := 0 to pred(TablesReferencedByOrder.Count) do - if pos('$$UNNAMED', TablesReferencedByOrder[i]) = 0 then - if assigned(TablesReferencedByOrder.Objects[i]) then - if not (TObject(TablesReferencedByOrder.Objects[i]) is TffSqlTableProxy) then - raise Exception.Create('Table list broken'); - end; -end; -} -procedure TffSqlSELECT.ClearTableList; -var - i : Integer; -begin - {CheckTableList;} {!!.12 debug code} - if TablesReferencedByOrder <> nil then begin - for i := 0 to pred(TablesReferencedByOrder.Count) do - if assigned(TablesReferencedByOrder.Objects[i]) then - if TffSqlTableProxy(TablesReferencedByOrder.Objects[i]).Owner = Self then begin {!!.10} - TffSqlTableProxy(TablesReferencedByOrder.Objects[i]).Owner := nil; {!!.10} - TObject(TablesReferencedByOrder.Objects[i]).Free; - end; {!!.10} - TablesReferencedByOrder.Clear; - end; - if TableAliases <> nil then - TableAliases.Clear; - Bound := False; -end; -{--------} -procedure TffSqlSELECT.Bind; -var - i, j : Integer; - T : TffSqlTableProxy; - Alias: string; {!!.11} -begin - if CondExpWhere <> nil then - CondExpWhere.EnumNodes(ClearBindings, False); - if CondExpHaving <> nil then - CondExpHaving.EnumNodes(ClearBindings, False); - ClearTableList; - TableRefList.EnumNodes(AddTableRefs, False); - Assert(Assigned(TablesReferencedByOrder)); - for i := 0 to pred(TablesReferencedByOrder.Count) do begin - Assert(TablesReferencedByOrder[i] <> ''); - if pos('$$UNNAMED', TablesReferencedByOrder[i]) <> 0 then - Assert(TablesReferencedByOrder.Objects[i] <> nil) - else begin - j := TableAliases.IndexOfObject(TObject(i)); - if j = -1 then - Alias := '' - else - Alias := TableAliases[j]; - T := Owner.FDatabase.TableByName(Self, TablesReferencedByOrder[i], - False, Alias); {!!.11} - if T = nil then - SQLError('Unable to open table: ' + TablesReferencedByOrder[i] + - '. Ensure the table exists and is not in use by ' + - 'another process.'); - TablesReferencedByOrder.Objects[i] := T; - end; - end; - ExpandWildcards; - - if CondExpWhere <> nil then - CondExpWhere.MatchType(fftBoolean); - - {build column list} - Assert(Assigned(Columns)); - Columns.Clear; - SelectionList.EnumNodes(AddColumns, False); - - {figure out if we're using aggregates} - {if we are, we need to prepare for those} - HaveAggregates := False; - - SelectionList.EnumNodes(FlagAggregates, False); - - {!!.11 begin} - if Distinct then begin - {ensure that all fields have a type we can compare} - Assert(Assigned(Columns)); - for i := 0 to pred(Columns.Count) do begin - case TffSqlNode(Columns.Objects[i]).GetType of - fftBoolean..fftDateTime : ; - fftShortString..{fftShortAnsiStr}fftWideString : ; {!!.12} - else - SQLError('Field ' + Columns[i] + ' has a type, which is incompatible with DISTINCT'); - end; - end; - end; - {!!.11 end} - Bound := True; -end; -{--------} -function TffSqlSELECT.BindField(const TableName, - FieldName: string): TFFSqlFieldProxy; -var - T: TFFSqlTableProxy; - j : Integer; -begin - Result := nil; - if TableName <> '' then begin - Assert(Assigned(TablesReferencedByOrder)); - j := TablesReferencedByOrder.IndexOf(TableName); - if (j = -1) - {can't refer to aliased table with its actual name} {!!.12} - or (TffSqlTableProxy(TablesReferencedByOrder.Objects[j]).Alias <> '') {!!.12} - then begin - //may be an alias - Assert(Assigned(TableAliases)); - with TableAliases do begin - j := IndexOf(TableName); - if j <> -1 then begin - j := Integer(Objects[j]); - T := TffSqlTableProxy(TablesReferencedByOrder.Objects[j]); - if T = nil then {!!.11} - SQLError('Invalid field reference:' + TableName + '.' + FieldName); {!!.11} - end else begin - //may be a field from an exclosed expression - if BindingDown then {!!.11} - Result := nil {!!.11} - else - try {!!.11} - BindingDown := True; {!!.11} - Result := TableRefList.BindFieldDown(TableName, FieldName); {!!.11} - finally {!!.11} - BindingDown := False; {!!.11} - end; {!!.11} - if Result = nil then - if IsSubQuery then begin - {may be field at outer level} - Result := Parent.BindField(TableName, FieldName); - IsDependent := True; - exit; - end; - {else - Result := TableRefList.BindFieldDown(TableName, FieldName);} {!!.11} - if Result = nil then - SQLError('Unknown field:' + TableName + '.' + FieldName); - exit; - end; - end; - end else begin - T := TffSqlTableProxy(TablesReferencedByOrder.Objects[j]); - Assert(T <> nil, 'Table not resolved:' - + TffSqlTableProxy(TablesReferencedByOrder.Objects[j]).Name); {!!.11} - end; - Assert(T <> nil); - Result := T.FieldByName(FieldName); - if Result = nil then - SQLError('Unknown field:' + TableName + '.' + FieldName); - end else begin - Assert(Assigned(TablesReferencedByOrder)); - for j := 0 to pred(TablesReferencedByOrder.Count) do begin - T := TffSqlTableProxy(TablesReferencedByOrder.Objects[j]); - Assert(T <> nil); - Assert(T is TffSqlTableProxy); - if T.FieldByName(FieldName) <> nil then begin - Result := T.FieldByName(FieldName); - Exit; - end; - end; - { No binding found yet. See if this is an alias for a field in the - result table. } - if Joiner <> nil then - for j := 0 to Pred(Joiner.FT.Count) do begin - if AnsiCompareText(TFFSqlFieldProxy(Joiner.FT[j]).Name, FieldName) = 0 then begin - Result := Joiner.FT[j]; - Exit; - end; - end; - SQLError('Unknown field:' + FieldName); - end; -end; - -function TffSqlSELECT.BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; -begin - Result := TableRefList.BindTable(AOwner, TableName); -end; - -{--------} -function TffSqlSELECT.FindField(const FieldName: string): TFFSqlFieldProxy; -var - P : Integer; -begin - P := PosCh('.', FieldName); - if P = 0 then - Result := BindField('', FieldName) - else - Result := BindField(copy(FieldName, 1, P - 1), copy(FieldName, P + 1, MaxInt)); -end; -{--------} -procedure TffSqlSELECT.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlSELECT then begin - Clear; - Distinct := TffSqlSELECT(Source).Distinct; - if TffSqlSELECT(Source).SelectionList <> nil then begin - SelectionList := TffSqlSelectionList.Create(Self); - SelectionList.Assign(TffSqlSELECT(Source).SelectionList); - end; - TableRefList := TffSqlTableRefList.Create(Self); - TableRefList.Assign(TffSqlSELECT(Source).TableRefList); - if TffSqlSELECT(Source).CondExpWhere <> nil then begin - CondExpWhere := TffSqlCondExp.Create(Self); - CondExpWhere.Assign(TffSqlSELECT(Source).CondExpWhere); - end; - if TffSqlSELECT(Source).GroupColumnList <> nil then begin - GroupColumnList := TffSqlGroupColumnList.Create(Self); - GroupColumnList.Assign(TffSqlSELECT(Source).GroupColumnList); - end; - if TffSqlSELECT(Source).CondExpHaving <> nil then begin - CondExpHaving := TffSqlCondExp.Create(Self); - CondExpHaving.Assign(TffSqlSELECT(Source).CondExpHaving); - end; - if TffSqlSELECT(Source).OrderList <> nil then begin - OrderList := TffSqlOrderList.Create(Self); - OrderList.Assign(TffSqlSELECT(Source).OrderList); - end; - end else - AssignError(Source); -end; -{--------} -constructor TffSqlSELECT.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); - TablesReferencedByOrder := TStringList.Create; - TableAliases := TStringList.Create; - TableAliases.Sorted := True; - TableAliases.Duplicates := dupError; - AggQueryMode := aqmIdle; -end; -{--------} -procedure TffSqlSELECT.Clear; -begin - ClearTableList; - - FSelectionList.Free; - FSelectionList:= nil; - - FTableRefList.Free; - FTableRefList:= nil; - - FCondExpWhere.Free; - FCondExpWhere:= nil; - - FGroupColumnList.Free; - FGroupColumnList:= nil; - - FCondExpHaving.Free; - FCondExpHaving:= nil; - - FOrderList.Free; - FOrderList:= nil; - -end; -{--------} -function TffSqlSELECT.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - if not Bound then - Bind; - Result := - ((CondExpWhere <> nil) and CondExpWhere.DependsOn(Table)) - or ((CondExpHaving <> nil) and CondExpHaving.DependsOn(Table)); - -end; -{--------} -destructor TffSqlSELECT.Destroy; -begin - if FResultTable <> nil then begin - FResultTable.Owner := nil; - FResultTable.Free; - end; - Clear; - TableAliases.Free; - TablesReferencedByOrder.Free; - Joiner.Free; - inherited; -end; -{--------} -procedure TffSqlSELECT.FlagAggregates(Node: TffSqlNode); -begin - Node.FlagAggregate(Self); -end; -{--------} -procedure TffSqlSELECT.EnumAggregates(Node: TffSqlNode); -begin - Node.AddAggregate(AggList); -end; -{--------} -function TffSqlSELECT.TargetFieldFromSourceField( - const F: TffSqlFieldProxy): TffSqlFieldProxy; -var - i: Integer; -begin - for i := 0 to pred(Columns.Count) do - if Columns.Objects[i] = F then begin - Result := ResultTable.Field(i); - exit; - end; - Result := nil; -end; - -{ TAggCounter } - -function TAggCounter.GetAvg: Variant; -begin - if FCount <> 0 then - Result := FSum / FCount - else - Result := Null; -end; - -function TAggCounter.GetMax: Variant; -begin - if FCount <> 0 then - Result := FMax - else - Result := Null; -end; - -function TAggCounter.GetMin: Variant; -begin - if FCount <> 0 then - Result := FMin - else - Result := Null; -end; - -function TAggCounter.GetSum: Variant; -begin - if FCount <> 0 then - Result := FSum - else - Result := Null; -end; - -procedure TAggCounter.Reset; -begin - FCount := 0; -end; - -const - NumericVarTypes : set of Byte = - [varSmallint, varInteger, varSingle, - {$IFDEF DCC6OrLater} - varShortInt, - {$ENDIF} - varDouble, varCurrency, varByte]; - -procedure TAggCounter.Add(const Value: Variant); -begin - if FCount = 0 then begin - FMin := Value; - FMax := Value; - if (VarType(Value) and VarTypeMask) in NumericVarTypes then - FSum := Value; - end else begin - if Value < FMin then - FMin := Value; - if Value > FMax then - FMax := Value; - if (VarType(Value) and VarTypeMask) in NumericVarTypes then - FSum := FSum + Value; - end; - FCount := FCount + 1; -end; - -procedure TffSqlSELECT.EnsureResultTable(NeedData: Boolean); -begin - Assert(TObject(Self) is TffSqlSELECT); - if IsDependent or (NeedData and not HaveData) then begin - if FResultTable <> nil then begin - Assert(TObject(FResultTable) is TffSqlTableProxy); - Assert(FResultTable.Owner = Self); - FResultTable.Owner := nil; - FResultTable.Free; - FResultTable := nil; - end; - end; - if FResultTable = nil then begin - FResultTable := Execute2(NeedData); - HaveData := NeedData; - end; -end; - -function TffSqlSELECT.CheckForValue(Value: Variant): Boolean; -begin - EnsureResultTable(True); - if VarIsNull(Value) then - Result := False - else begin - ResultTable.SetRange([Value], [Value], 1, 1, True, True, True); - Result := ResultTable.First; - end; -end; - -function TffSqlSELECT.CheckAllValues(RelOp: TffSqlRelOp; - const Val: Variant): Boolean; -var - TestVal: Variant; -begin - EnsureResultTable(True); - Result := False; - if VarIsNull(Val) then exit; - if ResultTable.First then begin - repeat - TestVal := ResultTable.Field(0).GetValue; - if VarIsNull(TestVal) then exit; - case RelOp of - roEQ : - if TestVal <> Val then - exit; - roLE : - if Val > TestVal then - exit; - roL : - if Val >= TestVal then - exit; - roG : - if Val <= TestVal then - exit; - roGE : - if Val < TestVal then - exit; - roNE : - if TestVal = Val then - exit; - end; - until not ResultTable.Next; - Result := True; - end; -end; - -function TffSqlSELECT.CheckAnyValue(RelOp: TffSqlRelOp; - const Val: Variant): Boolean; -begin - EnsureResultTable(True); - Result := True; - if ResultTable.First then - repeat - case RelOp of - roEQ : - if ResultTable.Field(0).GetValue = Val then - exit; - roLE : - if Val <= ResultTable.Field(0).GetValue then - exit; - roL : - if Val < ResultTable.Field(0).GetValue then - exit; - roG : - if Val > ResultTable.Field(0).GetValue then - exit; - roGE : - if Val >= ResultTable.Field(0).GetValue then - exit; - roNE : - if ResultTable.Field(0).GetValue <> Val then - exit; - end; - until not ResultTable.Next; - Result := False; -end; - -function TffSqlSELECT.CheckNonEmpty: Boolean; -begin - EnsureResultTable(True); - Result := FResultTable.First; -end; - -function TffSqlSELECT.GetDecimals: Integer; -begin - if not TypeKnown then begin - EnsureResultTable(False); - FDecimals := FResultTable.Field(0).GetDecimals; - FType := FResultTable.Field(0).GetType; - FSize := FResultTable.Field(0).GetSize; {!!.13} - TypeKnown := True; - end; - Result := FDecimals; -end; - -{!!.13 new} -function TffSqlSELECT.GetSize: Integer; -begin - if not TypeKnown then begin - EnsureResultTable(False); - FDecimals := FResultTable.Field(0).GetDecimals; - FType := FResultTable.Field(0).GetType; - FSize := FResultTable.Field(0).GetSize; - TypeKnown := True; - end; - Result := FSize; -end; - -function TffSqlSELECT.GetType: TffFieldType; -begin - if not TypeKnown then begin - EnsureResultTable(False); - FDecimals := FResultTable.Field(0).GetDecimals; - FType := FResultTable.Field(0).GetType; - FSize := FResultTable.Field(0).GetSize; {!!.13} - TypeKnown := True; - end; - Result := FType; -end; - -function TffSqlSELECT.GetValue: Variant; -begin - EnsureResultTable(True); - if ResultTable.First then - Result := ResultTable.Field(0).GetValue - else - Result := Null; -end; - -procedure TffSqlSELECT.BuildSortList(Table: TffSqlTableProxy; var SortList: TffSqlSortArray); -{-logic extracted from DoOrderBy} -var - i, z, k: Integer; - IX : Integer; - s: string; - FR : TffSqlFieldRef; - AliasName: string; -begin - for i := 0 to pred(OrderList.OrderCount) do begin - if OrderList.OrderItem[i].Column <> nil then begin - s := OrderList.OrderItem[i].Column.QualColumnName; - Assert(Assigned(Columns)); - z := Columns.IndexOf(S); - if z = -1 then begin - z := PosCh('.', S); - if z = 0 then begin - S := '.' + S; - // may be unqualified field but qualified columns - z := -1; - for k := 0 to pred(Columns.Count) do - if posI(S, Columns[k]) <> 0 then begin - z := k; - break; - end; - if z = -1 then begin - SQLError('Unknown column specified in ORDER BY clause: ' + - Copy(S, 2, Length(S) - 1)); - end; - end else begin - // Try to find qualified column - z := -1; - {S := Uppercase(S);} {!!.10} - Assert(Assigned(Columns)); - for k := 0 to pred(Columns.Count) do begin - FR := (Columns.Objects[k] as TffSQLSimpleExpression).Term[0].Factor[0].FieldRef; - if Assigned(FR) and - SameText(S, Trim(FR.SQLText)) then begin - z := k; - break; - end; - end; - if z = -1 then begin - //Table might be aliased. Replace alias with corresponding name. - z := PosCh('.', S); - AliasName := UpperCase(Copy(s, 1, z-1)); - - Assert(Assigned(TableAliases)); - IX := TableAliases.IndexOf(AliasName); - if IX <> -1 then begin - IX := Integer(TableAliases.Objects[IX]); - Assert(Assigned(TablesReferencedByOrder)); - S := TablesReferencedByOrder[IX] + '.' + - UpperCase(Copy(S, Z+1, MaxInt)); - - //Repeat search for field - z := -1; - Assert(Assigned(Columns)); - for k := 0 to Pred(Columns.Count) do begin - FR := (Columns.Objects[K] as TffSQLSimpleExpression).Term[0].Factor[0].FieldRef; - if Assigned(FR) and - SameText(S, Trim(FR.SQLText)) - then begin - z := k; - break; - end; - end; - end else - z := -1; - end; - - if z = -1 then begin - // may be qualified field but unqualified columns - z := PosCh('.', S); - S := copy(S, z + 1, MaxInt); - z := -1; - Assert(Assigned(Columns)); - for k := 0 to pred(Columns.Count) do - if posI(S, Columns[k]) <> 0 then begin - z := k; - break; - end; - if z = -1 then - SQLError('Unknown column specified in ORDER BY clause:'+S); - end; - end; - end; - - Assert(Assigned(Columns)); - SortList[i] := Table.FieldByName(Columns[z]).Index + 1; - end else begin - z := StrToInt(OrderList.OrderItem[i].Index); - SortList[i] := Table.FieldByName(Columns[z - 1]).Index + 1; - end; - if OrderList.OrderItem[i].Descending then - SortList[i] := -SortList[i]; - end; -end; - -procedure TffSqlSELECT.DoOrderBy; -var - SortList: TffSqlSortArray; - Status : TffResult; -begin - if (OrderList <> nil) and NeedData then begin - - BuildSortList(Table, SortList); {!!.11} - - Status := Table.Sort(OrderList.OrderCount, SortList, False); {!!.13} - if Status <> DBIERR_NONE then - raise EffException.CreateNoData(ffStrResServer, Status); - end; -end; - -function TffSqlSELECT.NormalQueryResult(NeedData: Boolean): TffSqlTableProxy; -var - i : Integer; - N : TffSqlNode; - T2 : TffSqlTableProxy; - F : TffSqlFieldProxy; - FieldDefList: TffSqlFieldDefList; -begin - - {build a normal answer table} - - {build field definition for answer table} - FieldDefList := TffSqlFieldDefList.Create; - try - Assert(Assigned(Columns)); - for i := 0 to pred(Columns.Count) do begin - N := TffSqlNode(Columns.Objects[i]); - FieldDefList.AddField(Columns[i], N.GetType, N.GetSize, N.GetDecimals); - end; - - Result := Owner.FDatabase.CreateTemporaryTableWithoutIndex(Self, - FieldDefList); - finally - FieldDefList.Free; - end; - - try - - if Joiner = nil then begin - Joiner := TffSqlJoiner.Create(Owner, CondExpWhere); - - Assert(Assigned(TablesReferencedByOrder)); - for i := 0 to pred(TablesReferencedByOrder.Count) do - Joiner.Sources.Add( - TFFSqlTableProxySubset.Create( - TFFSqlTableProxy(TablesReferencedByOrder.Objects[i]))); - - end; - - Joiner.ClearColumnList; - - Assert(Assigned(Columns)); - for i := 0 to pred(Columns.Count) do begin - if TffSqlSimpleExpression(Columns.Objects[i]).IsField(F) then begin - Joiner.AddColumn( - nil, - F, - Result.Field(i)); - end else begin - Joiner.AddColumn( - TffSqlSimpleExpression(Columns.Objects[i]), - nil, - Result.Field(i)); - end; - end; - - if NeedData then begin - Joiner.Target := Result; - Owner.FDatabase.StartTransaction([nil]); - try - Joiner.Execute(Owner.UseIndex, nil, jmNone); - except - Owner.FDatabase.AbortTransaction; - raise; - end; - Owner.FDatabase.Commit; - end; - - for i := 0 to Result.FieldCount - 1 do - Result.Field(i).IsTarget := False; - - {At this point we have a table with all records that meet the - WHERE criteria.} - - {if DISTINCT was specifed, we now need to remove any duplicates} - - if Distinct and NeedData then begin - T2 := Result.CopyUnique(Self, True); {!!.13} - Result.Owner := nil; - Result.Free; - Result := T2; - end; - - if (Parent is TffSqlInClause) or (Parent is TffSqlMatchClause) then begin - {need an index to allow the IN and MATCH clauses to be evaluated} - - T2 := Result.CopySortedOnAllFields(Self); - - Result.Owner := nil; - Result.Free; - Result := T2; - end else begin - //do ORDER BY - - DoOrderBy(NeedData, Result); - - end; - except - Result.Owner := nil; - Result.Free; - raise; - end; -end; - -function TffSqlSELECT.CheckHaving: Boolean; -begin - Result := CondExpHaving.AsBoolean; -end; - -procedure TffSqlSELECT.DoAggOrderBy; -{-utility method for AggregateQueryResult} -var - i, j, z, k, IX: Integer; - S: string; - FR : TffSQLFieldRef; - AliasName : string; - SortList: TffSqlSortArray; - Status : TffResult; -begin - //do ORDER BY - if OrderList <> nil then begin - - j := pred(OrderList.OrderCount); - for i := 0 to j do begin - if OrderList.OrderItem[i].Column <> nil then begin - s := OrderList.OrderItem[i].Column.QualColumnName; - z := Columns.IndexOf(S); - if z = -1 then begin - z := PosCh('.', S); - if z = 0 then begin - S := '.' + S; - // may be unqualified field but qualified columns - z := -1; - for k := 0 to pred(Columns.Count) do - if posI(S, Columns[k]) <> 0 then begin - z := k; - break; - end; - if z = -1 then begin - SQLError('Unknown column specified in ORDER BY clause: ' + - Copy(S, 2, Length(S) - 1)); - end; - end else begin - // This is a qualified column. Try to find qualified column - z := -1; - for k := 0 to pred(Columns.Count) do begin - FR := (Columns.Objects[k] as TffSQLSimpleExpression). - Term[0].Factor[0].FieldRef; - if Assigned(FR) and (posI(S, FR.SQLText) <> 0) then begin - z := k; - break; - end; - end; - if z = -1 then begin - //Table might be aliased. Replace alias with corresponding table name - z := PosCh('.', S); - AliasName := UpperCase(Copy(s, 1, z-1)); - - Assert(Assigned(TableAliases)); - IX := TableAliases.IndexOf(AliasName); - if IX <> -1 then begin - IX := Integer(TableAliases.Objects[IX]); - Assert(Assigned(TablesReferencedByOrder)); - S := TablesReferencedByOrder[IX] + '.' + - UpperCase(Copy(S, Z+1, MaxInt)); - - //Repeat search for field - z := -1; - for k := 0 to Pred(Columns.Count) do begin - FR := (Columns.Objects[K] as TffSQLSimpleExpression).Term[0].Factor[0].FieldRef; - if Assigned(FR) and (posI(S, FR.SQLText) <> 0) then begin - z := k; - break; - end; - end; - end else - z := -1; - end; - - if z = -1 then begin - // may be qualified field but unqualified columns - Z := PosCh('.', S); - S := copy(S, z + 1, MaxInt); - Z := -1; - for k := 0 to pred(Columns.Count) do - if posI(S, Columns[k]) <> 0 then begin - z := k; - break; - end; - if z = -1 then - SQLError('Unknown column specified in ORDER BY clause:'+S); - end; - end; - end; - - SortList[i] := FGrpTable.Field(z).Index + 1; - end else begin - z := StrToInt(OrderList.OrderItem[i].Index); - SortList[i] := FGrpTable.Field(z - 1).Index + 1; - end; - if OrderList.OrderItem[i].Descending then - SortList[i] := -SortList[i]; - end; - - Status := FGrpTable.Sort(j + 1, SortList, False); {!!.13} - if Status <> DBIERR_NONE then - raise EffException.CreateNoData(ffStrResServer, Status); - end; -end; - -procedure TffSqlSELECT.DoGroupCopy; -var - GroupColumnsOut : Integer; - FieldDefList: TffSqlFieldDefList; - i: Integer; - N : TffSqlNode; - Se : TffSqlSelection; - T2 : TffSqlTableProxy; - - procedure CopyGrouped(const Source, Target: TFFSqlTableProxy; - GroupColumnsIn, GroupColumnsOut, NonGroupColumns: Integer; - const GroupColumnTargetField, - AggExpList: TList); - - var - i : Integer; - IsFirst, HaveGroup, NewGroup : Boolean; - LastValues : TffVariantList; - - procedure WriteGroup; - var - TgtInfo : TffGroupColumnTargetInfo; - i : Integer; - begin - Target.Insert; - for i := 0 to pred(GroupColumnsOut) do begin - TgtInfo := TffGroupColumnTargetInfo(GroupColumnTargetField[i]); - if TgtInfo <> nil then - Target.Field(TgtInfo.SelFldIndex).SetValue - (LastValues.GetValue(TgtInfo.LastValueIndex)); - end; - for i := 0 to pred(NonGroupColumns) do - Target.Field(GroupColumnsOut + i).SetValue( - TffSqlSimpleExpression(AggExpList[i]).GetValue); - for i := 0 to pred(AggList.Count) do - TffSqlAggregate(AggList[i]).ResetCounters; - Target.Post; - end; - - - begin - - Owner.FDatabase.StartTransaction([nil]); - try - IsFirst := True; - HaveGroup := False; - LastValues := TffVariantList.Create(GroupColumnsIn); - {we know that the source table has grouping columns first} - for i := 0 to pred(AggList.Count) do - TffSqlAggregate(AggList[i]).CreateCounter(Source.Field(i + GroupColumnsIn)); - Source.First; - while not Source.EOF do begin - if IsFirst then begin - IsFirst := False; - NewGroup := True; - end else begin - NewGroup := False; - for i := 0 to pred(GroupColumnsIn) do - if Source.Field(i).GetValue <> LastValues.GetValue(i) then begin - NewGroup := True; - break; - end; - end; - if NewGroup then begin - if HaveGroup then begin - Source.Prior; - WriteGroup; - Source.Next; - end; - for i := 0 to pred(GroupColumnsIn) do - LastValues.SetValue(i, Source.Field(i).GetValue); - HaveGroup := True; - end; - - for i := 0 to pred(AggList.Count) do - TffSqlAggregate(AggList[i]).Update; - Source.Next; - end; - {If we happen to have an empty set AND if we don't have grouping - columns, an 'empty' record should be added to hold the - count value of zero as well as null for any aggregates} - if HaveGroup or (GroupColumnsIn = 0) then - WriteGroup; - for i := 0 to pred(AggList.Count) do - with TffSqlAggregate(AggList[i]) do - DeleteCounter; - Owner.FDatabase.Commit; - finally - LastValues.Free; - end; - end; - -begin - {build a normal answer table} - - GroupColumnsOut := 0; - {build field definition for answer table} - FieldDefList := TffSqlFieldDefList.Create; - try - Assert(Assigned(Columns)); - for i := 0 to pred(Columns.Count) do begin - N := TffSqlNode(Columns.Objects[i]); - if i < GroupColumnsIn then {!!.11} - FieldDefList.AddField(Columns[i], - N.GetType, N.GetSize, N.GetDecimals) - else {!!.11} -{Begin !!.12} - { Aggregate fields that reference date, time, & currency fields - should be of the same type in the result set. Other field - types should be changed to fftDouble in order to avoid clipping - of the value. } - case N.GetType of - fftCurrency..fftDateTime: - FieldDefList.AddField(Columns[i], - N.GetType, N.GetSize, N.GetDecimals); - else - FieldDefList.AddField(Columns[i], - fftDouble, 8, N.GetDecimals); - end; -{End !!.12} - Se := SelectionList.Selection[i]; - if (GroupColumnList <> nil) and - GroupColumnList.Contains(Columns[i], Se) then - inc(GroupColumnsOut) - else - AggExpList.Add(N); - end; - - T2 := Owner.FDatabase.CreateTemporaryTableWithoutIndex(Self, FieldDefList); - finally - FieldDefList.Free; - end; - - AggQueryMode := aqmGrouping; - try - CopyGrouped( - FGrpTable, - T2, - GroupColumnsIn, - GroupColumnsOut, - AggExpList.Count, - GroupColumnTargetField, - AggExpList); - finally - AggQueryMode := aqmIdle; - end; - - FGrpTable.Owner := nil; - FGrpTable.Free; - FGrpTable := T2; -end; - -procedure TffSqlSELECT.DoHaving; -var - T2 : TffSqlTableProxy; -begin - if CondExpHaving <> nil then begin - AggQueryMode := aqmHaving; - try - HavingTable := FGrpTable; - CondExpHaving.BindHaving; - CondExpHaving.EnumNodes(ResetIsConstant, False); - T2 := FGrpTable.CopyValidated(Self, CheckHaving); - FGrpTable.Owner := nil; - FGrpTable.Free; - FGrpTable := T2; - finally - AggQueryMode := aqmIdle; - end; - end; -end; - -procedure TffSqlSELECT.DoSortOnAll; -var - T2 : TffSqlTableProxy; -begin - T2 := FGrpTable.CopySortedOnAllFields(Self); - FGrpTable.Owner := nil; {!!.11} - FGrpTable.Free; - FGrpTable := T2; -end; - -procedure TffSqlSELECT.DoRemoveDups(NeedData: Boolean); -var - i: Integer; - LDistinct: Boolean; - T2 : TffSqlTableProxy; -begin - if not Distinct then begin - LDistinct := False; - for i := 0 to pred(AggList.Count) do - if TffSqlAggregate(AggList[i]).Distinct then begin - LDistinct := True; - break; - end; - end else - LDistinct := True; - - if LDistinct and NeedData then begin - T2 := FGrpTable.CopyUnique(Self, True); {!!.13} - FGrpTable.Owner := nil; - FGrpTable.Free; - FGrpTable := T2; - end; -end; - -procedure TffSqlSELECT.DoBuildGroupingTable; -var - FieldDefList: TffSqlFieldDefList; - i: Integer; - Co : TffSqlGroupColumn; - Se : TffSqlSelection; - F : TffSqlFieldProxy; - GrpTgtInfo : TffGroupColumnTargetInfo; - Ag : TffSqlAggregate; - FldType : TffFieldType; -begin - FieldDefList := TffSqlFieldDefList.Create; - try - {build field definition for grouping table} - for i := 0 to pred(GroupColumnsIn) do begin - Co := GroupColumnList.Column[i]; - Se := SelectionList.FindSelection(Co); - if Se <> nil then begin - if Se.SimpleExpression.IsField(F) then begin - FSF.Add(F); - FSX.Add(nil); - end else begin - FSF.Add(nil); - FSX.Add(Se.SimpleExpression); - end; - GrpTgtInfo := TffGroupColumnTargetInfo.Create; - GrpTgtInfo.SelFldIndex := Se.Index; - GrpTgtInfo.LastValueIndex := i; - GroupColumnTargetField.Add(GrpTgtInfo); - FieldDefList.AddField( - Co.QualColumnName, - Se.SimpleExpression.GetType, - Se.SimpleExpression.GetSize, - Se.SimpleExpression.GetDecimals); - - end else begin - {grouping field is not in selection list} - {must be plain field in source table} - F := FindField(Co.QualColumnName); - FSF.Add(F); - FSX.Add(nil); - FieldDefList.AddField( - Co.QualColumnName, - F.GetType, - F.GetSize, - F.GetDecimals); - end; - end; - - SelectionList.EnumNodes(EnumAggregates, False); - - for i := 0 to pred(AggList.Count) do begin - Ag := TffSqlAggregate(AggList[i]); - if Ag.SimpleExpression <> nil then begin - FldType := Ag.SimpleExpression.GetType; - if not Ag.ValidType(FldType) then - raise Exception.CreateFmt('The %s aggregate function requires a numeric field.', - [AgString[Ag.AgFunction]]); - {AVG() needs float field even for integer expressions} - if Ag.AgFunction = agAvg then - FieldDefList.AddField( - Ag.GetTitle(True) + '$' + IntToStr(i), {!!.11} - fftDouble, - 0, - 2) - else - FieldDefList.AddField( - Ag.GetTitle(True) + '$' + IntToStr(i), {!!.11} - FldType, - Ag.SimpleExpression.GetSize, - Ag.SimpleExpression.GetDecimals) - end - else // COUNT(* ) - FieldDefList.AddField( - Ag.GetTitle(True) + '$' + IntToStr(i), {!!.11} - fftDouble, - 0, - 0); - - end; - - FGrpTable := Owner.FDatabase.CreateTemporaryTableWithoutIndex(Self, - FieldDefList); - finally - FieldDefList.Free; - end; -end; - -procedure TffSqlSELECT.DoCheckAggregates; -var - i: Integer; - Se : TffSqlSelection; - F : TffSqlFieldProxy; - LDistinct: Boolean; -begin - LDistinct := False; - { LDistinct is being used to check for situation where a non-aggregate - column is listed after an aggregate column. } - for i := 0 to pred(SelectionList.SelectionCount) do begin - se := SelectionList.Selection[i]; - if se.IsAggregateExpression then - LDistinct := True - else if LDistinct then - SQLError('Non-aggregate column "' + Trim(se.SQLText) + - '" must appear before aggregate columns in the selection list.') - else if se.SimpleExpression.IsField(F) and - ((GroupColumnList = nil) or - (not GroupColumnList.Contains(Columns[i], se))) then - SQLError('Non-aggregate column "' + trim(se.SQLText) + - '" must appear in GROUP BY'); - end; -end; - -{!!.11 new} -function TffSqlSELECT.TableWithCount(const ColumnName: string): TffSqlTableProxy; {!!.12} -var - FieldDefList: TffSqlFieldDefList; -begin - FieldDefList := TffSqlFieldDefList.Create; - try - FieldDefList.AddField(ColumnName, fftDouble, 8, 0); {!!.12} - Result := Owner.FDatabase.CreateTemporaryTableWithoutIndex(Self, FieldDefList); - finally - FieldDefList.Free; - end; - Owner.FDatabase.StartTransaction([nil]); - try - Result.Insert; - Result.Field(0).SetValue(TFFSqlTableProxy(TablesReferencedByOrder.Objects[0]).GetRecordCount); - Result.Post; - Owner.FDatabase.Commit; - except - Owner.FDatabase.AbortTransaction; - raise; - end; -end; - -function TffSqlSELECT.AggregateQueryResult(NeedData: Boolean): TffSqlTableProxy; -var - i : Integer; - T2 : TffSqlTableProxy; - GroupColumnsIn : Integer; - SortList: TffSqlSortArray; - GroupColumnTargetField, - AggExpList, - FSX : TList; - FSF : TList; - j : Integer; - Status : TffResult; - ColumnName: string; {!!.12} -begin - {!!.11 begin} - if (GroupColumnList = nil) - and (CondExpWhere = nil) {!!.12} - and (TablesReferencedByOrder.Count = 1) - and (CondExpHaving = nil) - and (SelectionList.SelectionCount = 1) - and (SelectionList.Selection[0].SimpleExpression <> nil) - and (SelectionList.Selection[0].SimpleExpression.TermCount = 1) - and (SelectionList.Selection[0].SimpleExpression.Term[0].FactorCount = 1) - and (SelectionList.Selection[0].SimpleExpression.Term[0].Factor[0].Aggregate <> nil) - and (SelectionList.Selection[0].SimpleExpression.Term[0].Factor[0].Aggregate.AgFunction = agCount) - and (SelectionList.Selection[0].SimpleExpression.Term[0].Factor[0].Aggregate.SimpleExpression = nil) then begin - {special case, plain "COUNT(*)" - use record count reported by low-level code} - if SelectionList.Selection[0].Column <> nil then {!!.12} - ColumnName := SelectionList.Selection[0].Column.ColumnName {!!.12} - else {!!.12} - ColumnName := 'COUNT(*)'; {!!.12} - Result := TableWithCount(ColumnName); {!!.12} - exit; - end; - {!!.11 end} - - FGrpTable := nil; - T2 := nil; - - {Columns contain the columns that will be in the result table. - However, we may still group on other fields from the selection result - - in particular if this is a sub-query} - - {field list for grouping table creation} - - FSX := nil; - FSF := nil; - GroupColumnTargetField := nil; - AggExpList := nil; - - try - {field lists for joiner - one for expressions, another for fields} - FSX := TList.Create; - FSF := TList.Create; - - {where the groups should appear in the final result} - GroupColumnTargetField := TList.Create; - AggExpList := TList.Create; - - if GroupColumnList = nil then - GroupColumnsIn := 0 - else - GroupColumnsIn := GroupColumnList.ColumnCount; - - {make sure all non-grouped columns are aggregate expressions} - - DoCheckAggregates; - - AggList := TList.Create; - try - DoBuildGroupingTable(GroupColumnsIn, FSF, FSX, - GroupColumnTargetField); - - try - if Joiner = nil then begin - - Joiner := TffSqlJoiner.Create(Owner, CondExpWhere); - - Assert(Assigned(TablesReferencedByOrder)); - for i := 0 to pred(TablesReferencedByOrder.Count) do - Joiner.Sources.Add( - TFFSqlTableProxySubset.Create( - TFFSqlTableProxy(TablesReferencedByOrder.Objects[i]))); - end; - - Joiner.ClearColumnList; - - if GroupColumnList <> nil then begin - for i := 0 to pred(GroupColumnsIn) do begin - Joiner.AddColumn( - FSX[i], - FSF[i], - FGrpTable.Field(i)); - end; - end; - - for i := 0 to pred(AggList.Count) do begin - Joiner.AddColumn( - TffSqlAggregate(AggList[i]).SimpleExpression, - nil, - FGrpTable.Field(i + GroupColumnsIn)); - end; - - if NeedData then begin - Joiner.Target := FGrpTable; - Owner.FDatabase.StartTransaction([nil]); - try - Joiner.Execute(Owner.UseIndex, nil, jmNone); - Owner.FDatabase.Commit; - except - Owner.FDatabase.AbortTransaction; - raise; - end; - end; - - {turn off special aggregation flags so that the table result - may be queried} - for i := 0 to FGrpTable.FieldCount - 1 do - FGrpTable.Field(i).IsTarget := False; - - {At this point we have a table with all records that meet the - WHERE criteria.} - - {if DISTINCT was specifed, we now need to remove any duplicates} - - DoRemoveDups(NeedData); - - if GroupColumnList <> nil then begin - { we need to group FGrpTable } - { First, sort the data on groups } - for i := 0 to pred(GroupColumnsIn) do - SortList[i] := FGrpTable.Field(i).Index + 1; - - Status := FGrpTable.Sort(GroupColumnsIn, SortList, True); {!!.13} - if Status <> DBIERR_NONE then - raise EffException.CreateNoData(ffStrResServer, Status); - - end; - - {we now have the data sorted on the grouping fields} - {we then copy to another table with a slightly different - layout to hold aggregate counters rather than data values - for the non-grouped columns} - - DoGroupCopy(GroupColumnsIn, AggExpList, - GroupColumnTargetField); - - DoHaving; - - if (Parent is TffSqlInClause) or (Parent is TffSqlMatchClause) then begin - {need an index to allow the IN and MATCH clauses to be evaluated} - - DoSortOnAll; - end else - DoAggOrderBy; - except - if FGrpTable <> T2 then - T2.Free; - FGrpTable.Owner := nil; - FGrpTable.Free; - raise; - end; - - finally - AggList.Free; - end; - for j := 0 to Pred(GroupColumnTargetField.Count) do - TffGroupColumnTargetInfo(GroupColumnTargetField[j]).Free; - - finally - GroupColumnTargetField.Free; - FSF.Free; - FSX.Free; - AggExpList.Free; - end; - Result := FGrpTable; -end; -{--------} -function TffSqlSELECT.Execute2(NeedData: Boolean): TffSqlTableProxy; -begin - {check that all referenced tables and fields exist} - if not Bound then - Bind; - - if HaveAggregates or (GroupColumnList <> nil) then begin - Result := AggregateQueryResult(NeedData); - RequestLive := False; - end else begin - Result := NormalQueryResult(NeedData); - RequestLive := False; {!!! for now} - end; -end; -{--------} -procedure TffSqlSELECT.Execute(var aLiveResult: Boolean; - var aCursorID: TffCursorID; var RecordsRead: Integer); -var - T : TffSqlTableProxy; -begin - Assert(Owner <> nil); - RequestLive := aLiveResult; - T := Execute2(True); - aCursorID := T.CursorID; - aLiveResult := RequestLive; - T.LeaveCursorOpen := True; - if T.Owner = Self then begin - T.Owner := nil; - T.Free; - end; -end; -{--------} -function TffSqlSELECT.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlSELECT) - and (Distinct = TffSqlSELECT(Other).Distinct) - and (BothNil(SelectionList, TffSqlSELECT(Other).SelectionList) - or (BothNonNil(SelectionList, TffSqlSELECT(Other).SelectionList) - and SelectionList.Equals(TffSqlSELECT(Other).SelectionList)) - or ( ((SelectionList = nil) and TffSqlSELECT(Other).WasStar) - or (WasStar and (TffSqlSELECT(Other).SelectionList = nil)) ) - ) - and TableRefList.Equals(TffSqlSELECT(Other).TableRefList) - and (BothNil(CondExpWhere, TffSqlSELECT(Other).CondExpWhere) - or (BothNonNil(CondExpWhere, TffSqlSELECT(Other).CondExpWhere) - and CondExpWhere.Equals(TffSqlSELECT(Other).CondExpWhere)) - ) - and (BothNil(GroupColumnList, TffSqlSELECT(Other).GroupColumnList) - or (BothNonNil(GroupColumnList, TffSqlSELECT(Other).GroupColumnList) - and GroupColumnList.Equals(TffSqlSELECT(Other).GroupColumnList)) - ) - and (BothNil(CondExpHaving, TffSqlSELECT(Other).CondExpHaving) - or (BothNonNil(CondExpHaving, TffSqlSELECT(Other).CondExpHaving) - and CondExpHaving.Equals(TffSqlSELECT(Other).CondExpHaving)) - ) - and - (BothNil(OrderList, TffSqlSELECT(Other).OrderList) - or (BothNonNil(OrderList, TffSqlSELECT(Other).OrderList) - and OrderList.Equals(TffSqlSELECT(Other).OrderList))); -end; -{--------} -function TffSqlSELECT.GetResultTable: TFFSqlTableProxy; -begin - EnsureResultTable(True); - Result := FResultTable; -end; - -function TffSqlSELECT.IsSubQuery: Boolean; -var - P: TffSqlNode; -begin - P := Parent; - while P <> nil do begin - if (P is TffSqlSELECT) - or (P is TffSqlUPDATE) - or (P is TffSqlDELETE) - or (P is TffSqlINSERT) then begin - Result := True; - exit; - end; - P := P.Parent; - end; - Result := False; -end; -{--------} -function TffSqlSELECT.Match(Value: Variant; Unique: Boolean; - MatchOption: TffSqlMatchOption): Boolean; - - function RangeIsOne(const Table: TffSqlTableProxy): Boolean; - begin - Result := Table.First and not Table.Next; - end; - -begin - EnsureResultTable(True); - if not Unique then - case MatchOption of - moUnspec : - if VarIsNull(Value) then - Result := True - else begin - ResultTable.SetRange([Value], [Value], 1, 1, True, True, True); - Result := ResultTable.First; - end; - moPartial : - if VarIsNull(Value) then - Result := True - else begin - ResultTable.SetRange([Value], [Value], 1, 1, True, True, True); - Result := ResultTable.First; - end; - else//moFull : - if VarIsNull(Value) then - Result := True - else begin - ResultTable.SetRange([Value], [Value], 1, 1, True, True, True); - Result := ResultTable.First; - end; - end - else - case MatchOption of - moUnspec : - if VarIsNull(Value) then - Result := True - else begin - ResultTable.SetRange([Value], [Value], 1, 1, True, True, True); - Result := RangeIsOne(ResultTable); - end; - moPartial : - if VarIsNull(Value) then - Result := True - else begin - ResultTable.SetRange([Value], [Value], 1, 1, True, True, True); - Result := RangeIsOne(ResultTable); - end; - else//moFull : - if VarIsNull(Value) then - Result := True - else begin - ResultTable.SetRange([Value], [Value], 1, 1, True, True, True); - Result := RangeIsOne(ResultTable); - end; - end; -end; -{--------} -procedure TffSqlSELECT.MatchType(ExpectedType: TffFieldType; AllowMultiple: Boolean); -begin - //this will only be called when the current SELECT statement - //functions as a sub-query - if not AllowMultiple and (SelectionList.SelectionCount <> 1) then - SQLError('Sub-query was expected to have exactly one column'); - EnsureResultTable(False); -end; -{====================================================================} - -{===TffSqlFieldRef===================================================} -procedure TffSqlFieldRef.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlFieldRef then begin - TableName := TffSqlFieldRef(Source).TableName; - FieldName := TffSqlFieldRef(Source).FieldName; - end else - AssignError(Source); -end; - -procedure TffSqlFieldRef.CheckType; -{ Rewritten !!.06} -var - Found : Boolean; - Inx : Integer; - Select : TffSQLSelect; - Selection : TffSQLSelection; -begin - Found := False; - { The field reference may be an alias or a direct reference to a field. } - if (TableName = '') then begin - { See if it is an alias. } - Select := OwnerSelect; - if Select <> nil then begin - for Inx := 0 to Pred(Select.SelectionList.SelectionCount) do begin - Selection := Select.SelectionList.Selection[Inx]; - if (not IsAncestor(Selection)) and - (Selection.Column <> nil) and - (AnsiCompareText(Selection.Column.ColumnName, FieldName) = 0) then begin - FType := Selection.SimpleExpression.GetType; - Found := True; - Break; - end; - end; - end else begin - end; - end; - - { If this isn't an alias then see if it is a direct reference. } - if not Found then begin - Assert(Field <> nil); - FType := Field.GetType; - end; - TypeKnown := True; -end; -{--------} -procedure TffSqlFieldRef.ClearBinding; -begin - FField := nil; -end; -{--------} -function TffSqlFieldRef.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - {!!.12 begin} - if Field.IsTarget then begin - Assert(OwnerSelect <> nil); - if Field.SrcIndex > -1 then - Result := TffSQLSimpleExpression(OwnerSelect.Joiner.FSX[ - Field.SrcIndex]).DependsOn(Table) - else - Result := Field.SrcField.OwnerTable = Table; - end else - {!!.12 end} - Result := Field.OwnerTable = Table; -end; -{--------} -procedure TffSqlFieldRef.EmitSQL(Stream: TStream); -begin - WriteStr(Stream,' '); - if WasWildcard then begin - WriteStr(Stream, TableName); - WriteStr(Stream, '.*'); - end else - WriteStr(Stream, GetTitle(True)); {!!.11} -end; -{--------} -procedure TffSqlFieldRef.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); -end; -{--------} -function TffSqlFieldRef.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlFieldRef) - and (AnsiCompareText(TableName, TffSqlFieldRef(Other).TableName) = 0) - and - ( (AnsiCompareText(FieldName, TffSqlFieldRef(Other).FieldName) = 0) - or (WasWildcard and (TffSqlFieldRef(Other).FieldName = '') - or (((FieldName = '') and TffSqlFieldRef(Other).WasWildcard)))); -end; -{--------} -function TffSqlFieldRef.GetDecimals: Integer; -begin - Result := Field.GetDecimals; -end; -{--------} -function TffSqlFieldRef.GetField: TFFSqlFieldProxy; -begin - if FField = nil then - FField := Parent.BindField(TableName, FieldName); - Result := FField; -end; -{--------} -function TffSqlFieldRef.GetGroupField: TFFSqlFieldProxy; -begin - if OwnerSelect = nil then - SQLError('Field references may not occur in this context'); - if FGroupField = nil then begin - FGroupField := OwnerSelect.FGrpTable.FieldByName(QualName); - if FGroupField = nil then begin - FGroupField := OwnerSelect.FGrpTable.FieldByName(FieldName); - if FGroupField = nil then - SQLError('Unknown field:' + FieldName); - end; - end; - Result := FGroupField; -end; -{--------} -function TffSqlFieldRef.GetSize: Integer; -begin - Result := Field.GetSize; -end; -{--------} -function TffSqlFieldRef.GetTitle(const Qualified : Boolean): string; {!!.11} -begin - if Qualified and (TableName <> '') then {!!.11} - if FieldName <> '' then - Result := TableName + '.' + FieldName - else - Result := TableName + '.*' - else - Result := FieldName; -end; -{--------} -function TffSqlFieldRef.GetType: TffFieldType; -begin - if not TypeKnown then - CheckType; - Result := FType; -end; -{--------} -function TffSqlFieldRef.GetValue: Variant; -begin - if (OwnerSelect <> nil) and - (OwnerSelect.AggQueryMode = aqmGrouping) then - Result := GroupField.GetValue - else if Field.IsTarget then begin - Assert(OwnerSelect <> nil); - if Field.SrcIndex > -1 then - Result := TffSQLSimpleExpression(OwnerSelect.Joiner.FSX[ - Field.SrcIndex]).GetValue - else - Result := Field.SrcField.GetValue; - end else - Result := Field.GetValue; -end; -{--------} -function TffSqlFieldRef.IsNull: Boolean; -begin - if (OwnerSelect <> nil) and - (OwnerSelect.AggQueryMode = aqmGrouping) then - Result := VarIsNull(GroupField.GetValue) - else if Field.IsTarget then begin - Assert(OwnerSelect <> nil); - if Field.SrcIndex > -1 then - Result := TffSQLSimpleExpression(OwnerSelect.Joiner. - FSX[Field.SrcIndex]).IsNull - else - Result := Field.SrcField.IsNull; - end else - Result := Field.IsNull; -end; -{--------} -procedure TffSqlFieldRef.MatchType(ExpectedType: TffFieldType); -begin - if GetType <> ExpectedType then - case GetType of - fftByte..fftCurrency : - case ExpectedType of - fftByte..fftCurrency : - { OK }; - else - TypeMismatch; - end; - fftStDate, - fftStTime, - fftDateTime : - case ExpectedType of - fftStDate..fftDateTime : - { OK }; - else - TypeMismatch; - end; { case } - fftChar, - fftWideChar, - fftShortString..fftWideString : - case ExpectedType of - fftChar, fftWideChar, fftShortString..fftWideString : - { OK }; - else - TypeMismatch; - end; { case } -{Begin !!.13} - fftBLOB..fftBLOBTypedBin : - case ExpectedType of - fftChar, fftWideChar, - fftShortString..fftWideString, - fftBLOB..fftBLOBTypedBin : - { OK }; - else - TypeMismatch; - end; { case } -{End !!.13} - else - TypeMismatch; - end; { case } -end; -{--------} -function TffSQLFieldRef.QualName : string; -var - Name : string; -begin - Result := FFieldName; - { If no tablename specified then obtain table name of source table. } - if FTableName = '' then begin - if assigned(FField) then - Result := FField.OwnerTable.Name + '.' + FFieldName - else - Result := FFieldName; - end - else begin - if OwnerSelect = nil then - SQLError('Field references may not occur in this context'); - { Has a table name. Is it really an alias? } - Name := OwnerSelect.TableRefList.GetNameForAlias(FTableName); - if Name <> '' then - Result := Name + '.' + FFieldName - else - Result := TableName + '.' + FFieldName; - end; -end; -{====================================================================} - -{===TffSqlAggregate==================================================} -{--------} -procedure TffSqlAggregate.AddAggregate(Target: TList); -begin - Target.Add(Self); -end; -{--------} -procedure TffSqlAggregate.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlAggregate then begin - AgFunction := TffSqlAggregate(Source).AgFunction; - SimpleExpression.Free; - SimpleExpression := nil; - if assigned(TffSqlAggregate(Source).SimpleExpression) then begin - SimpleExpression := TffSqlSimpleExpression.Create(Self); - SimpleExpression.Assign(TffSqlAggregate(Source).SimpleExpression); - end; - Distinct := TffSqlAggregate(Source).Distinct; - end else - AssignError(Source); -end; -{--------} -procedure TffSqlAggregate.CreateCounter(SourceField: TFFSqlFieldProxy); -begin - FCounter := TAggCounter.Create; - FSourceField := SourceField; -end; -{--------} -procedure TffSqlAggregate.DeleteCounter; -begin - FCounter.Free; - FCounter := nil; - FSourceField := nil; -end; -{--------} -function TffSqlAggregate.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - Result := SimpleExpression.DependsOn(Table); -end; -{--------} -destructor TffSqlAggregate.Destroy; -begin - SimpleExpression.Free; - inherited; -end; -{--------} -procedure TffSqlAggregate.ResetCounters; -begin - FCounter.Reset; -end; -{--------} -procedure TffSqlAggregate.Update; -begin - case AgFunction of - agCount : - if (FSourceField = nil) or not VarIsNull(FSourceField.GetValue) then {!!.13} - FCounter.Add(1); - else - if not VarIsNull(FSourceField.GetValue) then - FCounter.Add(FSourceField.GetValue); - end; -end; -{--------} -procedure TffSqlAggregate.EmitSQL(Stream: TStream); -begin - WriteStr(Stream,' '); - WriteStr(Stream, AgString[AgFunction]); - WriteStr(Stream,'('); - if SimpleExpression <> nil then begin - if Distinct then - WriteStr(Stream,' DISTINCT') - else - WriteStr(Stream,' ALL'); - SimpleExpression.EmitSQL(Stream); - end else - WriteStr(Stream, '*'); - WriteStr(Stream,')'); -end; -{--------} -procedure TffSqlAggregate.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); - if SimpleExpression <> nil then - SimpleExpression.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlAggregate.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlAggregate) - and (AgFunction = TffSqlAggregate(Other).AgFunction) - and (Distinct = TffSqlAggregate(Other).Distinct) - and ( - BothNil(SimpleExpression, TffSqlAggregate(Other).SimpleExpression) - or ( - BothNonNil(SimpleExpression, TffSqlAggregate(Other).SimpleExpression) - and SimpleExpression.Equals(TffSqlAggregate(Other).SimpleExpression) - ) - ); -end; -{--------} -function TffSqlAggregate.GetAggregateValue: Variant; -begin - if FCounter = nil then - Result := 0 - else begin - case AgFunction of - agCount : - Result := FCounter.Count; - agMin : - Result := FCounter.Min; - agMax : - Result := FCounter.Max; - agSum : - Result := FCounter.Sum; - else //agAvg : - Result := FCounter.Avg; - end; - end; -end; -{--------} -procedure TffSqlAggregate.FlagAggregate(Select: TffSqlSELECT); -begin - Select.HaveAggregates := True; -end; -{--------} -function TffSqlAggregate.GetDecimals: Integer; -begin - case AgFunction of - agCount : - Result := 0; - else - Result := 2; - end; -end; -{--------} -function TffSqlAggregate.GetSize: Integer; -begin - if SimpleExpression <> nil then - Result := SimpleExpression.GetSize - else - Result := 0; -end; -{--------} -function TffSqlAggregate.GetTitle(const Qualified : Boolean): string; {!!.11} -begin - Result := AgString[AgFunction] + '('; - if Distinct then - Result := Result + 'DISTINCT '; - if SimpleExpression = nil then - Result := Result + '*' - else - Result := Result + SimpleExpression.GetTitle(Qualified); {!!.11} - Result := Result + ')'; -end; -{--------} -function TffSqlAggregate.GetType: TffFieldType; -begin - if SimpleExpression = nil then - Result := fftDouble - else - case SimpleExpression.GetType of - fftExtended : - Result := fftExtended; - fftCurrency : - case AgFunction of - agCount : - Result := fftDouble; - else - Result := fftCurrency; - end; - else - case AgFunction of - agCount, - agAvg: - Result := fftDouble; - else - Result := SimpleExpression.GetType; - end; - end; -end; -{--------} -procedure TffSqlAggregate.MatchType(ExpectedType: TffFieldType); -begin - case ExpectedType of - fftByte..fftCurrency : - ; - else - TypeMismatch; - end; -end; -{--------} -function TffSqlAggregate.Reduce: Boolean; -begin - if SimpleExpression <> nil then - Result := SimpleExpression.Reduce - else - Result := False; -end; -{--------} -function TffSqlAggregate.ValidType(aType : TffFieldType) : Boolean; -begin - case agFunction of - agSum, agAvg : - Result := (aType in [fftByte..fftCurrency]); - else - Result := True; - end; -end; -{====================================================================} - -{===TffSqlColumn=====================================================} -procedure TffSqlColumn.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlColumn then begin - ColumnName := TffSqlColumn(Source).ColumnName; - end else - AssignError(Source); -end; - -procedure TffSqlColumn.EmitSQL(Stream: TStream); -begin - WriteStr(Stream,' '); - WriteStr(Stream, ColumnName); -end; -{--------} -procedure TffSqlColumn.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); -end; -{--------} -function TffSqlColumn.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlColumn) - and (AnsiCompareText(ColumnName, TffSqlColumn(Other).ColumnName) = 0); -end; -{====================================================================} - -{===TffSqlIsTest=====================================================} -function TffSqlIsTest.AsBoolean(const TestValue: Variant): Boolean; -begin - case IsOp of - ioNull : - Result := VarIsNull(TestValue) xor UnaryNot; - ioTrue : - if UnaryNot then - Result := not TestValue - else - Result := TestValue; - ioFalse : - if UnaryNot then - Result := TestValue - else - Result := not TestValue; - else - //ioUnknown : - Result := VarIsNull(TestValue) xor UnaryNot; - end; -end; -{--------} -procedure TffSqlIsTest.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlIsTest then begin - UnaryNot := TffSqlIsTest(Source).UnaryNot; - IsOp := TffSqlIsTest(Source).IsOp; - end else - AssignError(Source); -end; - -procedure TffSqlIsTest.EmitSQL(Stream: TStream); -const - IsOpStr : array[TffSqlIsOp] of string = - ('NULL', 'TRUE', 'FALSE', 'UNKNOWN'); -begin - WriteStr(Stream,' IS'); - if UnaryNot then - WriteStr(Stream,' NOT'); - WriteStr(Stream,' '); - WriteStr(Stream, IsOpStr[IsOp]); -end; -{--------} -procedure TffSqlIsTest.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); -end; -{--------} -function TffSqlIsTest.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlIsTest) - and (UnaryNot = TffSqlIsTest(Other).UnaryNot) - and (IsOp = TffSqlIsTest(Other).IsOp); -end; -{--------} -function TffSqlIsTest.Evaluate( - Expression: TffSqlSimpleExpression): Boolean; -{- allow check against NULL for non-variant compatible fields} -begin - case IsOp of - ioNull, ioUnknown : - Result := Expression.IsNull xor UnaryNot; - else - Result := AsBoolean(Expression.GetValue); - end; -end; - -procedure TffSqlIsTest.MatchType(ExpectedType: TffFieldType); -begin -end; - -{====================================================================} - -{===TffSqlBetweenClause==============================================} -function TffSqlBetweenClause.AsBoolean(const TestValue: Variant): Boolean; -begin - if VarIsNull(TestValue) then - Result := False - else - Result := - ( - (TestValue >= SimpleLow.GetValue) - and - (TestValue <= SimpleHigh.GetValue) - ) xor Negated; -end; -{--------} -procedure TffSqlBetweenClause.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlBetweenClause then begin - Negated := TffSqlBetweenClause(Source).Negated; - SimpleLow.Free; - SimpleLow := TffSqlSimpleExpression.Create(Self); - SimpleLow.Assign(TffSqlBetweenClause(Source).SimpleLow); - SimpleHigh.Free; - SimpleHigh := TffSqlSimpleExpression.Create(Self); - SimpleHigh.Assign(TffSqlBetweenClause(Source).SimpleHigh); - end else - AssignError(Source); -end; - -procedure TffSqlBetweenClause.CheckIsConstant; -begin - FIsConstantChecked := True; - FIsConstant := - SimpleLow.IsConstant and SimpleHigh.IsConstant; -end; -{--------} -function TffSqlBetweenClause.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - Result := SimpleLow.DependsOn(Table) or SimpleHigh.DependsOn(Table); -end; - -destructor TffSqlBetweenClause.Destroy; -begin - SimpleLow.Free; - SimpleHigh.Free; - inherited; -end; -{--------} -procedure TffSqlBetweenClause.EmitSQL(Stream: TStream); -begin - if Negated then - WriteStr(Stream,' NOT'); - WriteStr(Stream, ' BETWEEN '); - SimpleLow.EmitSQL(Stream); - WriteStr(Stream,' AND '); - SimpleHigh.EmitSQL(Stream); -end; -{--------} -procedure TffSqlBetweenClause.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); - SimpleLow.EnumNodes(EnumMethod, Deep); - SimpleHigh.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlBetweenClause.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlBetweenClause) - and (Negated = TffSqlBetweenClause(Other).Negated) - and (SimpleLow.Equals(TffSqlBetweenClause(Other).SimpleLow)) - and (SimpleHigh.Equals(TffSqlBetweenClause(Other).SimpleHigh)); -end; -{--------} -function TffSqlBetweenClause.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; -{--------} -procedure TffSqlBetweenClause.MatchType(ExpectedType: TffFieldType); -begin - SimpleLow.MatchType(ExpectedType); - SimpleHigh.MatchType(ExpectedType); -end; -{--------} -function TffSqlBetweenClause.Reduce: Boolean; -begin - Result := SimpleLow.Reduce or SimpleHigh.Reduce; -end; - -procedure TffSqlBetweenClause.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; -{====================================================================} - -{ TffSqlLikePattern } - -constructor TffsqlLikePattern.Create(SearchPattern: string; const Escape: string); -var - i: Integer; - Mask : string; - Esc: Char; -begin - FloatPatterns := TStringList.Create; - FloatMasks := TStringList.Create; - - { - Search pattern is made up of - 0 or 1 lead pattern - 0-N floating patterns, and - 0 or 1 trail pattern. - Patterns are separated by '%'. - If search pattern starts with '%', it does not have a lead pattern. - If search pattern ends with '%', it does not have a trail pattern. - - Place holders, '_', are not considered here but in Find. - - } - - {build a separate mask string for place holders so that we can use - the same logic for escaped and non-escaped search patterns} - - Mask := SearchPattern; - if Escape <> '' then begin - i := length(SearchPattern); - Esc := Escape[1]; - while i >= 2 do begin - if SearchPattern[i - 1] = Esc then begin - Mask[i] := ' '; // blank out the mask character - //remove the escape - Delete(Mask, i - 1, 1); - Delete(SearchPattern, i - 1, 1); - end; - dec(i); - end; - end; - - if (SearchPattern = '') then - exit; - - if Mask[1] <> '%' then begin - {we have a lead pattern} - i := PosCh('%', Mask); - if i = 0 then begin - {entire search pattern is a lead pattern} - LeadPattern := SearchPattern; - LeadMask := Mask; - exit; - end; - - LeadPattern := copy(SearchPattern, 1, i - 1); - LeadMask := copy(Mask, 1, i - 1); - - Delete(SearchPattern, 1, i - 1); - Delete(Mask, 1, i - 1); - end; - - if (SearchPattern = '') then - exit; - - i := length(Mask); - - if Mask[i] <> '%' then begin - {we have a trail pattern} - while (i > 0) and (Mask[i] <> '%') do - dec(i); - if i = 0 then begin - {entire remaining pattern is a trail pattern} - TrailPattern := SearchPattern; - TrailMask := Mask; - exit; - end; - - TrailPattern := copy(SearchPattern, i + 1, MaxInt); - TrailMask := copy(Mask, i + 1, MaxInt); - - Delete(SearchPattern, i + 1, MaxInt); - Delete(Mask, i + 1, MaxInt); - end; - - {we now have one or more floating patterns separated by '%'} - - if Mask = '' then - exit; - - if Mask[1] <> '%' then - exit; - - Delete(Mask, 1, 1); - Delete(SearchPattern, 1, 1); - - repeat - - i := PosCh('%', Mask); - - if i = 0 then begin - {entire remaining search pattern is one pattern} - FloatPatterns.Add(SearchPattern); - FloatMasks.Add(Mask); - exit; - end; - - FloatPatterns.Add(copy(SearchPattern, 1, i - 1)); - FloatMasks.Add(copy(Mask, 1, i - 1)); - - Delete(SearchPattern, 1, i); - Delete(Mask, 1, i); - - until SearchPattern = ''; - -end; - -destructor TffSqlLikePattern.Destroy; -begin - FloatPatterns.Free; - FloatMasks.Free; - inherited; -end; - -{!!.13 new} -function CharsDiffer(IgnoreCase: Boolean; C1, C2: Char): Boolean; -begin - if IgnoreCase then - Result := CharUpper(Pointer(C1)) <> CharUpper(Pointer(C2)) - else - Result := C1 <> C2; -end; - -function Match(const Pattern, Mask : string; - PatternLength : Integer; - const PTextToSearch : PAnsiChar; - const TextLen : Integer; - StartIndex : Integer; - IgnoreCase : Boolean {!!.13} - ): Boolean; -{Modified !!.13} -{ Look for an exact match of the pattern at StartIndex, disregarding - locations with '_' in the mask. - Note: StartIndex is base zero. } -var - i : Integer; -begin - Result := True; - if TextLen < PatternLength then - Result := False - else - for i := 1 to PatternLength do - if (Mask[i] <> '_') and - {(PTextToSearch[StartIndex + i - 1] <> Pattern[i]) then begin} {!!.13} - CharsDiffer(IgnoreCase, PTextToSearch[StartIndex + i - 1], Pattern[i]) then begin {!!.13} - Result := False; - Break; - end; { if } -end; - -function Scan(const Pattern, Mask : string; - PatternLength : Integer; - const PTextToSearch : PAnsiChar; - const TextLen : Integer; - StartIndex: Integer; - IgnoreCase: Boolean {!!.13} - ) : Integer; -{Modified !!.13} -{ Scan for a match of the pattern starting at StartIndex, disregarding - locations with '_' in the mask. Return -1 if not found, otherwise - return the position immediately following the matched phrase. } -var - L, i : Integer; - Found : Boolean; -begin - L := TextLen - StartIndex; - repeat - if L < PatternLength then begin - Result := -1; - Exit; - end; - Found := True; - for i := 1 to PatternLength do - if (i - 1 > L) or (Mask[i] <> '_') and - {(PTextToSearch[i + StartIndex - 1] <> Pattern[i]) then begin} {!!.13} - CharsDiffer(IgnoreCase, PTextToSearch[i + StartIndex - 1], Pattern[i]) then begin {!!.13} - Found := False; - Break; - end; - if Found then begin - Result := StartIndex + PatternLength; - Exit; - end; - inc(StartIndex); - dec(L); - until False; -end; - -function TffSqlLikePattern.Find(const TextToSearch: Variant; - IgnoreCase: Boolean {!!.13} - ): Boolean; -{Rewritten !!.13} -{Search the TextToSearch. Return true if the search pattern was found} -var - TextLen, - LeadLen, - TrailLen, - i, - l, - StartPos, - EndPos: Integer; - VStr, P : string; - VPtr : PAnsiChar; -begin - Result := False; - try - if TVarData(TextToSearch).VType and VarTypeMask = varByte then begin - TextLen := VarArrayHighBound(TextToSearch, 1); - if TextLen = 0 then - Exit; - VStr := ''; - VPtr := VarArrayLock(TextToSearch); - end - else begin - TextLen := Length(TextToSearch); - if TextLen = 0 then - Exit; - VStr := VarToStr(TextToSearch); - VPtr := PAnsiChar(VStr); - end; - - LeadLen := Length(LeadPattern); - TrailLen := Length(TrailPattern); - if LeadLen > 0 then begin - { If there is a lead pattern then see if there is a match. } - if not Match(LeadPattern, LeadMask, LeadLen, VPtr, TextLen, 0, - IgnoreCase) then begin {!!.13} - { No match so exit. } - Result := False; - Exit; - end; - { There was a match so set the starting position for the next match. } - StartPos := LeadLen; - end else - { No lead pattern. Next match starts at beginning of string. } - StartPos := 0; - - if TrailLen > 0 then begin - { There is a trail pattern. Does it overlap with the lead pattern? } - i := TextLen - TrailLen; - if i < StartPos then begin - { Yes it overlaps. A match is not possible so exit. } - Result := False; - Exit; - end; - if not Match(TrailPattern, TrailMask, TrailLen, VPtr, TextLen, i, - IgnoreCase) then begin {!!.13} - Result := False; - Exit; - end; - EndPos := i - 1; - end else - EndPos := TextLen - 1; - - if FloatPatterns.Count = 0 then - if TextLen <> LeadLen + TrailLen then begin - Result := False; - Exit; - end; - - for i := 0 to pred(FloatPatterns.Count) do begin - P := FloatPatterns[i]; - l := Length(P); - { If the length of the float pattern is greater than the number of - characters left in the string then a match is not possible. } - if l > EndPos - StartPos + 1 then begin - Result := False; - Exit; - end; - StartPos := Scan(P, FloatMasks[i], l, VPtr, TextLen, StartPos, IgnoreCase); {!!.13} - if StartPos = -1 then begin - Result := False; - Exit; - end; - end; - Result := True; - finally - if VStr = '' then - VarArrayUnlock(TextToSearch); - end; -end; -{===TffSqlLikeClause=================================================} -function TffSqlLikeClause.AsBoolean(const TestValue: Variant): Boolean; -begin - if VarIsNull(TestValue) then begin - Result := Negated; - exit; - end; - if LikePattern = nil then - if EscapeExp <> nil then - LikePattern := TffSqlLikePattern.Create(SimpleExp.GetValue, EscapeExp.GetValue) - else - LikePattern := TffSqlLikePattern.Create(SimpleExp.GetValue, ''); - Result := LikePattern.Find(TestValue, IgnoreCase) xor Negated; {!!.13} - if not IsConstant then begin - LikePattern.Free; - LikePattern := nil; - end; -end; -{--------} -procedure TffSqlLikeClause.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlLikeClause then begin - if SimpleExp = nil then - SimpleExp := TffSqlSimpleExpression.Create(Self); - SimpleExp.Assign(TffSqlLikeClause(Source).SimpleExp); - if (EscapeExp = nil) and (TffSqlLikeClause(Source).EscapeExp <> nil) then begin - EscapeExp := TffSqlSimpleExpression.Create(Self); - EscapeExp.Assign(TffSqlLikeClause(Source).EscapeExp); - end; - Negated := TffSqlLikeClause(Source).Negated; - end else - AssignError(Source); -end; - -function TffSqlLikeClause.CanLimit: Boolean; -var - S: string; -begin - Result := False; - if not Limited - and not IgnoreCase {!!.13} - and SimpleExp.IsConstant - and ((EscapeExp = nil) {or EscapeExp.IsConstant}) then begin {!!.11} - S := SimpleExp.GetValue; - if not (S[1] in ['%', '_']) then - Result := (GetHighLimit <> ''); - end; -end; - -function TffSqlLikeClause.CanReplaceWithCompare: Boolean; -var - S: string; -begin - Result := False; - if not Limited - and not IgnoreCase {!!.13} - and SimpleExp.IsConstant - and ((EscapeExp = nil) {or EscapeExp.IsConstant}) then begin {!!.11} - S := SimpleExp.GetValue; - Result := (PosCh('_', S) = 0) - and (length(S) > 1) - and (PosCh('%', S) = length(S)); - end; -end; - -procedure TffSqlLikeClause.CheckIsConstant; -begin - FIsConstantChecked := True; - FIsConstant := SimpleExp.IsConstant and ((EscapeExp = nil) or EscapeExp.IsConstant); -end; -{--------} -function TffSqlLikeClause.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - Result := SimpleExp.DependsOn(Table); -end; - -destructor TffSqlLikeClause.Destroy; -begin - SimpleExp.Free; - EscapeExp.Free; - LikePattern.Free; - if FBmTable <> nil then {!!.11} - Dispose(FBmTable); {!!.11} - inherited; -end; -{--------} -procedure TffSqlLikeClause.EmitSQL(Stream: TStream); -begin - if Negated then - WriteStr(Stream,' NOT'); - WriteStr(Stream, ' LIKE '); - SimpleExp.EmitSQL(Stream); - if EscapeExp <> nil then begin - WriteStr(Stream,' ESCAPE'); - EscapeExp.EmitSQL(Stream); - end; -end; -{--------} -procedure TffSqlLikeClause.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - SimpleExp.EnumNodes(EnumMethod, Deep); - if EscapeExp <> nil then - EscapeExp.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlLikeClause.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlLikeClause) - and (Negated = TffSqlLikeClause(Other).Negated) - and (SimpleExp.Equals(TffSqlLikeClause(Other).SimpleExp)) - and (BothNil(EscapeExp, TffSqlLikeClause(Other).EscapeExp) - or (BothNonNil(EscapeExp, TffSqlLikeClause(Other).EscapeExp) - and EscapeExp.Equals(TffSqlLikeClause(Other).EscapeExp))); -end; -{--------} - -{!!.11 new} -function TffSqlLikeClause.GetBmTable: PBTable; -var - S: string; -begin - if FBmTable = nil then begin - Assert(IsBMCompatible); - if IgnoreCase then {!!.13} - S := AnsiUpperCase(SimpleExp.GetValue) {!!.13} - else {!!.13} - S := SimpleExp.GetValue; - New(FBmTable); - FBMPhrase := copy(S, 2, length(S) - 2); - BMMakeTableS(FBmPhrase, FBmTable^); - end; - Result := FBmTable; -end; - -function TffSqlLikeClause.GetHighLimit: string; -var - i: Integer; -begin - Result := GetLowLimit; - i := length(Result); - if Result[i] in [' '..'~'] then - inc(Result[i]) - else - Result := ''; -end; - -function TffSqlLikeClause.GetLowLimit: string; -var - P : Integer; -begin - Result := SimpleExp.GetValue; - P := 1; - while (P <= length(Result)) - and not (Result[P] in ['%', '_']) do - inc(P); - dec(P); - if P < length(Result) then - Result := copy(Result, 1 , P); -end; - -{!!.11 new} -procedure TffSqlLikeClause.CheckBMCompat; -var - S: string; - Len, - Inx : Integer; -begin - FBMCompat := False; - if SimpleExp.IsConstant and (EscapeExp = nil) then begin - S := SimpleExp.GetValue; - Len := Length(S); - FBMCompat := (Len >= 3) and - (S[1] = '%') and - (S[Len] = '%'); - { Verify there is not another wildcard character in the middle of the - string. } - for Inx := 2 to Pred(Len) do - if S[Inx] = '%' then begin - FBMCompat := False; - Break; - end; - end; - BMCompatChecked := True; -end; - -{!!.11 new} -function TffSqlLikeClause.IsBMCompatible: Boolean; -begin - if not BMCompatChecked then - CheckBMCompat; - Result := FBMCompat; -end; - -function TffSqlLikeClause.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; -{--------} -procedure TffSqlLikeClause.MatchType(ExpectedType: TffFieldType); -begin - case ExpectedType of - fftChar, fftWideChar, - fftShortString..fftWideString : - SimpleExp.MatchType(ExpectedType); - fftBLOB..fftBLOBTypedBin : {!!.11} - SimpleExp.MatchType(fftNullAnsiStr); {!!.11} - else - SQLError(Format('The LIKE operator may not be applied to %s fields', {!!.11} - [FieldDataTypes[ExpectedType]])); {!!.11} - end; -end; -{--------} -function TffSqlLikeClause.Reduce: Boolean; -begin - Result := SimpleExp.Reduce or ((EscapeExp <> nil) and EscapeExp.Reduce); -end; - -procedure TffSqlLikeClause.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; -{====================================================================} - -{===TffSqlInClause===================================================} -function TffSqlInClause.AsBoolean(const TestValue: Variant): Boolean; -begin - if SubQuery <> nil then - Result := SubQuery.CheckForValue(TestValue) - else - Result := SimpleExpList.Contains(TestValue); - Result := Result xor Negated; -end; -{--------} -procedure TffSqlInClause.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlInClause then begin - SimpleExpList.Free; - SimpleExpList := nil; {!!.12} - SubQuery.Free; - SubQuery := nil; {!!.12} - if TffSqlInClause(Source).SubQuery <> nil then begin - SubQuery := TffSqlSELECT.Create(Self); - SubQuery.Assign(TffSqlInClause(Source).SubQuery); - end else begin - SimpleExpList := TffSqlSimpleExpressionList.Create(Self); - SimpleExpList.Assign(TffSqlInClause(Source).SimpleExpList); - end; - Negated := TffSqlInClause(Source).Negated; - end else - AssignError(Source); -end; - -procedure TffSqlInClause.CheckIsConstant; -begin - FIsConstantChecked := True; - if SubQuery <> nil then - FIsConstant := False - else - FIsConstant := SimpleExpList.IsConstant; -end; -{--------} -function TffSqlInClause.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - if SubQuery <> nil then - Result := SubQuery.DependsOn(Table) - else - Result := SimpleExpList.DependsOn(Table); -end; - -destructor TffSqlInClause.Destroy; -begin - SubQuery.Free; - SimpleExpList.Free; - inherited; -end; -{--------} -procedure TffSqlInClause.EmitSQL(Stream: TStream); -begin - if Negated then - WriteStr(Stream,' NOT'); - WriteStr(Stream, ' IN ('); - if SubQuery <> nil then - SubQuery.EmitSQL(Stream) - else - SimpleExpList.EmitSQL(Stream); - WriteStr(Stream, ') '); -end; -{--------} -procedure TffSqlInClause.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - if SubQuery <> nil then - SubQuery.EnumNodes(EnumMethod, Deep) - else - SimpleExpList.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlInClause.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlInClause) - and (Negated = TffSqlInClause(Other).Negated); - if Result then - if SubQuery <> nil then - if TffSqlInClause(Other).SubQuery = nil then - Result := False - else - Result := SubQuery.Equals(TffSqlInClause(Other).SubQuery) - else - if TffSqlInClause(Other).SimpleExpList = nil then - Result := False - else - Result := SimpleExpList.Equals(TffSqlInClause(Other).SimpleExpList); -end; -{--------} -function TffSqlInClause.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; - -procedure TffSqlInClause.MatchType(ExpectedType: TffFieldType); -begin - if SubQuery <> nil then - SubQuery.MatchType(ExpectedType, True) - else - SimpleExpList.MatchType(ExpectedType); -end; -{--------} -function TffSqlInClause.Reduce: Boolean; -begin - if SubQuery <> nil then - Result := SubQuery.Reduce - else - Result := SimpleExpList.Reduce; -end; - -procedure TffSqlInClause.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; -{====================================================================} - -function SimpleCompare(RelOp: TffSqlRelOp; const Val1, Val2: Variant): Boolean; -const - ValIsBLOBArray : array[boolean, boolean] of Byte = - ( (1, { false, false } - 2), { false, true } - (3, { true, false } - 4) { true, true } - ); -var - VStr : string; - VPtr1, VPtr2 : PAnsiChar; - Inx, VPtr1Len, VPtr2Len : Integer; - VPtr1Locked, VPtr2Locked : Boolean; - ValIsBLOBCase : Byte; -begin - if VarIsNull(Val1) or - VarIsNull(Val2) then begin - Result := False; - Exit; - end; - Assert(RelOp <> roNone); - - ValIsBLOBCase := ValIsBLOBArray[VarIsArray(Val1) and - (TVarData(Val1).VType and VarTypeMask = varByte), - VarIsArray(Val2) and - (TVarData(Val2).VType and VarTypeMask = varByte)]; - if ValIsBLOBCase = 1 then - case RelOp of - roEQ : - if (VarType(Val1) and VarTypeMask = VarDate) - and (VarType(Val2) and VarTypeMask = VarDate) then - Result := abs(double(Val1) - double(Val2)) < TimeDelta - else - Result := Val1 = Val2; - roLE : - Result := Val1 <= Val2; - roL : - Result := Val1 < Val2; - roG : - Result := Val1 > Val2; - roGE : - Result := Val1 >= Val2; - else//roNE : - if (VarType(Val1) and VarTypeMask = VarDate) - and (VarType(Val2) and VarTypeMask = VarDate) then - Result := abs(double(Val1) - double(Val2)) >= TimeDelta - else - Result := Val1 <> Val2; - end { case } - else begin - { One of the parameters is a BLOB. It must be converted to a string. - This code is kind of flaky in that it is a duplicate of the preceding - section. However, this approach should give us optimal performance for - cases where neither parameter is a BLOB. } - VPtr1 := nil; - VPtr2 := nil; - VPtr1Locked := False; - VPtr2Locked := False; - try - case ValIsBLOBCase of - 2 : begin - VStr := VarToStr(Val1); - VPtr1 := PAnsiChar(VStr); - VPtr1Len := Length(VStr); - VPtr2 := VarArrayLock(Val2); - VPtr2Locked := True; - VPtr2Len := VarArrayHighBound(Val2, 1); - end; - 3 : begin - VPtr1 := VarArrayLock(Val1); - VPtr1Locked := True; - VPtr1Len := VarArrayHighBound(Val1, 1); - VStr := VarToStr(Val2); - VPtr2 := PAnsiChar(VStr); - VPtr2Len := Length(VStr); - end; - 4 : begin - VPtr1 := VarArrayLock(Val1); - VPtr1Locked := True; - VPtr1Len := VarArrayHighBound(Val1, 1); - VPtr2 := VarArrayLock(Val2); - VPtr2Locked := True; - VPtr2Len := VarArrayHighBound(Val2, 1); - end; - else begin - VPtr1Len := 0; - VPtr2Len := 0; - end; - end; { case } - Inx := Windows.CompareStringA(LOCALE_USER_DEFAULT, 0, - VPtr1, VPtr1Len, VPtr2, VPtr2Len) - 2; - case RelOp of - roEQ : Result := (Inx = 0); - roLE : Result := (Inx <= 0); - roL : Result := (Inx < 0); - roG : Result := (Inx > 0); - roGE : Result := (Inx >= 0); - else - { roNE } - Result := (Inx <> 0); - end; { case } - finally - if VPtr1Locked then - VarArrayUnlock(Val1); - if VPtr2Locked then - VarArrayUnlock(Val2); - end; - end; { if..else } -end; - -{===TffSqlCondPrimary================================================} -function TffSqlCondPrimary.AsBoolean: Boolean; -var - F: TffSqlFieldProxy; {!!.11} - BMTable: PBTable; {!!.13} -begin - Result := False; - if IsConstant then begin - Result := ConstantValue; - exit; - end; - if not TypeChecked then - CheckType; - - if RelOp = roNone then - if BetweenClause <> nil then - Result := BetweenClause.AsBoolean(SimpleExp1.GetValue) - else - if LikeClause <> nil then - if SimpleExp1.IsField(F) and LikeClause.IsBMCompatible then begin {!!.11}{!!.13} - {Need to call BMTable before method call - otherwise BMPhrase doesn't get initialized in time} - BMTable := LikeClause.BMTable; - Result := F.BMMatch(BMTable^, LikeClause.BMPhrase, LikeClause.IgnoreCase) {!!.11}{!!.13} - end else {!!.11}{!!.13} - Result := LikeClause.AsBoolean(SimpleExp1.GetValue) - else - if InClause <> nil then - Result := InClause.AsBoolean(SimpleExp1.GetValue) - else - if IsTest <> nil then - Result := IsTest.Evaluate(SimpleExp1) - else - if ExistsClause <> nil then - Result := ExistsClause.AsBoolean - else - if UniqueClause <> nil then - Result := UniqueClause.AsBoolean - else - if MatchClause <> nil then - Result := MatchClause.AsBoolean(SimpleExp1.GetValue) - else - Result := SimpleExp1.GetValue - else - if SimpleExp2 <> nil then - Result := SimpleCompare(RelOp, SimpleExp1.GetValue, SimpleExp2.GetValue) - else - if AllOrAnyClause <> nil then - Result := AllOrAnyClause.Compare(RelOp, SimpleExp1.GetValue) - else - SQLError('Simple expression or ANY/ALL clause expected'); -end; -{--------} -procedure TffSqlCondPrimary.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlCondPrimary then begin - - Clear; - - if assigned(TffSqlCondPrimary(Source).SimpleExp1) then begin - SimpleExp1 := TffSqlSimpleExpression.Create(Self); - SimpleExp1.Assign(TffSqlCondPrimary(Source).SimpleExp1); - end; - - RelOp := TffSqlCondPrimary(Source).RelOp; - - if assigned(TffSqlCondPrimary(Source).SimpleExp2) then begin - SimpleExp2 := TffSqlSimpleExpression.Create(Self); - SimpleExp2.Assign(TffSqlCondPrimary(Source).SimpleExp2); - end; - - if assigned(TffSqlCondPrimary(Source).BetweenClause) then begin - BetweenClause := TffSqlBetweenClause.Create(Self); - BetweenClause.Assign(TffSqlCondPrimary(Source).BetweenClause); - end; - - if assigned(TffSqlCondPrimary(Source).LikeClause) then begin - LikeClause := TffSqlLikeClause.Create(Self); - LikeClause.Assign(TffSqlCondPrimary(Source).LikeClause); - end; - - if assigned(TffSqlCondPrimary(Source).InClause) then begin - InClause := TffSqlInClause.Create(Self); - InClause.Assign(TffSqlCondPrimary(Source).InClause); - end; - - if assigned(TffSqlCondPrimary(Source).IsTest) then begin - IsTest := TffSqlIsTest.Create(Self); - IsTest.Assign(TffSqlCondPrimary(Source).IsTest); - end; - - if assigned(TffSqlCondPrimary(Source).AllOrAnyClause) then begin - AllOrAnyClause := TffSqlAllOrAnyClause.Create(Self); - AllOrAnyClause.Assign(TffSqlCondPrimary(Source).AllOrAnyClause); - end; - - if assigned(TffSqlCondPrimary(Source).ExistsClause) then begin - ExistsClause := TffSqlExistsClause.Create(Self); - ExistsClause.Assign(TffSqlCondPrimary(Source).ExistsClause); - end; - - if assigned(TffSqlCondPrimary(Source).UniqueClause) then begin - UniqueClause := TffSqlUniqueClause.Create(Self); - UniqueClause.Assign(TffSqlCondPrimary(Source).UniqueClause); - end; - - if assigned(TffSqlCondPrimary(Source).MatchClause) then begin - MatchClause := TffSqlMatchClause.Create(Self); - MatchClause.Assign(TffSqlCondPrimary(Source).MatchClause); - end; - - end else - AssignError(Source); -end; -{--------} -procedure TffSqlCondPrimary.BindHaving; -begin - if SimpleExp1 <> nil then - SimpleExp1.BindHaving; - case RelOp of - roNone : - if BetweenClause <> nil then - SQLError('BETWEEN not supported in a HAVING clause') - else - if LikeClause <> nil then - SQLError('LIKE not supported in a HAVING clause') - else - if InClause <> nil then - SQLError('IN not supported in a HAVING clause') - else - {if IsTest <> nil then - SQLError('IS not supported in a HAVING clause') - else} {!!.11} - if ExistsClause <> nil then - SQLError('EXISTS not supported in a HAVING clause') - else - if UniqueClause <> nil then - SQLError('UNIQUE not supported in a HAVING clause') - else - if MatchClause <> nil then - SQLError('MATCH not supported in a HAVING clause'); - else - if AllOrAnyClause <> nil then - //SQLError('ANY or ALL conditions not supported in a HAVING clause') - else begin - Assert(SimpleExp2 <> nil); - SimpleExp2.BindHaving; - end; - end; -end; - -procedure TffSqlCondPrimary.CheckIsConstant; -begin - FIsConstantChecked := True; - FIsConstant := False; - if SimpleExp1 <> nil then - if not SimpleExp1.IsConstant then - exit; - case RelOp of - roNone : - if BetweenClause <> nil then - if not BetweenClause.IsConstant then - exit - else - else - if LikeClause <> nil then - if not LikeClause.IsConstant then - exit - else - else - if InClause <> nil then - if not InClause.IsConstant then - exit - else - else - if IsTest <> nil then - // constant by definition - else - if ExistsClause <> nil then - exit - else - if UniqueClause <> nil then - exit - else - if MatchClause <> nil then - exit; - else - if AllOrAnyClause <> nil then - exit - else begin - Assert(SimpleExp2 <> nil); - if not SimpleExp2.IsConstant then - exit; - end; - end; - ConstantValue := GetValue; - FIsConstant := True; -end; - -procedure TffSqlCondPrimary.CheckType; -var - T1 : TffFieldType; -begin - if SimpleExp1 <> nil then - T1 := SimpleExp1.GetType - else - T1 := fftBLOB; {anything that doesn't match a valid SQL type} - case RelOp of - roNone : - if BetweenClause <> nil then - BetweenClause.MatchType(T1) - else - if LikeClause <> nil then - LikeClause.MatchType(T1) - else - if InClause <> nil then - InClause.MatchType(T1) - else - if IsTest <> nil then - IsTest.MatchType(T1) - else - if ExistsClause <> nil then - //T1 := ExistsClause.GetType - else - if UniqueClause <> nil then - //T1 := UniqueClause.GetType - else - if MatchClause <> nil then - MatchClause.MatchType(T1); - //else - // if T1 <> fftBoolean then - // TypeMismatch; - else - if AllOrAnyClause <> nil then - AllOrAnyClause.MatchType(T1) - else begin - Assert(SimpleExp2 <> nil); - SimpleExp2.MatchType(T1); - end; - end; - TypeChecked := True; -end; -{--------} -procedure TffSqlCondPrimary.Clear; -begin - SimpleExp1.Free; - SimpleExp1 := nil; - BetweenClause.Free; - BetweenClause := nil; - LikeClause.Free; - LikeClause := nil; - InClause.Free; - InClause := nil; - IsTest.Free; - IsTest := nil; - ExistsClause.Free; - ExistsClause := nil; - UniqueClause.Free; - UniqueClause := nil; - MatchClause.Free; - MatchClause := nil; - AllOrAnyClause.Free; - AllOrAnyClause := nil; - SimpleExp2.Free; - SimpleExp2 := nil; - inherited; -end; -{--------} -function TffSqlCondPrimary.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - Result := False; - case RelOp of - roNone : - if BetweenClause <> nil then - Result := SimpleExp1.DependsOn(Table) or BetweenClause.DependsOn(Table) - else - if LikeClause <> nil then - Result := SimpleExp1.DependsOn(Table) or LikeClause.DependsOn(Table) - else - if InClause <> nil then - Result := SimpleExp1.DependsOn(Table) or InClause.DependsOn(Table) - else - if IsTest <> nil then - Result := SimpleExp1.DependsOn(Table) - else - if ExistsClause <> nil then - Result := ExistsClause.DependsOn(Table) - else - if UniqueClause <> nil then - Result := UniqueClause.DependsOn(Table) - else - if MatchClause <> nil then - Result := SimpleExp1.DependsOn(Table) or MatchClause.DependsOn(Table) - else - Result := SimpleExp1.DependsOn(Table); - else //roEQ, roLE, roL, roG, roGE, roNE : - if SimpleExp2 <> nil then - Result := SimpleExp1.DependsOn(Table) or SimpleExp2.DependsOn(Table) - else - if AllOrAnyClause <> nil then - Result := SimpleExp1.DependsOn(Table) or AllOrAnyClause.DependsOn(Table) - else - SQLError('Simple expression or ANY/ALL clause expected'); - end; - if AllOrAnyClause <> nil then - Result := Result or AllOrAnyClause.DependsOn(Table); -end; - -destructor TffSqlCondPrimary.Destroy; -begin - Clear; - inherited; -end; - -procedure TffSqlCondPrimary.EmitSQL(Stream: TStream); -begin - if SimpleExp1 <> nil then - SimpleExp1.EmitSQL(Stream); - case RelOp of - roNone : - if BetweenClause <> nil then - BetweenClause.EmitSQL(Stream) - else - if LikeClause <> nil then - LikeClause.EmitSQL(Stream) - else - if InClause <> nil then - InClause.EmitSQL(Stream) - else - if IsTest <> nil then - IsTest.EmitSQL(Stream) - else - if ExistsClause <> nil then - ExistsClause.EmitSQL(Stream) - else - if UniqueClause <> nil then - UniqueClause.EmitSQL(Stream) - else - if MatchClause <> nil then - MatchClause.EmitSQL(Stream); - else - WriteStr(Stream,' '); - WriteStr(Stream, RelOpStr[RelOp]); - WriteStr(Stream,' '); - if AllOrAnyClause <> nil then - AllOrAnyClause.EmitSQL(Stream) - else - SimpleExp2.EmitSQL(Stream); - end; -end; -{--------} -procedure TffSqlCondPrimary.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); - if SimpleExp1 <> nil then - SimpleExp1.EnumNodes(EnumMethod, Deep); - case RelOp of - roNone : - if BetweenClause <> nil then - BetweenClause.EnumNodes(EnumMethod, Deep) - else - if LikeClause <> nil then - LikeClause.EnumNodes(EnumMethod, Deep) - else - if InClause <> nil then - InClause.EnumNodes(EnumMethod, Deep) - else - if IsTest <> nil then - IsTest.EnumNodes(EnumMethod, Deep) - else - if MatchClause <> nil then - MatchClause.EnumNodes(EnumMethod, Deep) - else - if ExistsClause <> nil then - ExistsClause.EnumNodes(EnumMethod, Deep) - else - if UniqueClause <> nil then - UniqueClause.EnumNodes(EnumMethod, Deep); - else - if SimpleExp2 <> nil then - SimpleExp2.EnumNodes(EnumMethod, Deep) - else - if AllOrAnyClause <> nil then - AllOrAnyClause.EnumNodes(EnumMethod, Deep); - end; -end; -{--------} -function TffSqlCondPrimary.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlCondPrimary) - and (RelOp = TffSqlCondPrimary(Other).RelOp) - and ( - BothNil(SimpleExp1, TffSqlCondPrimary(Other).SimpleExp1) - or ( - BothNonNil(SimpleExp1, TffSqlCondPrimary(Other).SimpleExp1) - and SimpleExp1.Equals(TffSqlCondPrimary(Other).SimpleExp1) - ) - ) - and ( - BothNil(SimpleExp2, TffSqlCondPrimary(Other).SimpleExp2) - or ( - BothNonNil(SimpleExp2, TffSqlCondPrimary(Other).SimpleExp2) - and SimpleExp2.Equals(TffSqlCondPrimary(Other).SimpleExp2) - ) - ) - and ( - BothNil(BetweenClause, TffSqlCondPrimary(Other).BetweenClause) - or ( - BothNonNil(BetweenClause, TffSqlCondPrimary(Other).BetweenClause) - and BetweenClause.Equals(TffSqlCondPrimary(Other).BetweenClause) - ) - ) - and ( - BothNil(LikeClause, TffSqlCondPrimary(Other).LikeClause) - or ( - BothNonNil(LikeClause, TffSqlCondPrimary(Other).LikeClause) - and LikeClause.Equals(TffSqlCondPrimary(Other).LikeClause) - ) - ) - and ( - BothNil(InClause, TffSqlCondPrimary(Other).InClause) - or ( - BothNonNil(InClause, TffSqlCondPrimary(Other).InClause) - and InClause.Equals(TffSqlCondPrimary(Other).InClause) - ) - ) - and ( - BothNil(IsTest, TffSqlCondPrimary(Other).IsTest) - or ( - BothNonNil(IsTest, TffSqlCondPrimary(Other).IsTest) - and IsTest.Equals(TffSqlCondPrimary(Other).IsTest) - ) - ) - and ( - BothNil(AllOrAnyClause, TffSqlCondPrimary(Other).AllOrAnyClause) - or ( - BothNonNil(AllOrAnyClause, TffSqlCondPrimary(Other).AllOrAnyClause) - and AllOrAnyClause.Equals(TffSqlCondPrimary(Other).AllOrAnyClause) - ) - ) - and ( - BothNil(ExistsClause, TffSqlCondPrimary(Other).ExistsClause) - or ( - BothNonNil(ExistsClause, TffSqlCondPrimary(Other).ExistsClause) - and ExistsClause.Equals(TffSqlCondPrimary(Other).ExistsClause) - ) - ) - and ( - BothNil(MatchClause, TffSqlCondPrimary(Other).MatchClause) - or ( - BothNonNil(MatchClause, TffSqlCondPrimary(Other).MatchClause) - and MatchClause.Equals(TffSqlCondPrimary(Other).MatchClause) - ) - ) - and ( - BothNil(UniqueClause, TffSqlCondPrimary(Other).UniqueClause) - or ( - BothNonNil(UniqueClause, TffSqlCondPrimary(Other).UniqueClause) - and UniqueClause.Equals(TffSqlCondPrimary(Other).UniqueClause) - ) - ); -end; -{--------} -function TffSqlCondPrimary.GetDecimals: Integer; -begin - if SimpleExp1 <> nil then - Result := SimpleExp1.GetDecimals - else - Result := 0; -end; -{--------} -function TffSqlCondPrimary.GetSize: Integer; -begin - case RelOp of - roNone : - Result := SimpleExp1.GetSize - else - Result := 1; - end; -end; -{--------} -function TffSqlCondPrimary.GetTitle(const Qualified : Boolean): string; {!!.11} -begin - case GetType of - fftBoolean: - Result := 'COND' - else - Result := SimpleExp1.GetTitle(Qualified); {!!.11} - end; -end; -{--------} -function TffSqlCondPrimary.GetType: TffFieldType; -begin - if SimpleExp1 <> nil then - Result := SimpleExp1.GetType - else - Result := fftBoolean; {should never happen} - case RelOp of - roNone : - if (BetweenClause <> nil) - or (LikeClause <> nil) - or (InClause <> nil) - or (IsTest <> nil) - or (MatchClause <> nil) then - Result := fftBoolean; - else - if SimpleExp2 <> nil then - SimpleExp2.MatchType(Result); - Result := fftBoolean; - end; -end; -{--------} -function TffSqlCondPrimary.GetValue: Variant; -begin - if IsConstant then begin - Result := ConstantValue; - exit; - end; - case GetType of - fftBoolean: - Result := AsBoolean - else - Result := SimpleExp1.GetValue; - end; -end; -{--------} -function TffSqlCondPrimary.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; -{--------} -function TffSqlCondPrimary.IsRelationTo(Table: TFFSqlTableProxy; - var FieldReferenced: TFFSqlFieldProxy; - var Operator: TffSqlRelOp; - var ArgExpression: TffSqlSimpleExpression; - var SameCase: Boolean): Boolean; {!!.10} -begin - ArgExpression := nil; - case RelOp of - roEQ, roLE, roL, roG, roGE, roNE : - begin - if SimpleExp2 <> nil then - if SimpleExp1.IsFieldFrom(Table, FieldReferenced, SameCase) then begin - Result := True; - ArgExpression := SimpleExp2; - end else - if SimpleExp2.IsFieldFrom(Table, FieldReferenced, SameCase) then begin - Result := True; - ArgExpression := SimpleExp1; - end else - Result := False - else {typically ANY or ALL relation} - Result := False; - end; - else - Result := False; - end; - if AllOrAnyClause <> nil then - Result := False; - Operator := RelOp; -end; -{--------} -function TffSqlCondPrimary.JustSimpleExpression: Boolean; -begin - Result := (RelOp = roNone) - and (BetweenClause = nil) - and (LikeClause = nil) - and (InClause = nil) - and (IsTest = nil) - and (ExistsClause = nil) - and (UniqueClause = nil) - and (MatchClause = nil); -end; - -{!!.11 new} -procedure TffSqlCondPrimary.MatchType(ExpectedType: TffFieldType); -begin - case RelOp of - roNone : - if (BetweenClause <> nil) - or (LikeClause <> nil) - or (InClause <> nil) - or (IsTest <> nil) - or (ExistsClause <> nil) {!!.11} - or (MatchClause <> nil) then - if ExpectedType <> fftBoolean then - TypeMismatch - else - else - SimpleExp1.MatchType(ExpectedType); - else - if SimpleExp2 <> nil then begin - SimpleExp2.MatchType(SimpleExp1.GetType); - if ExpectedType <> fftBoolean then - TypeMismatch; - end; - end; -end; - -function TffSqlCondPrimary.Reduce: Boolean; -begin - Result := True; - if (SimpleExp1 <> nil) and SimpleExp1.Reduce then - exit; - if (SimpleExp2 <> nil) and SimpleExp2.Reduce then - exit; - if (BetweenClause <> nil) and BetweenClause.Reduce then - exit; - if (LikeClause <> nil) and LikeClause.Reduce then - exit; - if (InClause <> nil) and InClause.Reduce then - exit; - if (ExistsClause <> nil) and ExistsClause.Reduce then - exit; - if (UniqueClause <> nil) and UniqueClause.Reduce then - exit; - if (MatchClause <> nil) and MatchClause.Reduce then - exit; - if (AllOrAnyClause <> nil) and AllOrAnyClause.Reduce then - exit; - Result := False; -end; - -procedure TffSqlCondPrimary.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; - -{====================================================================} - -{===TffSqlCondFactor=================================================} -function TffSqlCondFactor.AsBoolean: Boolean; -begin - if TmpKnown then begin - Result := TmpValue; - exit; - end; - if IsConstant then begin - Result := ConstantValue; - exit; - end; - Result := CondPrimary.AsBoolean; - if UnaryNot then - Result := not Result; -end; -{--------} -procedure TffSqlCondFactor.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlCondFactor then begin - if CondPrimary = nil then - CondPrimary := TffSqlCondPrimary.Create(Self); - CondPrimary.Assign(TffSqlCondFactor(Source).CondPrimary); - UnaryNot := TffSqlCondFactor(Source).UnaryNot; - end else - AssignError(Source); -end; - -procedure TffSqlCondFactor.BindHaving; -begin - CondPrimary.BindHaving; -end; - -procedure TffSqlCondFactor.CheckIsConstant; -begin - FIsConstantChecked := True; - if CondPrimary.IsConstant then begin - ConstantValue := GetValue; - FIsConstant := True; - end; -end; - -procedure TffSqlCondFactor.Clear; -begin - if CondPrimary <> nil then - CondPrimary.Clear; -end; - -function TffSqlCondFactor.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - Result := CondPrimary.DependsOn(Table); -end; - -destructor TffSqlCondFactor.Destroy; -begin - CondPrimary.Free; - inherited; -end; - -procedure TffSqlCondFactor.EmitSQL(Stream: TStream); -begin - if UnaryNot then - WriteStr(Stream,' NOT'); - CondPrimary.EmitSQL(Stream); -end; -{--------} -procedure TffSqlCondFactor.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); - CondPrimary.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlCondFactor.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlCondFactor) - and (UnaryNot = TffSqlCondFactor(Other).UnaryNot) - and (CondPrimary.Equals(TffSqlCondFactor(Other).CondPrimary)); -end; -{--------} -function TffSqlCondFactor.GetDecimals: Integer; -begin - Result := CondPrimary.GetDecimals; -end; -{--------} -{!!.10} -function TffSqlCondFactor.GetSize: Integer; -begin - if UnaryNot then - Result := 1 - else - Result := CondPrimary.GetSize; -end; -{--------} -function TffSqlCondFactor.GetTitle(const Qualified : Boolean): string; {!!.11} -begin - Result := CondPrimary.GetTitle(Qualified); {!!.11} -end; -{--------} -function TffSqlCondFactor.GetType: TffFieldType; -begin - if UnaryNot then - Result := fftBoolean - else - Result := CondPrimary.GetType; -end; -{--------} -function TffSqlCondFactor.GetValue: Variant; -begin - if TmpKnown then begin - Result := TmpValue; - exit; - end; - if IsConstant then begin - Result := ConstantValue; - exit; - end; - if UnaryNot then - Result := AsBoolean - else - Result := CondPrimary.GetValue; -end; -{--------} -function TffSqlCondFactor.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; -{--------} -function TffSqlCondFactor.IsRelationTo(Table: TFFSqlTableProxy; - var FieldReferenced: TFFSqlFieldProxy; - var Operator: TffSqlRelOp; - var ArgExpression: TffSqlSimpleExpression; - var SameCase: Boolean): Boolean; -begin - ArgExpression := nil; - Result := CondPrimary.IsRelationTo(Table, FieldReferenced, - Operator, ArgExpression, SameCase) - and not ArgExpression.DependsOn(Table); - if Result and UnaryNot then - case Operator of - roNone : ; - roEQ : Operator := roNE; - roLE : Operator := roG; - roL : Operator := roGE; - roG : Operator := roLE; - roGE : Operator := roL; - roNE : Operator := roEQ; - end; -end; -{--------} -procedure TffSqlCondFactor.MarkTrue; -begin - TmpKnown := True; - TmpValue := True; -end; -{--------} -procedure TffSqlCondFactor.MarkUnknown; -begin - TmpKnown := False; -end; -{--------} -{!!.11 - new} -procedure TffSqlCondFactor.MatchType(ExpectedType: TffFieldType); -begin - if UnaryNot then - if ExpectedType <> fftBoolean then - TypeMismatch - else - else - CondPrimary.MatchType(ExpectedType); -end; -{--------} -function TffSqlCondFactor.Reduce: Boolean; -var - LiftPrimary : TffSqlCondPrimary; - NewExp: TffSqlSimpleExpression; - NewTerm: TffSqlTerm; - NewFactor: TffSqlFactor; - NewCondExp : TffSqlCondExp; - NewCondTerm: TffSqlCondTerm; - NewCondFactor : TffSqlCondFactor; - NewCondPrimary : TffSqlCondPrimary; -begin - {look for a conditional primary nested inside redundant parens} - {eliminate parens when found} - Result := False; - LiftPrimary := nil; - if (CondPrimary.RelOp = roNone) then - with CondPrimary do begin - //if SimpleExp1 <> nil then begin - if JustSimpleExpression then begin - with SimpleExp1 do - if TermCount = 1 then - with Term[0] do - if FactorCount = 1 then - with Factor[0] do - if CondExp <> nil then - with CondExp do - if CondTermCount = 1 then - with CondTerm[0] do - if CondFactorCount = 1 then - with CondFactor[0] do begin - LiftPrimary := TffSqlCondPrimary.Create(Self); - LiftPrimary.Assign(CondPrimary); - end; - if LiftPrimary <> nil then begin - Clear; - Assign(LiftPrimary); - LiftPrimary.Free; - Result := True; - end else - if Reduce then begin - {expression itself was reduced} - Result := True; - end; - end; - if not Result then - Result := Reduce; - end; - if not Result then begin {otherwise we'll be called again} - {see if this a negated simple expression which can be reversed} - if UnaryNot and (CondPrimary.RelOp <> roNone) then begin - {it is, reverse condition and remove NOT} - case CondPrimary.RelOp of - roEQ : CondPrimary.RelOp := roNE; - roLE : CondPrimary.RelOp := roG; - roL : CondPrimary.RelOp := roGE; - roG : CondPrimary.RelOp := roLE; - roGE: CondPrimary.RelOp := roL; - roNE : CondPrimary.RelOp := roEQ; - end; - UnaryNot := False; - Result := True; - end; - end; - if not Result then {otherwise we'll be called again} - if (CondPrimary.RelOp = roNE) { "<>" operator } - {can't optimize ALL/ANY clauses this way} - and (CondPrimary.AllOrAnyClause = nil) then {!!.11} - if CondPrimary.SimpleExp1.HasFieldRef - or CondPrimary.SimpleExp2.HasFieldRef then begin - {convert expressions of the form - Simple Exp1 <> Simple Exp2 - where at least one expression contains a field reference - to - (Simple Exp1 < Simple Exp2 OR Simple Exp1 > Simple Exp2) - to allow for index optimization later on} - NewExp := TffSqlSimpleExpression.Create(CondPrimary); - NewTerm := TffSqlTerm.Create(NewExp); - NewFactor := TffSqlFactor.Create(NewTerm); - NewCondExp := TffSqlCondExp.Create(NewFactor); - - NewCondTerm := TffSqlCondTerm.Create(NewCondExp); - NewCondFactor := TffSqlCondFactor.Create(NewCondTerm); - NewCondPrimary := TffSqlCondPrimary.Create(NewCondFactor); - NewCondPrimary.Assign(CondPrimary); - NewCondPrimary.RelOp := roL; - NewCondFactor.CondPrimary := NewCondPrimary; - NewCondTerm.AddCondFactor(NewCondFactor); - NewCondExp.AddCondTerm(NewCondTerm); - - NewCondTerm := TffSqlCondTerm.Create(NewCondExp); - NewCondFactor := TffSqlCondFactor.Create(NewCondTerm); - NewCondPrimary := TffSqlCondPrimary.Create(NewCondFactor); - NewCondPrimary.Assign(CondPrimary); - NewCondPrimary.RelOp := roG; - NewCondFactor.CondPrimary := NewCondPrimary; - NewCondTerm.AddCondFactor(NewCondFactor); - NewCondExp.AddCondTerm(NewCondTerm); - - NewFactor.CondExp := NewCondExp; - NewTerm.AddFactor(NewFactor); - NewExp.AddTerm(NewTerm); - - CondPrimary.SimpleExp2.Free; - CondPrimary.SimpleExp2 := nil; - CondPrimary.RelOp := roNone; - CondPrimary.SimpleExp1.Assign(NewExp); - NewExp.Free; - Result := True; - end; - if not Result then {!!.11} - Result := CondPrimary.Reduce; {!!.11} -end; -{--------} -procedure TffSqlCondFactor.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; -{====================================================================} - -{===TffSqlFloatLiteral===============================================} -procedure TffSqlFloatLiteral.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlFloatLiteral then begin - Value := TffSqlFloatLiteral(Source).Value; - end else - AssignError(Source); -end; - -procedure TffSqlFloatLiteral.ConvertToNative; -var - Code : Integer; -begin - case GetType of - fftSingle : - Val(Value, SingleValue, Code); - fftDouble : - Val(Value, DoubleValue, Code); - fftExtended : - Val(Value, ExtendedValue, Code); - fftComp : - Val(Value, Comp(CompValue), Code); - fftCurrency : - begin - FFValCurr(Value, CurrencyValue, Code); - end; - end; - Converted := Code = 0; -end; - -procedure TffSqlFloatLiteral.EmitSQL(Stream: TStream); -begin - WriteStr(Stream, Value); -end; -{--------} -procedure TffSqlFloatLiteral.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); -end; -{--------} -function TffSqlFloatLiteral.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlFloatLiteral) - and (AnsiCompareText(Value, TffSqlFloatLiteral(Other).Value) = 0); -end; -{--------} -function TffSqlFloatLiteral.GetDecimals: Integer; -begin - Result := 2; -end; -{--------} -function TffSqlFloatLiteral.GetType: TffFieldType; -begin - Result := fftDouble; -end; -{--------} -function TffSqlFloatLiteral.GetValue: Variant; -begin - if not Converted then - ConvertToNative; - case GetType of - fftSingle : - Result := SingleValue; - fftDouble : - Result := DoubleValue; - fftExtended : - Result := ExtendedValue; - fftComp : - Result := Comp(CompValue); - fftCurrency : - Result := CurrencyValue; - end; -end; -{--------} -procedure TffSqlFloatLiteral.MatchType(ExpectedType: TffFieldType); -begin - case ExpectedType of - fftByte..fftAutoInc : - ; - fftSingle..fftCurrency : - ; - else - TypeMismatch; - end; -end; - -{====================================================================} - -{===TffSqlIntegerLiteral=============================================} -procedure TffSqlIntegerLiteral.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlIntegerLiteral then begin - Value := TffSqlIntegerLiteral(Source).Value; - end else - AssignError(Source); -end; - -procedure TffSqlIntegerLiteral.EmitSQL(Stream: TStream); -begin - WriteStr(Stream, Value); -end; -{--------} -procedure TffSqlIntegerLiteral.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); -end; -{--------} -function TffSqlIntegerLiteral.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlIntegerLiteral) - and (AnsiCompareText(Value, TffSqlFloatLiteral(Other).Value) = 0); -end; -{--------} -function TffSqlIntegerLiteral.GetType: TffFieldType; -begin - Result := fftInt32; -end; - -procedure TffSqlIntegerLiteral.ConvertToNative; -begin - Int32Value := StrToInt(Value); - Converted := True; -end; - -function TffSqlIntegerLiteral.GetValue: Variant; -begin - if not Converted then - ConvertToNative; - Result := Int32Value; -end; -{--------} -procedure TffSqlIntegerLiteral.MatchType(ExpectedType: TffFieldType); -begin - case ExpectedType of - fftByte..fftCurrency : - ; - fftShortString..fftWideString : - ; - else - TypeMismatch; - end; -end; - -{====================================================================} - -{===TffSqlStringLiteral==============================================} -procedure TffSqlStringLiteral.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlStringLiteral then begin - Value := TffSqlStringLiteral(Source).Value; - end else - AssignError(Source); -end; - -procedure TffSqlStringLiteral.ConvertToNative; -var - S : string; - P : Integer; -begin - S := copy(Value, 2, length(Value) - 2); //strip quotes - {convert internal double-quotes to single quotes} - P := pos('''''', S); - while P <> 0 do begin - Delete(S, P, 1); - P := pos('''''', S); - end; - Assert(GetType in [fftChar, fftWideChar, - fftShortString..fftWideString]); - case GetType of - fftChar : - CharValue := S[1]; - fftWideChar : - WideCharValue := WideChar(S[1]); - fftShortString : - ShortStringValue := S; - fftShortAnsiStr : - ShortAnsiStringValue := S; - fftNullString : - NullStringValue := PChar(S); - fftNullAnsiStr : - NullAnsiStrValue := PChar(S); - fftWideString : - WideStringValue := S; - end; - Converted := True; -end; -{--------} -constructor TffSqlStringLiteral.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); - FType := fftNullAnsiStr; {!!.11} -end; -{--------} -procedure TffSqlStringLiteral.EmitSQL(Stream: TStream); -begin - WriteStr(Stream, Value); -end; -{--------} -procedure TffSqlStringLiteral.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); -end; -{--------} -function TffSqlStringLiteral.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlStringLiteral) - and (AnsiCompareText(Value, TffSqlStringLiteral(Other).Value) = 0); -end; -{--------} -function TffSqlStringLiteral.GetSize: Integer; -begin - if not Converted then - ConvertToNative; - Assert(GetType in [fftChar..fftWideString]); - case GetType of - fftChar : - Result := 1; - fftWideChar : - Result := 2; - fftShortString : - Result := length(ShortStringValue); - fftShortAnsiStr : - Result := length(ShortAnsiStringValue); - fftNullString : - Result := length(NullStringValue{^}); - fftNullAnsiStr : - Result := length(NullAnsiStrValue); - else //fftWideString : - Result := length(WideStringValue); - end; -end; -{--------} -function TffSqlStringLiteral.GetType: TffFieldType; -begin - Result := FType; -end; -{--------} -function TffSqlStringLiteral.GetValue: Variant; -begin - if not Converted then - ConvertToNative; - Assert(GetType in [fftChar..fftWideString]); - case GetType of - fftChar : - Result := CharValue; - fftWideChar : - Result := WideCharValue; - fftShortString : - Result := ShortStringValue; - fftShortAnsiStr : - Result := ShortAnsiStringValue; - fftNullString : - Result := NullStringValue{^}; - fftNullAnsiStr : - Result := NullAnsiStrValue; - fftWideString : - Result := WideStringValue; - end; -end; -{--------} -procedure TffSqlStringLiteral.MatchType(ExpectedType: TffFieldType); -begin - case ExpectedType of - fftChar, - fftWideChar, - fftShortString..fftWideString : - begin - FType := ExpectedType; - Converted := False; - end; -{Begin !!.11} - fftBLOB..fftBLOBTypedBin : - begin - FType := fftNullAnsiStr; - Converted := False; - end; -{End !!.11} - else - TypeMismatch; - end; -end; - -{====================================================================} - -{===TffSqlLiteral====================================================} -procedure TffSqlLiteral.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlLiteral then begin - Clear; - - if assigned(TffSqlLiteral(Source).FloatLiteral) then begin - FloatLiteral := TffSqlFloatLiteral.Create(Self); - FloatLiteral.Assign(TffSqlLiteral(Source).FloatLiteral); - end; - - if assigned(TffSqlLiteral(Source).IntegerLiteral) then begin - IntegerLiteral := TffSqlIntegerLiteral.Create(Self); - IntegerLiteral.Assign(TffSqlLiteral(Source).IntegerLiteral); - end; - - if assigned(TffSqlLiteral(Source).StringLiteral) then begin - StringLiteral := TffSqlStringLiteral.Create(Self); - StringLiteral.Assign(TffSqlLiteral(Source).StringLiteral); - end; - - if assigned(TffSqlLiteral(Source).DateLiteral) then begin - DateLiteral := TffSqlDateLiteral.Create(Self); - DateLiteral.Assign(TffSqlLiteral(Source).DateLiteral); - end; - - if assigned(TffSqlLiteral(Source).TimeLiteral) then begin - TimeLiteral := TffSqlTimeLiteral.Create(Self); - TimeLiteral.Assign(TffSqlLiteral(Source).TimeLiteral); - end; - - if assigned(TffSqlLiteral(Source).TimeStampLiteral) then begin - TimeStampLiteral := TffSqlTimeStampLiteral.Create(Self); - TimeStampLiteral.Assign(TffSqlLiteral(Source).TimeStampLiteral); - end; - - if assigned(TffSqlLiteral(Source).IntervalLiteral) then begin - IntervalLiteral := TffSqlIntervalLiteral.Create(Self); - IntervalLiteral.Assign(TffSqlLiteral(Source).IntervalLiteral); - end; - - if assigned(TffSqlLiteral(Source).BooleanLiteral) then begin - BooleanLiteral := TffSqlBooleanLiteral.Create(Self); - BooleanLiteral.Assign(TffSqlLiteral(Source).BooleanLiteral); - end; - - end else - AssignError(Source); -end; - -procedure TffSqlLiteral.Clear; -begin - FloatLiteral.Free; - IntegerLiteral.Free; - StringLiteral.Free; - DateLiteral.Free; - TimeLiteral.Free; - TimeStampLiteral.Free; - IntervalLiteral.Free; - BooleanLiteral.Free; - FloatLiteral:= nil; - IntegerLiteral:= nil; - StringLiteral:= nil; - DateLiteral:= nil; - TimeLiteral:= nil; - TimeStampLiteral:= nil; - IntervalLiteral:= nil; - BooleanLiteral := nil; -end; - -destructor TffSqlLiteral.Destroy; -begin - Clear; - inherited; -end; -{--------} -procedure TffSqlLiteral.EmitSQL(Stream: TStream); -begin - if FloatLiteral <> nil then - FloatLiteral.EmitSQL(Stream) - else - if IntegerLiteral <> nil then - IntegerLiteral.EmitSQL(Stream) - else - if StringLiteral <> nil then - StringLiteral.EmitSQL(Stream) - else - if DateLiteral <> nil then - DateLiteral.EmitSQL(Stream) - else - if TimeLiteral <> nil then - TimeLiteral.EmitSQL(Stream) - else - if TimestampLiteral <> nil then - TimestampLiteral.EmitSQL(Stream) - else - if IntervalLiteral <> nil then - IntervalLiteral.EmitSQL(Stream) - else - if BooleanLiteral <> nil then - BooleanLiteral.EmitSQL(Stream) - else - Assert(False); -end; -{--------} -function TffSqlLiteral.AddIntervalTo(Target: TDateTime): TDateTime; -begin - if IntervalLiteral <> nil then - Result := IntervalLiteral.AddIntervalTo(Target) - else begin - SQLError('Internal error: Type Mismatch'); - Result := Null; - end; -end; -{--------} -function TffSqlLiteral.SubtractIntervalFrom(Target: TDateTime): TDateTime; -begin - if IntervalLiteral <> nil then - Result := IntervalLiteral.SubtractIntervalFrom(Target) - else begin - SQLError('Internal error: Type Mismatch'); - Result := Null; - end; -end; -{--------} -procedure TffSqlLiteral.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - if FloatLiteral <> nil then - FloatLiteral.EnumNodes(EnumMethod, Deep) - else - if IntegerLiteral <> nil then - IntegerLiteral.EnumNodes(EnumMethod, Deep) - else - if StringLiteral <> nil then - StringLiteral.EnumNodes(EnumMethod, Deep) - else - if DateLiteral <> nil then - DateLiteral.EnumNodes(EnumMethod, Deep) - else - if TimeLiteral <> nil then - TimeLiteral.EnumNodes(EnumMethod, Deep) - else - if TimestampLiteral <> nil then - TimestampLiteral.EnumNodes(EnumMethod, Deep) - else - if IntervalLiteral <> nil then - IntervalLiteral.EnumNodes(EnumMethod, Deep) - else - if BooleanLiteral <> nil then - BooleanLiteral.EnumNodes(EnumMethod, Deep) - else - Assert(False); -end; -{--------} -function TffSqlLiteral.GetValue: Variant; -begin - if FloatLiteral <> nil then - Result := FloatLiteral.GetValue - else - if IntegerLiteral <> nil then - Result := IntegerLiteral.GetValue - else - if StringLiteral <> nil then - Result := StringLiteral.GetValue - else - if DateLiteral <> nil then - Result := DateLiteral.GetValue - else - if TimeLiteral <> nil then - Result := TimeLiteral.GetValue - else - if TimestampLiteral <> nil then - Result := TimestampLiteral.GetValue - else - if IntervalLiteral <> nil then - Result := IntervalLiteral.GetValue - else - if BooleanLiteral <> nil then - Result := BooleanLiteral.GetValue - else - Assert(False); -end; -{--------} -function TffSqlLiteral.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlLiteral) - and - (BothNil(FloatLiteral, TffSqlLiteral(Other).FloatLiteral) - or (BothNonNil(FloatLiteral, TffSqlLiteral(Other).FloatLiteral) - and FloatLiteral.Equals(TffSqlLiteral(Other).FloatLiteral) - ) - ) - and - (BothNil(IntegerLiteral, TffSqlLiteral(Other).IntegerLiteral) - or (BothNonNil(IntegerLiteral, TffSqlLiteral(Other).IntegerLiteral) - and IntegerLiteral.Equals(TffSqlLiteral(Other).IntegerLiteral) - ) - ) - and - (BothNil(StringLiteral, TffSqlLiteral(Other).StringLiteral) - or (BothNonNil(StringLiteral, TffSqlLiteral(Other).StringLiteral) - and StringLiteral.Equals(TffSqlLiteral(Other).StringLiteral) - ) - ) - and - (BothNil(DateLiteral, TffSqlLiteral(Other).DateLiteral) - or (BothNonNil(DateLiteral, TffSqlLiteral(Other).DateLiteral) - and DateLiteral.Equals(TffSqlLiteral(Other).DateLiteral) - ) - ) - and - (BothNil(TimeLiteral, TffSqlLiteral(Other).TimeLiteral) - or (BothNonNil(TimeLiteral, TffSqlLiteral(Other).TimeLiteral) - and TimeLiteral.Equals(TffSqlLiteral(Other).TimeLiteral) - ) - ) - and - (BothNil(TimestampLiteral, TffSqlLiteral(Other).TimestampLiteral) - or (BothNonNil(TimestampLiteral, TffSqlLiteral(Other).TimestampLiteral) - and TimestampLiteral.Equals(TffSqlLiteral(Other).TimestampLiteral) - ) - ) - and - (BothNil(IntervalLiteral, TffSqlLiteral(Other).IntervalLiteral) - or (BothNonNil(IntervalLiteral, TffSqlLiteral(Other).IntervalLiteral) - and IntervalLiteral.Equals(TffSqlLiteral(Other).IntervalLiteral) - ) - ) - and - (BothNil(BooleanLiteral, TffSqlLiteral(Other).BooleanLiteral) - or (BothNonNil(BooleanLiteral, TffSqlLiteral(Other).BooleanLiteral) - and BooleanLiteral.Equals(TffSqlLiteral(Other).BooleanLiteral) - ) - ); -end; -{--------} -function TffSqlLiteral.GetDecimals: Integer; -begin - if FloatLiteral <> nil then - Result := FloatLiteral.GetDecimals - else - Result := 0; -end; -{--------} -function TffSqlLiteral.GetSize: Integer; -begin - Result := 0; - if FloatLiteral <> nil then - Result := FloatLiteral.GetSize - else - if IntegerLiteral <> nil then - Result := IntegerLiteral.GetSize - else - if StringLiteral <> nil then - Result := StringLiteral.GetSize - else - if DateLiteral <> nil then - Result := DateLiteral.GetSize - else - if TimeLiteral <> nil then - Result := TimeLiteral.GetSize - else - if TimestampLiteral <> nil then - Result := TimestampLiteral.GetSize - else - if IntervalLiteral <> nil then - Result := IntervalLiteral.GetSize - else - if BooleanLiteral <> nil then - Result := BooleanLiteral.GetSize - else - Assert(False); -end; -{--------} -function TffSqlLiteral.GetType: TffFieldType; -begin - Result := fftInterval; {dummy to suppress compiler warning} - if FloatLiteral <> nil then - Result := FloatLiteral.GetType - else - if IntegerLiteral <> nil then - Result := IntegerLiteral.GetType - else - if StringLiteral <> nil then - Result := StringLiteral.GetType - else - if DateLiteral <> nil then - Result := DateLiteral.GetType - else - if TimeLiteral <> nil then - Result := TimeLiteral.GetType - else - if TimestampLiteral <> nil then - Result := TimestampLiteral.GetType - else - if IntervalLiteral <> nil then - Result := IntervalLiteral.GetType - else - if BooleanLiteral <> nil then - Result := BooleanLiteral.GetType - else - Assert(False); -end; -{--------} - -function IsValidDate(const S: ShortString): Boolean; -begin - if (length(S) <> 12) - or (S[6] <> '-') - or (S[9] <> '-') then - Result := False - else - try - EncodeDate( - StrToInt(copy(S, 2, 4)), - StrToInt(copy(S, 7, 2)), - StrToInt(copy(S, 10, 2))); - Result := True; - except - Result := False; - end; -end; - -function IsValidTime(const S: ShortString): Boolean; -begin - if (length(S) <> 10) - or (S[4] <> ':') - or (S[7] <> ':') then - Result := False - else - try - EncodeTime( - StrToInt(copy(S, 2, 2)), - StrToInt(copy(S, 5, 2)), - StrToInt(copy(S, 8, 2)), - 0); - Result := True; - except - Result := False; - end; -end; - -function IsValidTimestamp(const S: ShortString): Boolean; -begin - if (length(S) < 21) - or (S[6] <> '-') - or (S[9] <> '-') - or (S[12] <> ' ') - or (S[15] <> ':') - or (S[18] <> ':') then - Result := False - else - try - EncodeDate( - StrToInt(copy(S, 2, 4)), - StrToInt(copy(S, 7, 2)), - StrToInt(copy(S, 10, 2))); - EncodeTime( - StrToInt(copy(S, 13, 2)), - StrToInt(copy(S, 16, 2)), - StrToInt(copy(S, 19, 2)), - 0); - Result := True; - except - Result := False; - end; -end; - -procedure TffSqlLiteral.MatchType(ExpectedType: TffFieldType); -begin - if FloatLiteral <> nil then - FloatLiteral.MatchType(ExpectedType) - else - if IntegerLiteral <> nil then - IntegerLiteral.MatchType(ExpectedType) - else - if StringLiteral <> nil then - case ExpectedType of - fftStDate, fftStTime, fftDateTime: - begin - {String literal, but caller was expecting a Date-type.} - {See if the string literal represents a valid date.} - {If it does, convert.} - if IsValidDate(StringLiteral.Value) then begin - DateLiteral := TffSqlDateLiteral.Create(Self); - DateLiteral.Value := StringLiteral.Value; - StringLiteral.Free; - StringLiteral := nil; - end else - {See if the string literal represents a valid time.} - {If it does, convert.} - if IsValidTime(StringLiteral.Value) then begin - TimeLiteral := TffSqlTimeLiteral.Create(Self); - TimeLiteral.Value := StringLiteral.Value; - StringLiteral.Free; - StringLiteral := nil; - end else - {See if the string literal represents a valid time stamp} - {If it does, convert.} - if IsValidTimestamp(StringLiteral.Value) then begin - TimeStampLiteral := TffSqlTimestampLiteral.Create(Self); - TimeStampLiteral.Value := StringLiteral.Value; - StringLiteral.Free; - StringLiteral := nil; - end else - TypeMismatch; - end; - else - StringLiteral.MatchType(ExpectedType); - end - else - if DateLiteral <> nil then - DateLiteral.MatchType(ExpectedType) - else - if TimeLiteral <> nil then - TimeLiteral.MatchType(ExpectedType) - else - if TimestampLiteral <> nil then - TimestampLiteral.MatchType(ExpectedType) - else - if IntervalLiteral <> nil then - IntervalLiteral.MatchType(ExpectedType) - else - if BooleanLiteral <> nil then - BooleanLiteral.MatchType(ExpectedType) - else - Assert(False); -end; -{====================================================================} - -{===TffSqlParam======================================================} -procedure TffSqlParam.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlParam then begin - FParmIndex := TffSqlParam(Source).FParmIndex; - end else - AssignError(Source); -end; - -constructor TffSqlParam.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); - FParmIndex := Owner.ParmCount; - inc(Owner.ParmCount); -end; -{--------} -function TffSqlParam.GetDecimals: Integer; -begin - Result := 0; -end; -{--------} -function TffSqlParam.GetSize: Integer; -begin - case GetType of - fftWideString : Result := length(GetValue); - fftShortAnsiStr : Result := length(GetValue); - fftBLOB : Result := VarArrayHighBound(GetValue, 1); {!!.13} - else - Result := 0; - end; -end; -{--------} -function TffSqlParam.GetTitle(const Qualified : Boolean): string; {!!.11} -begin - Result := '?'; -end; -{--------} -function TffSqlParam.GetType: TffFieldType; -var - V : Variant; -begin - Result := fftInterval; {dummy to suppress compiler warning} - V := Owner.ParmList.GetValue(ParmIndex); - case VarType(V) and VarTypeMask of - varSmallint : Result := fftInt32; - varInteger : Result := fftInt32; - varSingle : Result := fftSingle; - varDouble : Result := fftDouble; - varCurrency : Result := fftCurrency; - varDate : Result := fftDateTime; - varOleStr : Result := fftWideString; - varBoolean : Result := fftBoolean; - varString : Result := fftShortAnsiStr; - varByte : Result := fftBLOB; {!!.13} - else - SQLError('Unsupported parameter type:'+IntToHex(VarType(V),0)); - end; -end; -{--------} -procedure TffSqlParam.EmitSQL(Stream: TStream); -begin - WriteStr(Stream,' ?'); -end; -{--------} -procedure TffSqlParam.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); -end; -{--------} -function TffSqlParam.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlParam) { - and (AnsiCompareText(Name, TffSqlParam(Other).Name) = 0)}; -end; -{--------} -function TffSqlParam.GetValue: Variant; -begin - if Owner.ParmList = nil then - raise Exception.Create('No parameter values specified for query. ' + - 'Verify the parameters listed in the ' + - 'TffQuery.Params property matches the ' + - 'parameters specified in the TffQuery.SQL ' + - 'property.'); - Result := Owner.ParmList.GetValue(ParmIndex); -end; -{--------} -procedure TffSqlParam.MatchType(ExpectedType: TffFieldType); -begin -end; -{====================================================================} - -{===TffSqlFactor=====================================================} -function TffSqlFactor.AddIntervalTo(Target: TDateTime): TDateTime; -begin - if Literal <> nil then - Result := Literal.AddIntervalTo(Target) - else begin - SQLError('Not implemented'); - Result := Null; - end; -end; -{--------} -function TffSqlFactor.SubtractIntervalFrom(Target: TDateTime): TDateTime; -begin - if Literal <> nil then - Result := Literal.SubtractIntervalFrom(Target) - else begin - SQLError('Not implemented'); - Result := Null; - end; -end; -{--------} -procedure TffSqlFactor.CheckIsConstant; -begin - FIsConstantChecked := True; - if SubQuery <> nil then - FIsConstant := False - else - if CondExp <> nil then - FIsConstant := CondExp.IsConstant - else - if FieldRef <> nil then - FIsConstant := False - else - if Literal <> nil then - FIsConstant := {True} Literal.IntervalLiteral = nil - {can't store interval values, so we can't handle those - as constant values even if they are in fact constant} - else - if Param <> nil then - FIsConstant := False - else - if Aggregate <> nil then - FIsConstant := False - else - if ScalarFunc <> nil then - FIsConstant := ScalarFunc.IsConstant - else - Assert(False); - if FIsConstant then begin - FIsConstant := False; - ConstantValue := GetValue; - FIsConstant := True; - end; -end; -{--------} -procedure TffSqlFactor.CheckType; -begin - if SubQuery <> nil then - FType := SubQuery.GetType - else - if CondExp <> nil then - FType:= CondExp.GetType - else - if FieldRef <> nil then - FType := FieldRef.GetType - else - if Literal <> nil then - FType := Literal.GetType - else - if Param <> nil then - FType := Param.GetType - else - if Aggregate <> nil then - FType := Aggregate.GetType - else - if ScalarFunc <> nil then - FType := ScalarFunc.GetType - else - Assert(False); - if UnaryMinus then - case FType of - fftByte, - fftWord16, - fftWord32, - fftInt8, - fftInt16, - fftInt32, - fftAutoInc, - fftSingle, - fftDouble, - fftExtended, - fftComp, - fftCurrency : - ; - else - SQLError('Operator/operand mismatch'); - end; - TypeKnown := True; -end; -{--------} -procedure TffSqlFactor.Clear; -begin - SubQuery.Free; - CondExp.Free; - FieldRef.Free; - Literal.Free; - Param.Free; - Aggregate.Free; - ScalarFunc.Free; - SubQuery:= nil; - CondExp:= nil; - FieldRef:= nil; - Literal:= nil; - Param:= nil; - Aggregate:= nil; - ScalarFunc:= nil; -end; -{--------} -function TffSqlFactor.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - if SubQuery <> nil then - Result := SubQuery.DependsOn(Table) - else - if CondExp <> nil then - Result := CondExp.DependsOn(Table) - else - if FieldRef <> nil then - Result := FieldRef.DependsOn(Table) - else - if Literal <> nil then - Result := False - else - if Param <> nil then - Result := False - else - if Aggregate <> nil then - Result := Aggregate.DependsOn(Table) - else - if ScalarFunc <> nil then - Result := ScalarFunc.DependsOn(Table) - else begin - Assert(False); - Result := False; - end; -end; -{--------} -destructor TffSqlFactor.Destroy; -begin - Clear; - inherited; -end; -{--------} -procedure TffSqlFactor.EmitSQL(Stream: TStream); -begin - if UnaryMinus then - WriteStr(Stream,' - '); - if SubQuery <> nil then begin - WriteStr(Stream,' ('); - SubQuery.EmitSQL(Stream); - WriteStr(Stream,')'); - end else - if CondExp <> nil then begin - WriteStr(Stream,' ('); - CondExp.EmitSQL(Stream); - WRiteStr(Stream,')'); - end else - if FieldRef <> nil then - FieldRef.EmitSQL(Stream) - else - if Literal <> nil then - Literal.EmitSQL(Stream) - else - if Param <> nil then - Param.EmitSQL(Stream) - else - if Aggregate <> nil then - Aggregate.EmitSQL(Stream) - else - if ScalarFunc <> nil then - ScalarFunc.EmitSQL(Stream) - else - Assert(False); -end; -{--------} -procedure TffSqlFactor.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - if SubQuery <> nil then - SubQuery.EnumNodes(EnumMethod, Deep) - else - if CondExp <> nil then - CondExp.EnumNodes(EnumMethod, Deep) - else - if FieldRef <> nil then - FieldRef.EnumNodes(EnumMethod, Deep) - else - if Literal <> nil then - Literal.EnumNodes(EnumMethod, Deep) - else - if Param <> nil then - Param.EnumNodes(EnumMethod, Deep) - else - if ScalarFunc <> nil then - ScalarFunc.EnumNodes(EnumMethod, Deep) - else - if Aggregate <> nil then - Aggregate.EnumNodes(EnumMethod, Deep) - else - Assert(False); -end; -{--------} -function TffSqlFactor.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlFactor) - and (MulOp = TffSqlFactor(Other).MulOp) - and (UnaryMinus = TffSqlFactor(Other).UnaryMinus) - and - (BothNil(CondExp, TffSqlFactor(Other).CondExp) - or ( - BothNonNil(CondExp, TffSqlFactor(Other).CondExp) - and CondExp.Equals(TffSqlFactor(Other).CondExp) - ) - ) - and - (BothNil(FieldRef, TffSqlFactor(Other).FieldRef) - or ( - BothNonNil(FieldRef, TffSqlFactor(Other).FieldRef) - and FieldRef.Equals(TffSqlFactor(Other).FieldRef) - ) - ) - and - (BothNil(Literal, TffSqlFactor(Other).Literal) - or ( - BothNonNil(Literal, TffSqlFactor(Other).Literal) - and Literal.Equals(TffSqlFactor(Other).Literal) - ) - ) - and - (BothNil(Param, TffSqlFactor(Other).Param) - or ( - BothNonNil(Param, TffSqlFactor(Other).Param) - and Param.Equals(TffSqlFactor(Other).Param) - ) - ) - and - (BothNil(Aggregate, TffSqlFactor(Other).Aggregate) - or ( - BothNonNil(Aggregate, TffSqlFactor(Other).Aggregate) - and Aggregate.Equals(TffSqlFactor(Other).Aggregate) - ) - ) - and - (BothNil(SubQuery, TffSqlFactor(Other).SubQuery) - or ( - BothNonNil(SubQuery, TffSqlFactor(Other).SubQuery) - and SubQuery.Equals(TffSqlFactor(Other).SubQuery) - ) - ) - and - (BothNil(ScalarFunc, TffSqlFactor(Other).ScalarFunc) - or ( - BothNonNil(ScalarFunc, TffSqlFactor(Other).ScalarFunc) - and ScalarFunc.Equals(TffSqlFactor(Other).ScalarFunc) - ) - ); -end; -{--------} -function TffSqlFactor.GetDecimals: Integer; -begin - if SubQuery <> nil then - Result := SubQuery.GetDecimals - else - if CondExp <> nil then - Result := CondExp.GetDecimals - else - if FieldRef <> nil then - Result := FieldRef.GetDecimals - else - if Literal <> nil then - Result := Literal.GetDecimals - else - if Param <> nil then - Result := Param.GetDecimals - else - if Aggregate <> nil then - Result := Aggregate.GetDecimals - else - if ScalarFunc <> nil then - Result := ScalarFunc.GetDecimals - else begin - Assert(False); - Result := 0; - end; -end; -{--------} -function TffSqlFactor.GetSize: Integer; -begin - if SubQuery <> nil then - Result := SubQuery.GetSize - else - if CondExp <> nil then - Result := CondExp.GetSize - else - if FieldRef <> nil then - Result := FieldRef.GetSize - else - if Literal <> nil then - Result := Literal.GetSize - else - if Param <> nil then - Result := Param.GetSize - else - if Aggregate <> nil then - Result := Aggregate.GetSize - else - if ScalarFunc <> nil then - Result := ScalarFunc.GetSize - else begin - Assert(False); - Result := 0; - end; -end; -{--------} -function TffSqlFactor.GetTitle(const Qualified : Boolean): string; {!!.11} -begin - if SubQuery <> nil then - Result := 'SUB' - else - if CondExp <> nil then - Result := CondExp.GetTitle(Qualified) {!!.11} - else - if FieldRef <> nil then - Result := FieldRef.GetTitle(Qualified) {!!.11} - else - if Literal <> nil then - Result := 'LIT' - else - if Param <> nil then - Result := Param.GetTitle(Qualified) {!!.11} - else - if ScalarFunc <> nil then - Result := ScalarFunc.GetTitle(Qualified) {!!.11} - else - if Aggregate <> nil then - Result := Aggregate.GetTitle(Qualified) {!!.11} - else - Assert(False); -end; -{--------} -function TffSqlFactor.GetType: TffFieldType; -begin - if not TypeKnown then - CheckType; - Result := FType -end; -{--------} -procedure TffSqlFactor.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlFactor then begin - Clear; - - MulOp := TffSqlFactor(Source).MulOp; - - UnaryMinus := TffSqlFactor(Source).UnaryMinus; - - if assigned(TffSqlFactor(Source).CondExp) then begin - CondExp := TffSqlCondExp.Create(Self); - CondExp.Assign(TffSqlFactor(Source).CondExp); - end; - - if assigned(TffSqlFactor(Source).FieldRef) then begin - FieldRef := TffSqlFieldRef.Create(Self); - FieldRef.Assign(TffSqlFactor(Source).FieldRef); - end; - - if assigned(TffSqlFactor(Source).Literal) then begin - Literal := TffSqlLiteral.Create(Self); - Literal.Assign(TffSqlFactor(Source).Literal); - end; - - if assigned(TffSqlFactor(Source).Param) then begin - Param := TffSqlParam.Create(Self); - Param.Assign(TffSqlFactor(Source).Param); - end; - - if assigned(TffSqlFactor(Source).Aggregate) then begin - Aggregate := TffSqlAggregate.Create(Self); - Aggregate.Assign(TffSqlFactor(Source).Aggregate); - end; - - if assigned(TffSqlFactor(Source).SubQuery) then begin - SubQuery := TffSqlSELECT.Create(Self); - SubQuery.Assign(TffSqlFactor(Source).SubQuery); - end; - - if assigned(TffSqlFactor(Source).ScalarFunc) then begin - ScalarFunc := TffSqlScalarFunc.Create(Self); - ScalarFunc.Assign(TffSqlFactor(Source).ScalarFunc); - end; - - end else - AssignError(Source); -end; -{--------} -function TffSqlFactor.GetValue: Variant; -begin - if IsConstant then begin - Result := ConstantValue; - exit; - end; - if SubQuery <> nil then - Result := SubQuery.GetValue - else - if CondExp <> nil then - Result := CondExp.GetValue - else - if FieldRef <> nil then - Result := FieldRef.GetValue - else - if Literal <> nil then - Result := Literal.GetValue - else - if Param <> nil then - Result := Param.GetValue - else - if Aggregate <> nil then - Result := Aggregate.GetAggregateValue - else - if ScalarFunc <> nil then - Result := ScalarFunc.GetValue - else - Assert(False); - if UnaryMinus then - if not VarIsNull(Result) then - Result := - Result; -end; -{--------} -function TffSqlFactor.HasFieldRef: Boolean; -begin - Result := (FieldRef <> nil); -end; -{--------} -function TffSqlFactor.IsField(var FieldReferenced: TFFSqlFieldProxy): Boolean; -begin - Result := (FieldRef <> nil) and not UnaryMinus; - if Result then - FieldReferenced := FieldRef.Field; -end; -{--------} -function TffSqlFactor.IsFieldFrom(Table: TFFSqlTableProxy; - var FieldReferenced: TFFSqlFieldProxy; var SameCase: Boolean): Boolean; -begin - Result := (FieldRef <> nil) and - (FieldRef.Field <> nil) and - (FieldRef.Field.OwnerTable = Table); - if Result then begin - FieldReferenced := FieldRef.Field; - SameCase := True; - end else - if ScalarFunc <> nil then begin - Result := ScalarFunc.IsFieldFrom(Table, FieldReferenced); - SameCase := False; - end; -end; -{--------} -function TffSqlFactor.IsNull: Boolean; -begin - if FieldRef <> nil then - Result := FieldRef.IsNull - else - Result := VarIsNull(GetValue); -end; -{--------} -function TffSqlFactor.IsAggregate: Boolean; -begin - Result := Aggregate <> nil; -end; -{--------} -function TffSqlFactor.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; -{--------} -procedure TffSqlFactor.MatchType(ExpectedType: TffFieldType); -begin - if SubQuery <> nil then - SubQuery.MatchType(ExpectedType, True) - else - if CondExp <> nil then - CondExp.MatchType(ExpectedType) - else - if FieldRef <> nil then - FieldRef.MatchType(ExpectedType) - else - if Literal <> nil then - Literal.MatchType(ExpectedType) - else - if Param <> nil then - Param.MatchType(ExpectedType) - else - if Aggregate <> nil then - Aggregate.MatchType(ExpectedType) - else - if ScalarFunc <> nil then - ScalarFunc.MatchType(ExpectedType) - else - Assert(False); -end; -{--------} -function TffSqlFactor.Reduce: Boolean; -var - LiftFactor: TffSqlFactor; -begin - if SubQuery <> nil then - Result := SubQuery.Reduce - else - if CondExp <> nil then begin - {!!.11 begin} - {if conditional expression is nothing but a parenthesized factor, - lift it to this level} - LiftFactor := nil; - if CondExp.CondTermCount = 1 then - with CondExp.CondTerm[0] do - if CondFactorCount = 1 then - with CondFactor[0] do - if not UnaryNot then - with CondPrimary do - if (RelOp = roNone) and (SimpleExp2 = nil) then - with SimpleExp1 do - if TermCount = 1 then - with Term[0] do - if FactorCount = 1 then begin - LiftFactor := TffSqlFactor.Create(Parent); - LiftFactor.Assign(Factor[0]); - LiftFactor.MulOp := MulOp; {!!.13} - end; - if LiftFactor <> nil then begin - CondExp.Free; - CondExp := nil; - Assign(LiftFactor); - LiftFactor.Free; - Result := True; - end else - {!!.11 end} - Result := CondExp.Reduce - end else - if FieldRef <> nil then - Result := False - else - if Literal <> nil then - Result := False - else - if Param <> nil then - Result := False - else - if Aggregate <> nil then - Result := Aggregate.Reduce - else - if ScalarFunc <> nil then - Result := ScalarFunc.Reduce - else - Result := False; -end; -{--------} -procedure TffSqlFactor.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; -{Begin !!.11} -{--------} -function TffSqlFactor.WasWildcard : Boolean; -begin - if FieldRef <> nil then - Result := FieldRef.WasWildcard - else - Result := False; -end; -{End !!.11} -{====================================================================} - -{===TffSqlSelection==================================================} -procedure TffSqlSelection.AddColumnDef(Target: TffSqlColumnListOwner); -{Rewritten !!.11} -var - S, SQual : string; - F : TffSqlNode; - i : Integer; -begin - if Column <> nil then - S := Column.ColumnName - else - S := ''; - F := SimpleExpression; - if S = '' then - S := SimpleExpression.GetTitle(False); - - if Target.Columns.IndexOf(S) <> -1 then begin - { See if we can use the qualified column name. This is done for the sake - of backwards compatibility with existing SQL statements in FF clients. } - SQual := SimpleExpression.GetTitle(True); - if Target.Columns.IndexOf(SQual) = -1 then - Target.Columns.AddObject(SQual, F) - else begin - i := 1; - repeat - inc(i); - until Target.Columns.IndexOf(S + '_' + IntToStr(i)) = -1; - Target.Columns.AddObject(S + '_' + IntToStr(i), F); - end; - end else - Target.Columns.AddObject(S, F); -end; -{--------} -procedure TffSqlSelection.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlSelection then begin - SimpleExpression.Free; - SimpleExpression := TffSqlSimpleExpression.Create(Self); - SimpleExpression.Assign(TffSqlSelection(Source).SimpleExpression); - Column.Free; - Column := nil; - if assigned(TffSqlSelection(Source).Column) then begin - Column := TffSqlColumn.Create(Self); - Column.Assign(TffSqlSelection(Source).Column); - end; - end else - AssignError(Source); -end; - -destructor TffSqlSelection.Destroy; -begin - SimpleExpression.Free; - Column.Free; - inherited; -end; - -procedure TffSqlSelection.EmitSQL(Stream: TStream); -begin - SimpleExpression.EmitSQL(Stream); - if Column <> nil then begin - WriteStr(Stream,' AS'); - Column.EmitSQL(Stream); - end; -end; -{--------} -procedure TffSqlSelection.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - SimpleExpression.EnumNodes(EnumMethod, Deep); - if Column <> nil then - Column.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlSelection.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlSelection) - and ( - BothNil(SimpleExpression, TffSqlSelection(Other).SimpleExpression) - or (BothNonNil(SimpleExpression, TffSqlSelection(Other).SimpleExpression) - and SimpleExpression.Equals(TffSqlSelection(Other).SimpleExpression) - ) - ) - and ( - BothNil(Column, TffSqlSelection(Other).Column) - or (BothNonNil(Column, TffSqlSelection(Other).Column) - and Column.Equals(TffSqlSelection(Other).Column) - ) - ); -end; -{--------} -function TffSqlSelection.GetIndex: Integer; -begin - Result := TffSqlSelectionList(Parent).FSelections.IndexOf(Self); -end; - -{--------} -function TffSqlSelection.IsAggregateExpression: Boolean; -begin - Result := SimpleExpression.IsAggregateExpression; -end; - -function TffSqlSelection.Reduce: Boolean; -begin - Result := SimpleExpression.Reduce; -end; - -{====================================================================} - -{===TffSqlTableRef===================================================} -procedure TffSqlTableRef.AddTableReference(Select: TffSqlSELECT); -var - IX, I : Integer; -begin - IX := -1; - Assert(Assigned(Select.TablesReferencedByOrder)); - if TableName <> '' then begin - if DatabaseName <> '' then - if not SameText(DatabaseName, Owner.FDatabase.Alias) then - SQLError(format('The referenced database name %s does not '+ - 'match the current database, %s.', - [DatabaseName, Owner.FDatabase.Alias])); - IX := Select.TablesReferencedByOrder.Add(TableName) - end else begin - Assert(Assigned(TableExp)); - TableExp.EnsureResultTable(True); - if Select.TablesReferencedByOrder.IndexOf('$$UNNAMED') = -1 then - IX := Select.TablesReferencedByOrder.AddObject('$$UNNAMED', - TableExp.ResultTable) - else begin - I := 2; - repeat - if Select.TablesReferencedByOrder.IndexOf('$$UNNAMED_' + IntToStr(I)) = - -1 then begin - IX := Select.TablesReferencedByOrder.AddObject('$$UNNAMED_' + - IntToStr(I), TableExp.ResultTable); - break; - end; - inc(I); - until False; - end; - end; - if Alias <> '' then begin - Assert(Assigned(Select.TableAliases)); - if Select.TableAliases.IndexOf(Alias) <> -1 then - SQLError('Duplicate alias definition:' + Alias); - Select.TableAliases.AddObject(Alias, TObject(IX)); - end; -end; -{--------} -procedure TffSqlTableRef.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlTableRef then begin - Clear; - TableName := TffSqlTableRef(Source).TableName; - Alias := TffSqlTableRef(Source).Alias; - if TffSqlTableRef(Source).TableExp <> nil then begin - TableExp := TffSqlTableExp.Create(Self); - TableExp.Assign(TffSqlTableRef(Source).TableExp); - end; - if TffSqlTableRef(Source).ColumnList <> nil then begin - ColumnList := TFFSqlInsertColumnList.Create(Self); - ColumnList.Assign(TffSqlTableRef(Source).ColumnList); - end; - end else - AssignError(Source); -end; - -function TffSqlTableRef.BindFieldDown(const TableName, - FieldName: string): TFFSqlFieldProxy; -{- not used for binding directly from SELECT - only for - binding to contained sub-expressions} -begin - if TableExp <> nil then - Result := TableExp.BindFieldDown(TableName, FieldName) - else - if SameText(TableName, Self.TableName) - and (Alias = '') {can't bind to table name if alias present} {!!.12} - or SameText(TableName, Alias) then - Result := ResultTable.FieldByName(FieldName) - else - Result := nil; -end; - -function TffSqlTableRef.BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; -begin - if SameText(TableName, Alias) or SameText(TableName, Self.TableName) then - Result := GetTable(AOwner, False) - else - if TableExp <> nil then - Result := TableExp.BindTable(AOwner, TableName) - else - Result := nil; -end; - -procedure TffSqlTableRef.Clear; -begin - TableName := ''; - Alias := ''; - TableExp.Free; - TableExp := nil; - ColumnList.Free; - ColumnList := nil; -end; - -function TffSqlTableRef.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - if TableExp <> nil then - Result := TableExp.DependsOn(Table) - else - Result := False; -end; - -destructor TffSqlTableRef.Destroy; -begin - Clear; - inherited; -end; - -procedure TffSqlTableRef.EmitSQL(Stream: TStream); -begin - if TableName <> '' then begin - WriteStr(Stream, ' '); - WriteStr(Stream, TableName); - if Alias <> '' then begin - WriteStr(Stream,' AS '); - WriteStr(Stream, Alias); - end; - end else - if TableExp <> nil then begin - WriteStr(Stream, ' ('); - TableExp.EmitSQL(Stream); - WriteStr(Stream,')'); - if Alias <> '' then begin - WriteStr(Stream,' AS '); - WriteStr(Stream, Alias); - end; - if ColumnList <> nil then begin - WriteStr(Stream, ' ('); - ColumnList.EmitSQL(Stream); - WriteStr(Stream, ')'); - end; - end; -end; -{--------} -procedure TffSqlTableRef.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - if Deep and assigned(TableExp) then - TableExp.EnumNodes(EnumMethod, Deep); - if assigned(ColumnList) then - ColumnList.EnumNodes(EnumMethod, Deep); -end; -{--------} - -function TffSqlTableRef.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlTableRef) - and (AnsiCompareText(TableName, TffSqlTableRef(Other).TableName) = 0) - and (AnsiCompareText(Alias, TffSqlTableRef(Other).Alias) = 0) - and (BothNil(TableExp, TffSqlTableRef(Other).TableExp) - or (BothNonNil(TableExp, TffSqlTableRef(Other).TableExp) - and TableExp.Equals(TffSqlTableRef(Other).TableExp) - )) - and (BothNil(ColumnList, TffSqlTableRef(Other).ColumnList) - or (BothNonNil(ColumnList, TffSqlTableRef(Other).ColumnList) - and ColumnList.Equals(TffSqlTableRef(Other).ColumnList) - )); -end; - -procedure TffSqlTableRef.Execute( - var aLiveResult: Boolean; var aCursorID: TffCursorID; - var RecordsRead: Integer); -var - T : TffSqlTableProxy; -begin - Assert(Owner <> nil); - T := GetTable(Self, False); - aCursorID := T.CursorID; - T.LeaveCursorOpen := True; - if T.Owner = Self then begin - T.Owner := nil; - T.Free; - end; -end; - -function TffSqlTableRef.GetResultTable: TFFSqlTableProxy; -begin - Result := GetTable(Self, False); -end; - -function TffSqlTableRef.GetSQLName: string; -begin - if Alias <> '' then - Result := Alias - else - if TableName <> '' then - Result := TableName - else - Result := 'UNNAMED'; -end; - -function TffSqlTableRef.GetTable(AOwner: TObject; - const ExclContLock : Boolean): TffSqlTableProxy; -begin - if DatabaseName <> '' then - if not SameText(DatabaseName, Owner.FDatabase.Alias) then - SQLError(format('The referenced database name %s does not '+ - 'match the current database, %s.', - [DatabaseName, Owner.FDatabase.Alias])); - if TableName <> '' then begin - if FTable = nil then begin - FTable := Owner.FDatabase.TableByName(AOwner, TableName, - ExclContLock, Alias); {!!.11} - if FTable = nil then - SQLError('Unable to open table: ' + TableName + - '. Ensure the table exists and is not in use by ' + - 'another process.'); - FTable.SetIndex(-1); - end; - Result := FTable; - end else - Result := TableExp.ResultTable; -end; - -{!!.11 new} -function TffSqlTableRef.Reduce: Boolean; -begin - if TableExp <> nil then - if TableExp.Reduce then begin - Result := True; - exit; - end; - Result := False; -end; - -function TffSqlTableRef.TargetFieldFromSourceField( - const F: TffSqlFieldProxy): TffSqlFieldProxy; -begin - if TableExp <> nil then - Result := TableExp.TargetFieldFromSourceField(F) - else - Result := nil; {!!.13} -end; - -{====================================================================} - -{===TffSqlSimpleExpressionList=======================================} -function TffSqlSimpleExpressionList.AddExpression( - Expression: TffSqlSimpleExpression): TffSqlSimpleExpression; -begin - FExpressionList.Add(Expression); - Result := Expression; -end; -{--------} -procedure TffSqlSimpleExpressionList.Assign(const Source: TffSqlNode); -var - i: Integer; -begin - if Source is TffSqlSimpleExpressionList then begin - Clear; - for i := 0 to pred(TffSqlSimpleExpressionList(Source).ExpressionCount) do - AddExpression(TffSqlSimpleExpression.Create(Self)).Assign( - TffSqlSimpleExpressionList(Source).Expression[i]); - end else - AssignError(Source); -end; - -procedure TffSqlSimpleExpressionList.CheckIsConstant; -var - i : Integer; -begin - FIsConstantChecked := True; - for i := 0 to pred(ExpressionCount) do - if not Expression[i].IsConstant then begin - FIsConstant := False; - exit; - end; - FIsConstant := True; -end; - -function TffSqlSimpleExpressionList.Contains(const TestValue: Variant): Boolean; -var - i : Integer; -begin - for i := 0 to pred(ExpressionCount) do - if Expression[i].GetValue = TestValue then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -constructor TffSqlSimpleExpressionList.Create( - AParent: TffSqlNode); -begin - inherited Create(AParent); - FExpressionList := TList.Create; -end; -{--------} -procedure TffSqlSimpleExpressionList.Clear; -var - i : Integer; -begin - for i := 0 to pred(ExpressionCount) do - Expression[i].Free; - FExpressionList.Clear; -end; -{--------} -function TffSqlSimpleExpressionList.DependsOn( - Table: TFFSqlTableProxy): Boolean; -var - i : Integer; -begin - for i := 0 to pred(ExpressionCount) do - if Expression[i].DependsOn(Table) then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -destructor TffSqlSimpleExpressionList.Destroy; -begin - Clear; - FExpressionList.Free; - inherited; -end; -{--------} -procedure TffSqlSimpleExpressionList.EmitSQL(Stream: TStream); -var - i : Integer; -begin - Expression[0].EmitSQL(Stream); - for i := 1 to pred(ExpressionCount) do begin - WriteStr(Stream,', '); - Expression[i].EmitSQL(Stream); - end; -end; -{--------} -procedure TffSqlSimpleExpressionList.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -var - i : Integer; -begin - EnumMethod(Self); - for i := 0 to pred(ExpressionCount) do - Expression[i].EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlSimpleExpressionList.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if Other is TffSqlSimpleExpressionList then begin - if ExpressionCount <> TffSqlSimpleExpressionList(Other).ExpressionCount then - exit; - for i := 0 to pred(ExpressionCount) do - if not Expression[i].Equals(TffSqlSimpleExpressionList(Other).Expression[i]) then - exit; - Result := True; - end; -end; -{--------} -function TffSqlSimpleExpressionList.GetExpression( - Index: Integer): TffSqlSimpleExpression; -begin - Result := TffSqlSimpleExpression(FExpressionList[Index]); -end; -{--------} -function TffSqlSimpleExpressionList.GetExpressionCount: Integer; -begin - Result := FExpressionList.Count; -end; -{--------} -function TffSqlSimpleExpressionList.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; - -procedure TffSqlSimpleExpressionList.MatchType(ExpectedType: TffFieldType); -var - i : Integer; -begin - for i := 0 to pred(ExpressionCount) do - Expression[i].MatchType(ExpectedType); -end; -{--------} -function TffSqlSimpleExpressionList.Reduce: Boolean; -var - I : integer; -begin - for i := 0 to pred(ExpressionCount) do - if Expression[i].Reduce then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -procedure TffSqlSimpleExpressionList.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; - -procedure TffSqlSimpleExpressionList.SetExpression(Index: Integer; - const Value: TffSqlSimpleExpression); -begin - FExpressionList[Index] := Value; -end; -{====================================================================} - -{===TffSqlOrderColumn================================================} -procedure TffSqlOrderColumn.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlOrderColumn then begin - TableName := TffSqlOrderColumn(Source).TableName; - FieldName := TffSqlOrderColumn(Source).FieldName; - end else - AssignError(Source); -end; -{--------} -procedure TffSqlOrderColumn.EmitSQL(Stream: TStream); -begin - WriteStr(Stream, ' '); - if TableName <> '' then begin - WriteStr(Stream, TableName); - WriteStr(Stream, '.'); - end; - WriteStr(Stream, FieldName); -end; -{--------} -procedure TffSqlOrderColumn.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); -end; -{--------} -function TffSqlOrderColumn.Equals(Other: TffSqlNode): Boolean; -begin - Result := Other is TffSqlOrderColumn - and (AnsiCompareText(TableName, TffSqlOrderColumn(Other).TableName) = 0) - and (AnsiCompareText(FieldName, TffSqlOrderColumn(Other).FieldName) = 0); -end; -{--------} -function TffSqlOrderColumn.QualColumnName : string; -begin - if TableName <> '' then - Result := TableName + '.' + FieldName - else - Result := FieldName; -end; -{====================================================================} - -{===TffSqlGroupColumn================================================} -procedure TffSqlGroupColumn.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlGroupColumn then begin - TableName := TffSqlGroupColumn(Source).TableName; - FieldName := TffSqlGroupColumn(Source).FieldName; - end else - AssignError(Source); -end; -{--------} -procedure TffSqlGroupColumn.EmitSQL(Stream: TStream); -begin - WriteStr(Stream, ' '); - if TableName <> '' then begin - WriteStr(Stream, TableName); - WriteStr(Stream, '.'); - end; - WriteStr(Stream, FieldName); -end; -{--------} -procedure TffSqlGroupColumn.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); -end; -{--------} -function TffSqlGroupColumn.Equals(Other: TffSqlNode): Boolean; -begin - Result := Other is TffSqlGroupColumn - and (AnsiCompareText(TableName, TffSqlGroupColumn(Other).TableName) = 0) - and (AnsiCompareText(FieldName, TffSqlGroupColumn(Other).FieldName) = 0); -end; -{--------} -function TffSqlGroupColumn.QualColumnName: string; -var - F : TffSqlFieldProxy; - Name : string; -begin - if OwnerSelect = nil then - SQLError('Field references may not occur in this context'); - if TableName <> '' then begin - Name := OwnerSelect.TableRefList.GetNameForAlias(FTableName); - if Name <> '' then - Result := Name + '.' + FFieldName - else - Result := TableName + '.' + FFieldName; - end - else begin - { If this is an alias for a field in the selection list then return - the name. } - if OwnerSelect.Columns.IndexOf(FieldName) > -1 then - Result := FieldName - else begin - { Find the proxy for this field. } - F := OwnerSelect.FindField(FFieldName); - if F = nil then - Result := FFieldName - else - Result := F.OwnerTable.Name + '.' + FFieldName; - end; - end; -end; -{====================================================================} - -{===TffSqlOrderItem==================================================} -procedure TffSqlOrderItem.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlOrderItem then begin - if TffSqlOrderItem(Source).Column <> nil then begin - if Column = nil then - Column := TffSqlOrderColumn.Create(Self); - Column.Assign(TffSqlOrderItem(Source).Column); - end; - Index := TffSqlOrderItem(Source).Index; - Descending := TffSqlOrderItem(Source).Descending; - end else - AssignError(Source); -end; - -constructor TffSqlOrderItem.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); -end; - -destructor TffSqlOrderItem.Destroy; -begin - Column.Free; - inherited; -end; - -procedure TffSqlOrderItem.EmitSQL(Stream: TStream); -begin - if Column <> nil then - Column.EmitSQL(Stream) - else begin - WriteStr(Stream, ' '); - WriteStr(Stream, Index); - end; - if Descending then - WriteStr(Stream,' DESC') - else - Writestr(Stream,' ASC'); -end; -{--------} -procedure TffSqlOrderItem.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - if Column <> nil then - Column.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlOrderItem.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlOrderItem) - and (Descending = TffSqlOrderItem(Other).Descending) - and (Index = TffSqlOrderItem(Other).Index) - and (BothNil(Column, TffSqlOrderItem(Other).Column) - or (BothNonNil(Column, TffSqlOrderItem(Other).Column) - and Column.Equals(TffSqlOrderItem(Other).Column) - )); -end; -{--------} -{====================================================================} - -{===TffSqlOrderList==================================================} -function TffSqlOrderList.AddOrderItem(NewOrder: TffSqlOrderItem): TffSqlOrderItem; -begin - FOrderItemList.Add(NewOrder); - Result := NewOrder; -end; -{--------} -procedure TffSqlOrderList.Assign(const Source: TffSqlNode); -var - i: Integer; -begin - if Source is TffSqlOrderList then begin - Clear; - for i := 0 to pred(TffSqlOrderList(Source).OrderCount) do - AddOrderItem(TffSqlOrderItem.Create(Self)).Assign( - TffSqlOrderList(Source).OrderItem[i]); - end else - AssignError(Source); -end; - -constructor TffSqlOrderList.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); - FOrderItemList := TList.Create; -end; -{--------} -procedure TffSqlOrderList.Clear; -var - i : Integer; -begin - for i := 0 to pred(FOrderItemList.Count) do - OrderItem[i].Free; - FOrderItemList.Clear; -end; -{--------} -destructor TffSqlOrderList.Destroy; -begin - Clear; - FOrderItemList.Free; - inherited; -end; -{--------} -procedure TffSqlOrderList.EmitSQL(Stream: TStream); -var - i : Integer; -begin - WriteStr(Stream,' ORDER BY'); - OrderItem[0].EmitSQL(Stream); - for i := 1 to pred(OrderCount) do begin - WriteStr(Stream,', '); - OrderItem[i].EmitSQL(Stream); - end; -end; -{--------} -procedure TffSqlOrderList.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -var - i : Integer; -begin - EnumMethod(Self); - for i := 0 to pred(OrderCount) do - OrderItem[i].EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlOrderList.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if Other is TffSqlOrderList then begin - if OrderCount <> TffSqlOrderList(Other).OrderCount then - exit; - for i := 0 to pred(OrderCount) do - if not OrderItem[i].Equals(TffSqlOrderList(Other).OrderItem[i]) then - exit; - Result := True; - end; -end; -{--------} -function TffSqlOrderList.GetOrderCount: Integer; -begin - Result := FOrderItemList.Count; -end; -{--------} -function TffSqlOrderList.GetOrderItem( - Index: Integer): TffSqlOrderItem; -begin - Result := TffSqlOrderItem(FOrderItemList[Index]); -end; -{--------} -function TffSqlOrderList.Reduce: Boolean; -begin - Result := False; -end; - -procedure TffSqlOrderList.SetOrderItem(Index: Integer; - const Value: TffSqlOrderItem); -begin - FOrderItemList[Index] := Value; -end; -{====================================================================} - -{===TffSqlAllOrAnyClause=============================================} -procedure TffSqlAllOrAnyClause.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlAllOrAnyClause then begin - All := TffSqlAllOrAnyClause(Source).All; - SubQuery.Free; - SubQuery := TffSqlSELECT.Create(Self); - SubQuery.Assign(TffSqlAllOrAnyClause(Source).SubQuery); - end else - AssignError(Source); -end; - -function TffSqlAllOrAnyClause.Compare(RelOp: TffSqlRelOp; - const Val: Variant): Boolean; -begin - if All then - Result := SubQuery.CheckAllValues(RelOp, Val) - else - Result := SubQuery.CheckAnyValue(RelOp, Val); -end; - -function TffSqlAllOrAnyClause.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - Result := SubQuery.DependsOn(Table); -end; - -destructor TffSqlAllOrAnyClause.Destroy; -begin - SubQuery.Free; - inherited; -end; -{--------} -procedure TffSqlAllOrAnyClause.EmitSQL(Stream: TStream); -begin - if All then - WriteStr(Stream,' ALL ') - else - WriteStr(Stream,' ANY '); - WriteStr(Stream,'('); - SubQuery.EmitSQL(Stream); - WriteStr(Stream,')'); -end; -{--------} -procedure TffSqlAllOrAnyClause.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - SubQuery.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlAllOrAnyClause.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlAllOrAnyClause) - and (All = TffSqlAllOrAnyClause(Other).All) - and (SubQuery.Equals(TffSqlAllOrAnyClause(Other).SubQuery)); -end; -{--------} -procedure TffSqlAllOrAnyClause.MatchType(ExpectedType: TffFieldType); -begin - SubQuery.MatchType(ExpectedType, True); -end; - -function TffSqlAllOrAnyClause.Reduce: Boolean; -begin - Result := SubQuery.Reduce; -end; - -{====================================================================} - -{===TffSqlExistsClause===============================================} -function TffSqlExistsClause.AsBoolean: Boolean; -begin - Result := SubQuery.CheckNonEmpty; -end; -{--------} -procedure TffSqlExistsClause.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlExistsClause then begin - SubQuery.Free; - SubQuery := TffSqlSELECT.Create(Self); - SubQuery.Assign(TffSqlExistsClause(Source).SubQuery); - end else - AssignError(Source); -end; - -function TffSqlExistsClause.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - Result := SubQuery.DependsOn(Table); -end; - -destructor TffSqlExistsClause.Destroy; -begin - SubQuery.Free; - inherited; -end; -{--------} -procedure TffSqlExistsClause.EmitSQL(Stream: TStream); -begin - WriteStr(Stream,' EXISTS ('); - SubQuery.EmitSQL(Stream); - WriteStr(Stream,')'); -end; -{--------} -procedure TffSqlExistsClause.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - SubQuery.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlExistsClause.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlExistsClause) - and (SubQuery.Equals(TffSqlExistsClause(Other).SubQuery)); -end; -{--------} -function TffSqlExistsClause.Reduce: Boolean; -begin - Result := SubQuery.Reduce; -end; - -{====================================================================} - -{===TffSqlUniqueClause===============================================} -function TffSqlUniqueClause.AsBoolean: Boolean; -begin - Result := SubQuery.CheckNoDups; -end; -{--------} -procedure TffSqlUniqueClause.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlUniqueClause then begin - SubQuery.Free; - SubQuery := TffSqlTableExp.Create(Self); - SubQuery.Assign(TffSqlUniqueClause(Source).SubQuery); - end else - AssignError(Source); -end; - -function TffSqlUniqueClause.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - Result := SubQuery.DependsOn(Table); -end; - -destructor TffSqlUniqueClause.Destroy; -begin - SubQuery.Free; - inherited; -end; -{--------} -procedure TffSqlUniqueClause.EmitSQL(Stream: TStream); -begin - WriteStr(Stream,' UNIQUE ('); - SubQuery.EmitSQL(Stream); - WriteStr(Stream,')'); -end; -{--------} -procedure TffSqlUniqueClause.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - SubQuery.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlUniqueClause.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlUniqueClause) - and (SubQuery.Equals(TffSqlUniqueClause(Other).SubQuery)); -end; -{--------} -function TffSqlUniqueClause.Reduce: Boolean; -begin - Result := SubQuery.Reduce; -end; - -{====================================================================} - -function OffsetTime(const DateTime: TDateTime; DeltaH, DeltaM, DeltaS: Integer): TDateTime; -var - Mi, H, S, MSec : Word; - Hs, Mis, Ss : Integer; - DeltaD : Integer; -begin - DecodeTime(DateTime, H, Mi, S, MSec); - Hs := H; - Mis := Mi; - Ss := S; - Ss := Ss + (DeltaS mod 60); - Mis := Mis + (DeltaS div 60); - if Ss < 0 then begin - dec(Mis); - inc(Ss, 60); - end else - if Ss >= 60 then begin - inc(Mis); - dec(Ss, 60); - end; - Mis := Mis + (DeltaM mod 60); - Hs := Hs + (DeltaM div 60); - if Mis < 0 then begin - dec(Hs); - inc(Mis, 60); - end else - if Mis >= 60 then begin - inc(Hs); - dec(Mis, 60); - end; - Hs := Hs + (DeltaH mod 24); - DeltaD := (DeltaH div 24); - if Hs < 0 then begin - dec(DeltaD); - inc(Hs, 24); - end else - if Hs >= 24 then begin - inc(DeltaD); - dec(Hs, 24); - end; - Result := Round(DateTime) + EncodeTime(Hs, Mis, Ss, MSec) + DeltaD; -end; - -{===TffSqlIntervalLiteral============================================} -function TffSqlIntervalLiteral.AddIntervalTo(Target: TDateTime): TDateTime; -begin - if not Converted then - ConvertToNative; - case StartDef of - iYear : - case EndDef of - iUnspec : - Result := IncMonth(Target, Y1 * 12); - else //iMonth : - Result := IncMonth(Target, Y1 * 12 + M1); - end; - iMonth : - Result := IncMonth(Target, M1); - iDay : - case EndDef of - iUnspec : - Result := Target + D1; - iHour : - Result := OffsetTime(Target, H1, 0, 0) + D1; - iMinute : - Result := OffsetTime(Target, H1, M1, 0) + D1; - else//iSecond : - Result := OffsetTime(Target, H1, M1, S1) + D1; - end; - iHour : - case EndDef of - iUnspec : - Result := OffsetTime(Target, H1, 0, 0); - iMinute : - Result := OffsetTime(Target, H1, M1, 0); - else//iSecond : - Result := OffsetTime(Target, H1, M1, S1); - end; - iMinute : - case EndDef of - iUnspec : - Result := OffsetTime(Target, 0, M1, 0); - else//iSecond : - Result := OffsetTime(Target, 0, M1, S1); - end; - else //iSecond : - Result := OffsetTime(Target, 0, 0, S1); - end; -end; -{--------} -function TffSqlIntervalLiteral.SubtractIntervalFrom(Target: TDateTime): TDateTime; -begin - if not Converted then - ConvertToNative; - case StartDef of - iYear : - case EndDef of - iUnspec : - Result := IncMonth(Target, -Y1 * 12); - else//iMonth : - Result := IncMonth(Target, -(Y1 * 12 + M1)); - end; - iMonth : - Result := IncMonth(Target, -M1); - iDay : - case EndDef of - iUnspec : - Result := Target - D1; - iHour : - Result := OffsetTime(Target, -H1, 0, 0) - D1; - iMinute : - Result := OffsetTime(Target, -H1, -M1, 0) - D1; - else//iSecond : - Result := OffsetTime(Target, -H1, -M1, -S1) - D1; - end; - iHour : - case EndDef of - iUnspec : - Result := OffsetTime(Target, -H1, 0, 0); - iMinute : - Result := OffsetTime(Target, -H1, -M1, 0); - else//iSecond : - Result := OffsetTime(Target, -H1, -M1, -S1); - end; - iMinute : - case EndDef of - iUnspec : - Result := OffsetTime(Target, 0, -M1, 0); - else//iSecond : - Result := OffsetTime(Target, 0, -M1, -S1); - end; - else//iSecond : - Result := OffsetTime(Target, 0, 0, -S1); - end; -end; -{--------} -procedure TffSqlIntervalLiteral.ConvertToNative; -var - S : string; - P : Integer; -begin - S := Value; - case StartDef of - iUnspec : - SQLError('Internal error in date/time interval literal'); - iYear : - case EndDef of - iUnspec : - Y1 := StrToInt(copy(S, 2, length(S) - 2)); - iYear : - SQLError('Syntax error in year-month interval literal'); - iMonth : - begin - P := PosCh('-', S); - if P = 0 then - SQLError('Syntax error in year-month interval literal: "-" expected'); - Y1 := StrToInt(copy(S, 2, P - 2)); - M1 := StrToInt(copy(S, P + 1, length(S) - P - 1)); - end; - else - SQLError('Syntax error in year-month interval literal'); - end; - iMonth : - case EndDef of - iUnspec : - M1 := StrToInt(copy(S, 2, length(S) - 2)); - else - SQLError('Syntax error in year-month interval literal'); - end; - iDay : - case EndDef of - iUnspec : - D1 := StrToInt(copy(S, 2, length(S) - 2)); - iHour : - begin - P := PosCh(' ', S); - if P = 0 then - SQLError('Syntax error in date-time interval literal: " " expected'); - D1 := StrToInt(copy(S, 2, P - 2)); - H1 := StrToInt(copy(S, P + 1, length(S) - P - 1)); - end; - iMinute : - begin - P := PosCh(' ', S); - if P = 0 then - SQLError('Syntax error in date-time interval literal: " " expected'); - D1 := StrToInt(copy(S, 2, P - 2)); - Delete(S, 2, P - 2); - P := PosCh(':', S); - if P = 0 then - SQLError('Syntax error in date-time interval literal: ":" expected'); - H1 := StrToInt(copy(S, 2, P - 2)); - M1 := StrToInt(copy(S, P + 1, length(S) - P - 1)); - end; - iSecond : - begin - P := PosCh(' ', S); - if P = 0 then - SQLError('Syntax error in date-time interval literal: " " expected'); - D1 := StrToInt(copy(S, 2, P - 2)); - Delete(S, 2, P - 1); - P := PosCh(':', S); - if P = 0 then - SQLError('Syntax error in date-time interval literal: ":" expected'); - H1 := StrToInt(copy(S, 2, P - 2)); - Delete(S, 2, P - 1); - P := PosCh(':', S); - if P = 0 then - SQLError('Syntax error in date-time interval literal: ":" expected'); - M1 := StrToInt(copy(S, 2, P - 2)); - S1 := StrToInt(copy(S, P + 1, length(S) - P - 1)); - end; - else - SQLError('Syntax error in date-time interval literal'); - end; - iHour : - case EndDef of - iUnspec : - H1 := StrToInt(copy(S, 2, length(S) - 2)); - iMinute : - begin - P := PosCh(':', S); - if P = 0 then - SQLError('Syntax error in date-time interval literal: ":" expected'); - H1 := StrToInt(copy(S, 2, P - 2)); - M1 := StrToInt(copy(S, P + 1, length(S) - P - 1)); - end; - iSecond : - begin - P := PosCh(':', S); - if P = 0 then - SQLError('Syntax error in date-time interval literal: ":" expected'); - H1 := StrToInt(copy(S, 2, P - 2)); - Delete(S, 2, P - 1); - P := PosCh(':', S); - if P = 0 then - SQLError('Syntax error in date-time interval literal: ":" expected'); - M1 := StrToInt(copy(S, 2, P - 2)); - S1 := StrToInt(copy(S, P + 1, length(S) - P - 1)); - end; - else - SQLError('Syntax error in date-time interval literal'); - end; - iMinute : - case EndDef of - iUnspec : - M1 := StrToInt(copy(S, 2, length(S) - 2)); - iSecond : - begin; - P := PosCh(':', S); - if P = 0 then - SQLError('Syntax error in date-time interval literal: ":" expected'); - M1 := StrToInt(copy(S, 2, P - 2)); - S1 := StrToInt(copy(S, P + 1, length(S) - P - 1)); - end; - else - SQLError('Syntax error in date-time interval literal'); - end; - iSecond : - case EndDef of - iUnspec : - S1 := StrToInt(copy(S, 2, length(S) - 2)); - else - SQLError('Syntax error in date-time interval literal'); - end; - else - SQLError('Syntax error in date-time interval literal'); - end; - Converted := True; -end; -{--------} -procedure TffSqlIntervalLiteral.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlIntervalLiteral then begin - Value := TffSqlIntervalLiteral(Source).Value; - StartDef := TffSqlIntervalLiteral(Source).StartDef; - EndDef := TffSqlIntervalLiteral(Source).EndDef; - end else - AssignError(Source); -end; - -procedure TffSqlIntervalLiteral.EmitSQL(Stream: TStream); -begin - WriteStr(Stream,' INTERVAL '); - WriteStr(Stream, Value); - WriteStr(Stream,' '); - WriteStr(Stream, DefStr[StartDef]); - if EndDef <> iUnspec then begin - WriteStr(Stream,' TO '); - WriteStr(Stream, DefStr[EndDef]); - end; -end; -{--------} -procedure TffSqlIntervalLiteral.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); -end; -{--------} -function TffSqlIntervalLiteral.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlIntervalLiteral) - and (AnsiCompareText(Value, TffSqlIntervalLiteral(Other).Value) = 0) - and (StartDef = TffSqlIntervalLiteral(Other).StartDef) - and (EndDef = TffSqlIntervalLiteral(Other).EndDef); -end; -{--------} -function TffSqlIntervalLiteral.GetType: TffFieldType; -begin - Result := fftInterval; -end; -{--------} -function TffSqlIntervalLiteral.GetValue: Variant; -begin - Result := ''; - {This value returned to allow tests for NULL to pass} -end; -{--------} -procedure TffSqlIntervalLiteral.MatchType(ExpectedType: TffFieldType); -begin - case ExpectedType of - fftStDate, - fftDateTime : - ; - else - TypeMismatch; - end; - if not Converted then - ConvertToNative; -end; -{====================================================================} - -{===TffSqlTimestampLiteral===========================================} -procedure TffSqlTimestampLiteral.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlTimeStampLiteral then begin - Value := TffSqlTimeStampLiteral(Source).Value; - end else - AssignError(Source); -end; - -procedure TffSqlTimeStampLiteral.ConvertToNative; -begin - if (length(Value) < 21) - or not (Value[6] in ['-', '.', '/']) - or (Value[9] <> Value[6]) - or (Value[12] <> ' ') - or (Value[15] <> ':') - or (Value[18] <> ':') then - SQLError('Syntax error in time stamp literal'); - DateTimeValue := - EncodeDate( - StrToInt(copy(Value, 2, 4)), - StrToInt(copy(Value, 7, 2)), - StrToInt(copy(Value, 10, 2))) - + - EncodeTime( - StrToInt(copy(Value, 13, 2)), - StrToInt(copy(Value, 16, 2)), - StrToInt(copy(Value, 19, 2)), - 0); - Converted := True; -end; - -procedure TffSqlTimestampLiteral.EmitSQL(Stream: TStream); -begin - WriteStr(Stream,' TIMESTAMP '); - WriteStr(Stream, Value); -end; -{--------} -procedure TffSqlTimestampLiteral.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); -end; -{--------} -function TffSqlTimestampLiteral.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlTimestampLiteral) - and (AnsiCompareText(Value, TffSqlTimestampLiteral(Other).Value) = 0); -end; -{--------} -function TffSqlTimestampLiteral.GetType: TffFieldType; -begin - Result := fftDateTime; -end; - -function TffSqlTimestampLiteral.GetValue: Variant; -begin - if not Converted then - ConvertToNative; - Result := DateTimeValue; -end; -{--------} -procedure TffSqlTimestampLiteral.MatchType(ExpectedType: TffFieldType); -begin - case ExpectedType of - fftStTime, - fftDateTime : - ; - else - TypeMismatch; - end; - if not Converted then - ConvertToNative; -end; -{====================================================================} - -{===TffSqlTimeLiteral================================================} -procedure TffSqlTimeLiteral.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlTimeLiteral then begin - Value := TffSqlTimeLiteral(Source).Value; - end else - AssignError(Source); -end; - -procedure TffSqlTimeLiteral.ConvertToNative; -begin - if (length(Value) <> 10) - or (Value[4] <> ':') - or (Value[7] <> ':') then - SQLError('Syntax error in time literal'); - TimeValue := EncodeTime( - StrToInt(copy(Value, 2, 2)), - StrToInt(copy(Value, 5, 2)), - StrToInt(copy(Value, 8, 2)), - 0); - Converted := True; -end; -{--------} -procedure TffSqlTimeLiteral.EmitSQL(Stream: TStream); -begin - WriteStr(Stream,' TIME '); - WriteStr(Stream, Value); -end; -{--------} -procedure TffSqlTimeLiteral.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); -end; -{--------} -function TffSqlTimeLiteral.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlTimeLiteral) - and (AnsiCompareText(Value, TffSqlTimeLiteral(Other).Value) = 0); -end; -{--------} -function TffSqlTimeLiteral.GetType: TffFieldType; -begin - Result := fftStTime; -end; - -function TffSqlTimeLiteral.GetValue: Variant; -begin - if not Converted then - ConvertToNative; - Result := TimeValue; -end; -{--------} -procedure TffSqlTimeLiteral.MatchType(ExpectedType: TffFieldType); -begin - case ExpectedType of - fftStTime, - fftDateTime : - ; - else - TypeMismatch; - end; - if not Converted then - ConvertToNative; -end; -{====================================================================} - -{===TffSqlDateLiteral================================================} -{--------} -procedure TffSqlDateLiteral.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlDateLiteral then begin - Value := TffSqlDateLiteral(Source).Value; - end else - AssignError(Source); -end; - -procedure TffSqlDateLiteral.ConvertToNative; -begin - if (length(Value) <> 12) - or not (Value[6] in ['-', '.', '/']) - or (Value[9] <> Value[6]) then - SQLError('Syntax error in date literal'); - DateValue := EncodeDate( - StrToInt(copy(Value, 2, 4)), - StrToInt(copy(Value, 7, 2)), - StrToInt(copy(Value, 10, 2))); - Converted := True; -end; -{--------} -procedure TffSqlDateLiteral.EmitSQL(Stream: TStream); -begin - WriteStr(Stream,' DATE '); - WriteStr(Stream, Value); -end; -{--------} -procedure TffSqlDateLiteral.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); -end; -{--------} -function TffSqlDateLiteral.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlDateLiteral) - and (AnsiCompareText(Value, TffSqlDateLiteral(Other).Value) = 0); -end; -{--------} -function TffSqlDateLiteral.GetType: TffFieldType; -begin - Result := fftStDate; -end; - -function TffSqlDateLiteral.GetValue: Variant; -begin - if not Converted then - ConvertToNative; - Result := DateValue; -end; -{--------} -procedure TffSqlDateLiteral.MatchType(ExpectedType: TffFieldType); -begin - case ExpectedType of - fftStDate, - fftDateTime : - ; - else - TypeMismatch; - end; - if not Converted then - ConvertToNative; -end; -{===TffSqlBooleanLiteral================================================} -{--------} -procedure TffSqlBooleanLiteral.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlBooleanLiteral then begin - Value := TffSqlBooleanLiteral(Source).Value; - end else - AssignError(Source); -end; - -{--------} -procedure TffSqlBooleanLiteral.EmitSQL(Stream: TStream); -begin - if Value then - WriteStr(Stream, ' TRUE') - else - WriteStr(Stream, ' FALSE'); -end; -{--------} -procedure TffSqlBooleanLiteral.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); -end; -{--------} -function TffSqlBooleanLiteral.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlBooleanLiteral) - and (Value = TffSqlBooleanLiteral(Other).Value); -end; -{--------} -function TffSqlBooleanLiteral.GetType: TffFieldType; -begin - Result := fftBoolean; -end; - -function TffSqlBooleanLiteral.GetValue: Boolean; -begin - Result := Value; -end; -{--------} -procedure TffSqlBooleanLiteral.MatchType(ExpectedType: TffFieldType); -begin - case ExpectedType of - fftBoolean : ; - else - TypeMismatch; - end; -end; -{====================================================================} - -const - FuncStr : array[TffSqlScalarFunction] of string = ( - 'CASE', 'CHARACTER_LENGTH','COALESCE', 'CURRENT_DATE','CURRENT_TIME','CURRENT_TIMESTAMP', - 'CURRENT_USER','LOWER','UPPER','POSITION','SESSION_USER','SUBSTRING', - 'SYSTEM_USER','TRIM','EXTRACT', 'NULLIF', - 'ABS', 'CEIL', 'FLOOR', 'EXP', 'LOG', 'POWER', 'RAND', 'ROUND'); {!!.11} - LeadStr : array[TffSqlLTB] of string = ('BOTH', 'LEADING', 'TRAILING'); -{===TffSqlScalarFunc=================================================} -procedure TffSqlScalarFunc.CheckIsConstant; -begin - FIsConstantChecked := True; - case SQLFunction of - sfCase : - FIsConstant := CaseExp.IsConstant; - sfCharlen : - FIsConstant := Arg1.IsConstant; - sfCoalesce : - FIsConstant := False; - sfCurrentDate : - FIsConstant := True; - sfCurrentTime : - FIsConstant := True; - sfCurrentTimestamp : - FIsConstant := True; - sfCurrentUser : - FIsConstant := True; - sfLower : - FIsConstant := Arg1.IsConstant; - sfUpper : - FIsConstant := Arg1.IsConstant; - sfPosition : - FIsConstant := Arg2.IsConstant and Arg1.IsConstant; - sfSessionUser : - FIsConstant := True; - sfSubstring : - FIsConstant := - Arg1.IsConstant and Arg2.IsConstant and - ((Arg3 = nil) or (Arg3.IsConstant)); - sfSystemUser : - FIsConstant := True; - sfTrim : - FIsConstant := - ((Arg1 = nil) or (Arg1.IsConstant)) - and ((Arg2 = nil) or (Arg2.IsConstant)); - sfExtract : - FIsConstant := Arg1.IsConstant; - sfNullIf : - FIsConstant := Arg2.IsConstant and Arg1.IsConstant; - {!!.11 begin} - sfAbs, sfCeil, sfFloor, sfExp, sfLog, sfRound : - FIsConstant := Arg1.IsConstant; - sfRand : - FIsConstant := False; - sfPower : - FIsConstant := Arg2.IsConstant and Arg1.IsConstant; - {!!.11 end} - else - Assert(False); - end; - if FIsConstant then begin - FIsConstant := False; - ConstantValue := GetValue; - FIsConstant := True; - end; -end; - -procedure TffSqlScalarFunc.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlScalarFunc then begin - Clear; - SQLFunction := TffSqlScalarFunc(Source).SQLFunction; - if assigned(TffSqlScalarFunc(Source).Arg1) then begin - Arg1 := TffSqlSimpleExpression.Create(Self); - Arg1.Assign(TffSqlScalarFunc(Source).Arg1); - end; - if assigned(TffSqlScalarFunc(Source).Arg2) then begin - Arg2 := TffSqlSimpleExpression.Create(Self); - Arg2.Assign(TffSqlScalarFunc(Source).Arg2); - end; - if assigned(TffSqlScalarFunc(Source).Arg3) then begin - Arg3 := TffSqlSimpleExpression.Create(Self); - Arg3.Assign(TffSqlScalarFunc(Source).Arg3); - end; - LTB := TffSqlScalarFunc(Source).LTB; - XDef := TffSqlScalarFunc(Source).XDef; - if assigned(TffSqlScalarFunc(Source).CaseExp) then begin - CaseExp := TffSqlCaseExpression.Create(Self); - CaseExp.Assign(TffSqlScalarFunc(Source).CaseExp); - end; - if assigned(TffSqlScalarFunc(Source).CoalesceExp) then begin - CoalesceExp := TffSqlCoalesceExpression.Create(Self); - CoalesceExp.Assign(TffSqlScalarFunc(Source).CoalesceExp); - end; - end else - AssignError(Source); -end; - -procedure TffSqlScalarFunc.Clear; -begin - CaseExp.Free; - CoalesceExp.Free; - Arg1.Free; - Arg2.Free; - Arg3.Free; - CaseExp:= nil; - CoalesceExp:= nil; - Arg1:= nil; - Arg2:= nil; - Arg3:= nil; -end; - -function TffSqlScalarFunc.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - case SQLFunction of - sfCase : - Result := CaseExp.DependsOn(Table); - sfCharlen, - sfLower, - sfUpper, - sfExtract : - Result := Arg1.DependsOn(Table); - sfCoalesce : - Result := CoalesceExp.DependsOn(Table); - sfSystemUser, - sfCurrentDate, - sfCurrentTime, - sfCurrentTimestamp, - sfCurrentUser, - sfSessionUser : - Result := False; - sfPosition : - Result := Arg2.DependsOn(Table) or Arg1.DependsOn(Table); - sfSubstring : - begin - Result := Arg1.DependsOn(Table) or Arg2.DependsOn(Table); - if not Result and (Arg3 <> nil) then - Result := Arg3.DependsOn(Table); - end; - sfTrim : - begin - if Arg2 = nil then - Result := Arg1.DependsOn(Table) - else - Result := Arg1.DependsOn(Table) or Arg2.DependsOn(Table) - end; - sfNullIf : - begin - Result := Arg1.DependsOn(Table) or Arg2.DependsOn(Table); - end; - {!!.11 begin} - sfAbs, sfCeil, sfFloor, sfExp, sfLog, sfRound : - Result := Arg1.DependsOn(Table) ; - sfRand : - Result := False; - sfPower : - Result := Arg1.DependsOn(Table) or Arg2.DependsOn(Table); - {!!.11 end} - else - Assert(False); - Result := False; - end; -end; - -destructor TffSqlScalarFunc.Destroy; -begin - Clear; - inherited; -end; - -procedure TffSqlScalarFunc.EmitSQL(Stream: TStream); -begin - WriteStr(Stream, ' '); - case SQLFunction of - sfCase : - CaseExp.EmitSQL(Stream); - sfCoalesce : - CoalesceExp.EmitSQL(Stream); - sfCurrentDate, - sfCurrentTime, - sfCurrentTimestamp, - sfCurrentUser, - sfSessionUser, - sfSystemUser, - sfRand : {!!.11} - WriteStr(Stream, FuncStr[SQLFunction]); - else - WriteStr(Stream, FuncStr[SQLFunction]); - WriteStr(Stream,'('); - case SQLFunction of - sfCharlen, - sfLower, - sfUpper, - sfAbs, sfCeil, sfFloor, sfExp, sfLog, sfRound : {!!.11} - begin - Arg1.EmitSQL(Stream); - end; - sfNullIf, - sfPosition, - sfPower : {!!.11} - begin - Arg1.EmitSQL(Stream); - WriteStr(Stream,' , '); - Arg2.EmitSQL(Stream); - end; - sfSubstring : - begin - Arg1.EmitSQL(Stream); - WriteStr(Stream,' FROM '); - Arg2.EmitSQL(Stream); - if Arg3 <> nil then begin - WriteStr(Stream,' FOR '); - Arg3.EmitSQL(Stream); - end; - end; - sfTrim : - begin - WriteStr(Stream, LeadStr[LTB]); - WriteStr(Stream, ' '); - if Arg1 <> nil then - Arg1.EmitSQL(Stream); - if Arg2 <> nil then begin - WriteStr(Stream,' FROM '); - Arg2.EmitSQL(Stream); - end; - end; - sfExtract : - begin - WriteStr(Stream, DefStr[XDef]); - WriteStr(Stream,' FROM '); - Arg1.EmitSQL(Stream); - end; - end; - WriteStr(Stream,')'); - end; -end; -{--------} -procedure TffSqlScalarFunc.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - case SQLFunction of - sfCase : - CaseExp.EnumNodes(EnumMethod, Deep); - sfCoalesce : - CoalesceExp.EnumNodes(EnumMethod, Deep); - sfCurrentDate, - sfCurrentTime, - sfCurrentTimestamp, - sfCurrentUser, - sfSessionUser, - sfSystemUser, - sfRand : {!!.11} - ; - else - case SQLFunction of - sfCharlen, - sfLower, - sfUpper, - sfExtract, - sfAbs, sfCeil, sfFloor, sfExp, sfLog, sfRound : {!!.11} - Arg1.EnumNodes(EnumMethod, Deep); - sfNullIf, - sfPosition, - sfPower : {!!.11} - begin - Arg1.EnumNodes(EnumMethod, Deep); - Arg2.EnumNodes(EnumMethod, Deep); - end; - sfSubstring : - begin - Arg1.EnumNodes(EnumMethod, Deep); - Arg2.EnumNodes(EnumMethod, Deep); - if Arg3 <> nil then - Arg3.EnumNodes(EnumMethod, Deep); - end; - sfTrim : - begin - if Arg1 <> nil then - Arg1.EnumNodes(EnumMethod, Deep); - if Arg2 <> nil then - Arg2.EnumNodes(EnumMethod, Deep); - end; - end; - end; -end; -{--------} -function TffSqlScalarFunc.Equals(Other: TffSqlNode): Boolean; -begin - Result := False; - if Other is TffSqlScalarFunc then begin - if SQLFunction <> TffSqlScalarFunc(Other).SQLFunction then - exit; - case SQLFunction of - sfCase : - if not CaseExp.Equals(TffSqlScalarFunc(Other).CaseExp) then - exit; - sfCoalesce : - if not CoalesceExp.Equals(TffSqlScalarFunc(Other).CoalesceExp) then - exit; - sfCharlen, - sfLower, - sfUpper, - sfExtract, - sfAbs, sfCeil, sfFloor, sfExp, sfLog, sfRound : {!!.11} - if not Arg1.Equals(TffSqlScalarFunc(Other).Arg1) then - exit; - sfNullIf, - sfPosition, - sfPower : {!!.11} - begin - if not Arg1.Equals(TffSqlScalarFunc(Other).Arg1) then - exit; - if not Arg2.Equals(TffSqlScalarFunc(Other).Arg2) then - exit; - end; - sfSubstring : - begin - if not Arg1.Equals(TffSqlScalarFunc(Other).Arg1) then - exit; - if not Arg2.Equals(TffSqlScalarFunc(Other).Arg2) then - exit; - if not ( - BothNil(Arg3, TffSqlScalarFunc(Other).Arg3) - or (BothNonNil(Arg3, TffSqlScalarFunc(Other).Arg3) - and Arg3.Equals(TffSqlScalarFunc(Other).Arg3))) then - exit; - end; - sfTrim : - begin - if not ( - BothNil(Arg1, TffSqlScalarFunc(Other).Arg1) - or (BothNonNil(Arg1, TffSqlScalarFunc(Other).Arg1) - and Arg1.Equals(TffSqlScalarFunc(Other).Arg1))) then - exit; - if not ( - BothNil(Arg2, TffSqlScalarFunc(Other).Arg2) - or (BothNonNil(Arg2, TffSqlScalarFunc(Other).Arg2) - and Arg2.Equals(TffSqlScalarFunc(Other).Arg2))) then - exit; - end; - end; - Result := True; - end; -end; -{--------} -function TffSqlScalarFunc.GetDecimals: Integer; -begin - Result := 0; -end; -{--------} -function TffSqlScalarFunc.GetSize: Integer; -var - S : string; -begin - {should only be called on text functions} - case SQLFunction of - sfCase : - Result := CaseExp.GetSize; - sfLower, - sfUpper, - sfSubstring : - Result := Arg1.GetSize; - sfTrim : - if Arg2 = nil then - Result := Arg1.GetSize - else - Result := Arg2.GetSize; - sfCoalesce : - Result := CoalesceExp.GetSize; - sfCurrentUser, - sfSystemUser, - sfSessionUser : - begin - S := GetValue; - Result := length(S); - end; - sfNullIf : - Result := Arg1.GetSize; - else - Result := 0; - end; -end; -{--------} -function TffSqlScalarFunc.GetTitle(const Qualified : Boolean): string; {!!.11} -begin - Result := FuncStr[SQLFunction]; -end; -{--------} -procedure TffSqlScalarFunc.CheckType; -begin - case SQLFunction of - sfCase : - FType := CaseExp.GetType; - sfCharlen : - begin - Arg1.MatchType(fftShortString); - FType := fftInt32; - end; - sfCoalesce : - FType := CoalesceExp.GetType; - sfCurrentDate : - FType := fftStDate; - sfCurrentTime : - FType := fftStTime; - sfCurrentTimestamp : - FType := fftDateTime; - sfCurrentUser : - FType := fftShortAnsiStr; - sfLower : - begin - Arg1.MatchType(fftShortString); - FType := fftShortAnsiStr; - end; - sfUpper : - begin - Arg1.MatchType(fftShortString); - FType := fftShortAnsiStr; - end; - sfPosition : - begin - Arg1.MatchType(fftShortString); - Arg2.MatchType(fftShortString); - FType := fftInt32; - end; - sfSessionUser : - FType := fftShortAnsiStr; - sfSubstring : - begin - Arg1.MatchType(fftShortString); - Arg2.MatchType(fftInt32); - if Arg3 <> nil then - Arg3.MatchType(fftInt32); - FType := fftShortAnsiStr; - end; - sfSystemUser : - FType := fftShortAnsiStr; - sfTrim : - begin - if Arg1 <> nil then - Arg1.MatchType(fftShortString); - if Arg2 <> nil then - Arg2.MatchType(fftShortString); - FType := fftShortAnsiStr; - end; - sfExtract : - begin - Arg1.MatchType(fftDateTime); - FType := fftInt32; - end; - sfNullIf : - FType := Arg1.GetType; - {!!.11 begin} - sfAbs, {sfCeil, sfFloor, }sfExp, sfLog, sfRound, sfRand, sfPower : {!!.12} - FType := fftDouble; - {!!.11 end} - sfCeil, sfFloor: {!!.12} - case Arg1.GetType of {!!.12} - fftStDate..fftDateTime : {!!.12} - FType := Arg1.GetType; {!!.12} - else {!!.12} - FType := fftDouble; {!!.12} - end; {!!.12} - else - Assert(False); - end; - TypeKnown := True; -end; -{--------} -function TffSqlScalarFunc.GetType: TffFieldType; -begin - if not TypeKnown then - CheckType; - Result := FType; -end; -{Begin !!.13} -{--------} -function ConvertBLOBToString(const Value : Variant) : string; - { Converts a BLOB value to a string value. - Assumption: Value is always a var array of byte } -var - ResultLen : Longint; - VPtr : PAnsiChar; -begin - ResultLen := VarArrayHighBound(Value, 1); - SetLength(Result, ResultLen); - VPtr := VarArrayLock(Value); - try - Move(VPtr^, Result[1], ResultLen); - finally - VarArrayUnlock(Value); - end; -end; -{End !!.13} -{--------} -function TffSqlScalarFunc.GetValue: Variant; -{Revised !!.13 - Scalar functions updated to recognize BLOB fields as - arrays of bytes instead of as strings. } -var - S : string; - WS, WS2 : widestring; {!!.11} - I1, I2 : Integer; - Y, M, D : Word; - Hour, Min, Sec, MSec : Word; - Ch : Char; - DT : TDateTime; - V, V2 : Variant; {!!.11} -begin - if IsConstant then begin - Result := ConstantValue; - exit; - end; - case SQLFunction of - sfCase : - Result := CaseExp.GetValue; - sfCharlen : - begin - V := Arg1.GetValue; - if VarIsNull(V) then - Result := V - else if (VarType(V) and VarTypeMask = varByte) then - Result := VarArrayHighBound(V, 1) - else - Result := length(V); - end; - sfCoalesce : - Result := CoalesceExp.GetValue; - sfCurrentDate : - Result := Owner.StartDate; - sfCurrentTime : - Result := Owner.StartTime; - sfCurrentTimestamp : - Result := Owner.StartDateTime; - sfCurrentUser : - Result := IntToStr(Owner.FClientID); - sfLower : - begin - V := Arg1.GetValue; - if VarIsNull(V) then - Result := V - else if (VarType(V) and VarTypeMask = varByte) then - Result := AnsiLowerCase(ConvertBLOBToString(V)) - else - Result := AnsiLowerCase(V); - end; - sfUpper : - begin - V := Arg1.GetValue; - if VarIsNull(V) then - Result := V - else if (VarType(V) and VarTypeMask = varByte) then - Result := AnsiUpperCase(ConvertBLOBToString(V)) - else - Result := AnsiUpperCase(V); - end; - sfPosition : - begin - V := Arg1.GetValue; - V2 := Arg2.GetValue; - if VarIsNull(V) or VarIsNull(V2) then - Result := 0 - else begin - WS := V; - if WS = '' then - Result := 1 - else begin - if (VarType(V2) and VarTypeMask = varByte) then - WS2 := ConvertBLOBToString(V2) - else - WS2 := V2; - Result := Pos(WS, WS2); - end; { if } - end; { if } - end; - sfSessionUser : - Result := IntToStr(Owner.FSessionID); - sfSubstring : - begin - V := Arg1.GetValue; - if VarIsNull(V) then - Result := V - else begin - if (VarType(V) and VarTypeMask = varByte) then - S := ConvertBLOBToString(V) - else - S := V; - I1 := Arg2.GetValue; - if Arg3 = nil then - Result := copy(S, I1, length(S)) - else begin - I2 := Arg3.GetValue; - Result := copy(S, I1, I2); - end; - end; - end; - sfSystemUser : - SQLError('SYSTEM_USER is not supported at this time'); - sfTrim : - begin - if Arg2 = nil then begin - V := Arg1.GetValue; - if VarIsNull(V) then begin - Result := V; - Exit; - end; - if (VarType(V) and VarTypeMask = varByte) then - S := ConvertBLOBToString(V) - else - S := V; - Ch := ' '; - end else - if Arg1 = nil then begin - V := Arg2.GetValue; - if VarIsNull(V) then begin - Result := V; - Exit; - end; - if (VarType(V) and VarTypeMask = varByte) then - S := ConvertBLOBToString(V) - else - S := V; - Ch := ' '; - end else begin - V := Arg1.GetValue; - if VarIsNull(V) then begin - Result := V; - Exit; - end; - if (VarType(V) and VarTypeMask = varByte) then - S := ConvertBLOBToString(V) - else - S := V; - Ch := S[1]; - V := Arg2.GetValue; - if VarIsNull(V) then - S := '' - else if (VarType(V) and VarTypeMask = varByte) then - S := ConvertBLOBToString(V) - else - S := V; - end; - case LTB of - ltbBoth : - begin - while (length(S) > 0) and (S[1] = Ch) do - Delete(S, 1, 1); - while (length(S) > 0) and (S[length(S)] = Ch) do - Delete(S, length(S), 1); - end; - ltbLeading : - while (length(S) > 0) and (S[1] = Ch) do - Delete(S, 1, 1); - ltbTrailing : - while (length(S) > 0) and (S[length(S)] = Ch) do - Delete(S, length(S), 1); - end; - Result := S; - end; - sfExtract : - begin - V := Arg1.GetValue; - if VarIsNull(V) then begin - Result := V; - exit; - end; - DT := V; - case XDef of - iYear : - begin - DecodeDate(DT, Y, M, D); - Result := Y; - end; - iMonth : - begin - DecodeDate(DT, Y, M, D); - Result := M; - end; - iDay : - begin - DecodeDate(DT, Y, M, D); - Result := D; - end; - iHour : - begin - DecodeTime(DT, Hour, Min, Sec, MSec); - Result := Hour; - end; - iMinute: - begin - DecodeTime(DT, Hour, Min, Sec, MSec); - Result := Min; - end; - else - //iSecond: - begin - DecodeTime(DT, Hour, Min, Sec, MSec); - Result := Sec; - end; - end; - end; - sfNullIf : - begin - V := Arg1.GetValue; - if V = Arg2.GetValue then - Result := Null - else - Result := V; - end; - sfAbs : - begin - V := Arg1.GetValue; - if VarIsNull(V) then - Result := V - else - Result := abs(V); - end; - sfCeil : - begin - V := Arg1.GetValue; - if VarIsNull(V) then - Result := V - else - Result := Ceil(V); - end; - sfFloor : - begin - V := Arg1.GetValue; - if VarIsNull(V) then - Result := V - else - Result := Floor(V); - end; - sfExp : - begin - V := Arg1.GetValue; - if VarIsNull(V) then - Result := V - else - Result := Exp(V); - end; - sfLog : - begin - V := Arg1.GetValue; - if VarIsNull(V) then - Result := V - else - Result := Ln(V); - end; - sfRound : - begin - V := Arg1.GetValue; - if VarIsNull(V) then - Result := V - else - Result := 1.0 * Round(V); - end; - sfRand : - Result := Random; - sfPower : - begin - V := Arg1.GetValue; - if VarIsNull(V) then - Result := V - else begin - V2 := Arg2.GetValue; - if VarIsNull(V2) then - Result := V2 - else - Result := Power(V, V2); - end; - end; - else - Assert(False); - end; -end; - -function TffSqlScalarFunc.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; - -function TffSqlScalarFunc.IsFieldFrom(Table: TFFSqlTableProxy; - var FieldReferenced: TFFSqlFieldProxy): Boolean; -var - SameCase: Boolean; -begin - if SQLFunction in [sfUpper, sfLower] then - Result := Arg1.IsFieldFrom(Table, FieldReferenced, SameCase) - else - Result := False; -end; - -procedure TffSqlScalarFunc.MatchType(ExpectedType: TffFieldType); -begin - case ExpectedType of - {!!.11 begin} - fftChar, - fftWideChar, - fftShortString, - fftShortAnsiStr, - fftNullString, - fftNullAnsiStr, - fftWideString, - fftBLOB..fftBLOBTypedBin : - case GetType of - fftChar, - fftWideChar, - fftShortString, - fftShortAnsiStr, - fftNullString, - fftNullAnsiStr, - fftWideString, - fftBLOB..fftBLOBTypedBin : - ; {ok} - else - TypeMismatch; - end; - {!!.11 end} - fftStDate, - fftStTime, - fftDateTime: - case GetType of - fftStDate, - fftStTime, - fftDateTime: - ; {ok} - else - TypeMismatch; - end; - else - if GetType <> ExpectedType then - TypeMismatch; - end; -end; -{--------} -function TffSqlScalarFunc.Reduce: Boolean; -begin - case SQLFunction of - sfCase : - Result := CaseExp.Reduce; - sfCharlen : - Result := Arg1.Reduce; - sfCoalesce : - Result := CoalesceExp.Reduce; - sfCurrentDate : - Result := False; - sfCurrentTime : - Result := False; - sfCurrentTimestamp : - Result := False; - sfCurrentUser : - Result := False; - sfLower : - Result := Arg1.Reduce; - sfUpper : - Result := Arg1.Reduce; - sfPosition : - begin - Result := Arg1.Reduce; - if not Result and (Arg2 <> nil) then - Result := Arg2.Reduce; - end; - sfSessionUser : - Result := False; - sfSubstring : - begin - Result := Arg1.Reduce or Arg2.Reduce; - if not Result and (Arg3 <> nil) then - Result := Arg3.Reduce; - end; - sfSystemUser : - Result := False; - sfTrim : - begin - if Arg2 = nil then begin - Result := Arg1.Reduce - end else - if Arg1 = nil then begin - Result := Arg2.Reduce; - end else begin - Result := Arg1.Reduce or Arg2.Reduce; - end; - end; - sfExtract : - begin - Result := Arg1.Reduce; - end; - sfNullIf : - begin - Result := Arg1.Reduce or Arg2.Reduce; - end; - {!!.11 begin} - sfAbs, sfCeil, sfFloor, sfExp, sfLog, sfRound : - Result := Arg1.Reduce; - sfRand : - Result := False; - sfPower : - Result := Arg1.Reduce or Arg2.Reduce; - {!!.11 end} - else - Result := False; - end; -end; -{--------} -procedure TffSqlScalarFunc.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; - -{====================================================================} - -{===TffSqlWhenClauseList=============================================} -function TffSqlWhenClauseList.AddWhenClause(Value: TffSqlWhenClause): TffSqlWhenClause; -begin - WhenClauseList.Add(Value); - Result := Value; -end; -{--------} -procedure TffSqlWhenClauseList.Assign(const Source: TffSqlNode); -var - i : Integer; -begin - if Source is TffSqlWhenClauseList then begin - Clear; - for i := 0 to pred(TffSqlWhenClauseList(Source).WhenClauseCount) do - AddWhenClause(TffSqlWhenClause.Create(Self)).Assign( - TffSqlWhenClauseList(Source).WhenClause[i]); - end else - AssignError(Source); -end; - -procedure TffSqlWhenClauseList.CheckIsConstant; -var - i : Integer; -begin - FIsConstantChecked := True; - for i := 0 to pred(WhenClauseCount) do - if not WhenClause[i].IsConstant then begin - FIsConstant := False; - exit; - end; - FIsConstant := True; -end; - -constructor TffSqlWhenClauseList.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); - WhenClauseList := TList.Create; -end; -{--------} -function TffSqlWhenClauseList.DependsOn(Table: TFFSqlTableProxy): Boolean; -var - i : Integer; -begin - for i := 0 to pred(WhenClauseCount) do - if WhenClause[i].DependsOn(Table) then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -procedure TffSqlWhenClauseList.Clear; -var - i : Integer; -begin - for i := 0 to pred(WhenClauseCount) do - WhenClause[i].Free; - WhenClauseList.Clear; -end; -{--------} -destructor TffSqlWhenClauseList.Destroy; -begin - Clear; - WhenClauseList.Free; - inherited; -end; -{--------} -procedure TffSqlWhenClauseList.EmitSQL(Stream: TStream); -var - i : Integer; -begin - for i := 0 to pred(WhenClauseCount) do - WhenClause[i].EmitSQL(Stream); -end; -{--------} -procedure TffSqlWhenClauseList.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -var - i : Integer; -begin - EnumMethod(Self); - for i := 0 to pred(WhenClauseCount) do - WhenClause[i].EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlWhenClauseList.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if Other is TffSqlWhenClauseList then begin - if WhenClauseCount <> TffSqlWhenClauseList(Other).WhenClauseCount then - exit; - for i := 0 to pred(WhenClauseCount) do - if not WhenClause[i].Equals(TffSqlWhenClauseList(Other).WhenClause[i]) then - exit; - Result := True; - end; -end; -{--------} -function TffSqlWhenClauseList.GetWhenClause( - Index: Integer): TffSqlWhenClause; -begin - Result := TffSqlWhenClause(WhenClauseList[Index]); -end; -{--------} -function TffSqlWhenClauseList.GetWhenClauseCount: Integer; -begin - Result := WhenClauseList.Count; -end; -{--------} -function TffSqlWhenClauseList.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; - -procedure TffSqlWhenClauseList.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; - -{====================================================================} - -{===TffSqlWhenClause=================================================} -procedure TffSqlWhenClause.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlWhenClause then begin - if WhenExp = nil then - WhenExp := TffSqlCondExp.Create(Self); - WhenExp.Assign(TffSqlWhenClause(Source).WhenExp); - ThenExp.Free; - ThenExp := nil; - if assigned(TffSqlWhenClause(Source).ThenExp) then begin - ThenExp := TffSqlSimpleExpression.Create(Self); - ThenExp.Assign(TffSqlWhenClause(Source).ThenExp); - end; - end else - AssignError(Source); -end; - -procedure TffSqlWhenClause.CheckIsConstant; -begin - FIsConstantChecked := True; - FIsConstant := WhenExp.IsConstant and - (not assigned(ThenExp) or - ThenExp.IsConstant); -end; -{--------} -function TffSqlWhenClause.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - Result := WhenExp.DependsOn(Table) or - ((ThenExp <> nil) and ThenExp.DependsOn(Table)); -end; - -destructor TffSqlWhenClause.Destroy; -begin - WhenExp.Free; - ThenExp.Free; - inherited; -end; - -procedure TffSqlWhenClause.EmitSQL(Stream: TStream); -begin - WriteStr(Stream,' WHEN '); - WhenExp.EmitSQL(Stream); - WriteStr(Stream,' THEN '); - if ThenExp <> nil then - ThenExp.EmitSQL(Stream) - else - WriteStr(Stream,' NULL'); -end; -{--------} -procedure TffSqlWhenClause.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - WhenExp.EnumNodes(EnumMethod, Deep); - if assigned(ThenExp) then - ThenExp.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlWhenClause.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlWhenClause) - and (WhenExp.Equals(TffSqlWhenClause(Other).WhenExp)) - and - BothNil(ThenExp, TffSqlWhenClause(Other).ThenExp) - or (BothNonNil(ThenExp, TffSqlWhenClause(Other).ThenExp) - and (ThenExp.Equals(TffSqlWhenClause(Other).ThenExp))); -end; -{--------} -function TffSqlWhenClause.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; - -procedure TffSqlWhenClause.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; - - -{====================================================================} - -{===TffSqlCaseExpression=============================================} -procedure TffSqlCaseExpression.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlCaseExpression then begin - if WhenClauseList = nil then - WhenClauseList := TffSqlWhenClauseList.Create(Self); - WhenClauseList.Assign(TffSqlCaseExpression(Source).WhenClauseList); - ElseExp.Free; - ElseExp := nil; - if Assigned(TffSqlCaseExpression(Source).ElseExp) then begin - ElseExp := TffSqlSimpleExpression.Create(Self); - ElseExp.Assign(TffSqlCaseExpression(Source).ElseExp); - end; - end else - AssignError(Source); -end; - -procedure TffSqlCaseExpression.CheckIsConstant; -begin - FIsConstantChecked := True; - FIsConstant := - WhenClauseList.IsConstant and ((ElseExp = nil) or ElseExp.IsConstant); - if FIsConstant then begin - FIsConstant := False; - ConstantValue := GetValue; - FIsConstant := True; - end; -end; - -function TffSqlCaseExpression.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - Result := WhenClauseList.DependsOn(Table) or - (ElseExp <> nil) and ElseExp.DependsOn(Table); -end; - -destructor TffSqlCaseExpression.Destroy; -begin - WhenClauseList.Free; - ElseExp.Free; - inherited; -end; - -procedure TffSqlCaseExpression.EmitSQL(Stream: TStream); -begin - WriteStr(Stream,' CASE'); - WhenClauseList.EmitSQL(Stream); - WriteStr(Stream,' ELSE '); - if ElseExp <> nil then - ElseExp.EmitSQL(Stream) - else - WriteStr(Stream, 'NULL'); - WriteStr(Stream,' END'); -end; -{--------} -procedure TffSqlCaseExpression.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - WhenClauseList.EnumNodes(EnumMethod, Deep); - if ElseExp <> nil then - ElseExp.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlCaseExpression.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlCaseExpression) - and WhenClauseList.Equals(TffSqlCaseExpression(Other).WhenClauseList) - and (BothNil(ElseExp, TffSqlCaseExpression(Other).ElseExp) - or (BothNonNil(ElseExp, TffSqlCaseExpression(Other).ElseExp) - and - ElseExp.Equals(TffSqlCaseExpression(Other).ElseExp) - ) - ); -end; -{--------} -function TffSqlCaseExpression.GetSize: Integer; -var - i : Integer; -begin - Result := 0; - for i := 0 to pred(WhenClauseList.WhenClauseCount) do - if WhenClauseList.WhenClause[i].ThenExp <> nil then - Result := FFMaxI(Result, WhenClauseList.WhenClause[i].ThenExp.GetSize); - if ElseExp <> nil then - Result := FFMaxI(Result, ElseExp.GetSize); -end; - -function TffSqlCaseExpression.GetType: TffFieldType; -begin - if WhenClauseList.WhenClause[0].ThenExp <> nil then - Result := WhenClauseList.WhenClause[0].ThenExp.GetType - else - Result := fftShortString; {actually, NULL} -end; - -function TffSqlCaseExpression.GetValue: Variant; -var - i : Integer; -begin - if IsConstant then begin - Result := ConstantValue; - exit; - end; - for i := 0 to pred(WhenClauseList.WhenClauseCount) do - if WhenClauseList.WhenClause[i].WhenExp.AsBoolean then begin - if WhenClauseList.WhenClause[i].ThenExp <> nil then - Result := WhenClauseList.WhenClause[i].ThenExp.GetValue - else - Result := Null; - exit; - end; - if ElseExp <> nil then - Result := ElseExp.GetValue - else - Result := Null; -end; -{--------} -function TffSqlCaseExpression.IsConstant: Boolean; -begin - if not FIsConstantChecked then - CheckIsConstant; - Result := FIsConstant; -end; -{--------} -function TffSqlCaseExpression.Reduce: Boolean; -var - i : Integer; -begin - for i := 0 to pred(WhenClauseList.WhenClauseCount) do - if WhenClauseList.WhenClause[i].WhenExp.Reduce then begin - Result := True; - exit; - end else - if WhenClauseList.WhenClause[i].ThenExp <> nil then - if WhenClauseList.WhenClause[i].ThenExp.Reduce then begin - Result := True; - exit; - end; - if ElseExp <> nil then - Result := ElseExp.Reduce - else - Result := False; -end; - -procedure TffSqlCaseExpression.ResetConstant; -begin - FIsConstantChecked := False; - FIsConstant := False; -end; - -{====================================================================} - -{===TffSqlMatchClause================================================} -function TffSqlMatchClause.AsBoolean(const TestValue: Variant): Boolean; -begin - Result := SubQuery.Match(TestValue, Unique, Option) -end; -{--------} -procedure TffSqlMatchClause.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlMatchClause then begin - Unique := TffSqlMatchClause(Source).Unique; - Option := TffSqlMatchClause(Source).Option; - SubQuery.Free; - SubQuery := TffSqlSELECT.Create(Self); - SubQuery.Assign(TffSqlMatchClause(Source).SubQuery); - end else - AssignError(Source); -end; - -function TffSqlMatchClause.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - Result := SubQuery.DependsOn(Table); -end; - -destructor TffSqlMatchClause.Destroy; -begin - SubQuery.Free; - inherited; -end; -{--------} -procedure TffSqlMatchClause.EmitSQL(Stream: TStream); -begin - WriteStr(Stream, ' MATCH'); - if Unique then - WriteStr(Stream,' UNIQUE'); - case Option of - moPartial : - WriteStr(Stream,' PARTIAL'); - moFull : - WriteStr(Stream,' FULL'); - end; - WriteStr(Stream,'('); - SubQuery.EmitSQL(Stream); - WriteStr(Stream,')'); -end; -{--------} -procedure TffSqlMatchClause.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -begin - EnumMethod(Self); - SubQuery.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlMatchClause.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlMatchClause) - and (Unique = TffSqlMatchClause(Other).Unique) - and (Option = TffSqlMatchClause(Other).Option) - and (SubQuery.Equals(TffSqlMatchClause(Other).SubQuery)); -end; -{--------} -procedure TffSqlMatchClause.MatchType(ExpectedType: TffFieldType); -begin - SubQuery.MatchType(ExpectedType, False); -end; - -function TffSqlMatchClause.Reduce: Boolean; -begin - Result := SubQuery.Reduce; -end; - -{====================================================================} -{ TffSqlCoalesceExpression } -function TffSqlCoalesceExpression.AddArg(Value: TffSqlSimpleExpression): TffSqlSimpleExpression; -begin - ArgList.Add(Value); - Result := Value; -end; -{--------} -procedure TffSqlCoalesceExpression.Assign(const Source: TffSqlNode); -var - i : Integer; -begin - if Source is TffSqlCoalesceExpression then begin - Clear; - for i := 0 to pred(TffSqlCoalesceExpression(Source).ArgCount) do - AddArg(TffSqlSimpleExpression.Create(Self)).Assign( - TffSqlCoalesceExpression(Source).Arg[i]); - end else - AssignError(Source); -end; - -constructor TffSqlCoalesceExpression.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); - ArgList := TList.Create; -end; -{--------} -procedure TffSqlCoalesceExpression.Clear; -var - i : Integer; -begin - for i := 0 to pred(ArgCount) do - Arg[i].Free; - ArgList.Clear; -end; -{--------} -destructor TffSqlCoalesceExpression.Destroy; -begin - Clear; - ArgList.Free; - inherited; -end; -{--------} -procedure TffSqlCoalesceExpression.EmitSQL(Stream: TStream); -var - i : Integer; -begin - WriteStr(Stream,' COALESCE('); - Arg[0].EmitSQL(Stream); - for i := 1 to pred(ArgCount) do begin - WriteStr(Stream,' ,'); - Arg[i].EmitSQL(Stream); - end; - WriteStr(Stream,')'); -end; -{--------} -procedure TffSqlCoalesceExpression.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -var - i : Integer; -begin - EnumMethod(Self); - for i := 0 to pred(ArgCount) do - Arg[i].EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlCoalesceExpression.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if Other is TffSqlCoalesceExpression then - if ArgCount = TffSqlCoalesceExpression(Other).ArgCount then begin - for i := 0 to pred(ArgCount) do - if not Arg[i].Equals(TffSqlCoalesceExpression(Other).Arg[i]) then - exit; - Result := True; - end; -end; -{--------} -function TffSqlCoalesceExpression.GetArg( - Index: Integer): TffSqlSimpleExpression; -begin - Result := TffSqlSimpleExpression(ArgList[Index]); -end; -{--------} -function TffSqlCoalesceExpression.GetArgCount: Integer; -begin - Result := ArgList.Count; -end; -{--------} -function TffSqlCoalesceExpression.GetValue: Variant; -var - i : Integer; -begin - Result := Null; - for i := 0 to pred(ArgCount) do begin - Result := Arg[i].GetValue; - if Result <> Null then - exit; - end; -end; -{--------} -function TffSqlCoalesceExpression.DependsOn( - Table: TFFSqlTableProxy): Boolean; -var - i : Integer; -begin - for i := 0 to pred(ArgCount) do - if Arg[i].DependsOn(Table) then begin - Result := True; - exit; - end; - Result := False; -end; -{--------} -function TffSqlCoalesceExpression.GetType: TffFieldType; -begin - Result := Arg[0].GetType; -end; -{--------} -function TffSqlCoalesceExpression.Reduce: Boolean; -var - i : Integer; -begin - for i := 0 to pred(ArgCount) do - if Arg[i].Reduce then begin - Result := True; - exit; - end; - Result := False; -end; -{====================================================================} - -function TffSqlCoalesceExpression.GetSize: Integer; -var - i : Integer; -begin - Result := 0; - for i := 0 to pred(ArgCount) do - Result := FFMaxI(Result, Arg[i].GetSize); -end; - -{ TFFSqlTableProxySubset } - -procedure TFFSqlTableProxySubset.Assign( - const Source: TFFSqlTableProxySubset); -begin - FTable := Source.Table; - KeyRelation := Source.KeyRelation; - Outer := Source.Outer; - Opposite := Source.Opposite; -end; - -constructor TFFSqlTableProxySubset.Create; -begin - FTable := Table; -end; - -procedure TFFSqlTableProxySubset.Iterate(Iterator: TFFSqlTableIterator; - Cookie: TffWord32); -begin - FTable.Iterate(Iterator, Cookie); -end; - -function TFFSqlTableProxySubset.UniqueValue: Boolean; -begin - Result := - (KeyRelation.RelationFieldCount = KeyRelation.RelationKeyFieldCount) - and (KeyRelation.RelationOperators[KeyRelation.RelationKeyFieldCount - 1] = roEQ); -end; - -function TFFSqlTableProxySubset.ClosedSegment: Boolean; -begin - Result := KeyRelation.RelationOperatorB[KeyRelation.RelationKeyFieldCount - 1] <> roNone; {!!.11} -end; - -function TFFSqlTableProxySubset.KeyDepth: Integer; -begin - Result := KeyRelation.RelationFieldCount; -end; - -function TFFSqlTableProxySubset.EqualKeyDepth: Integer; -begin - Result := 0; - while (Result < KeyRelation.RelationFieldCount) - and (KeyRelation.RelationOperators[Result] = roEQ) do - inc(Result); -end; - -{ TFFSqlTableProxySubsetList } - -function TFFSqlTableProxySubsetList.Add( - TableProxySubset: TFFSqlTableProxySubset): TFFSqlTableProxySubset; -begin - FList.Add(TableProxySubset); - Result := TableProxySubset; -end; - -{!!.10 new} -function TFFSqlTableProxySubsetList.Insert( - TableProxySubset: TFFSqlTableProxySubset): TFFSqlTableProxySubset; -begin - FList.Insert(0, TableProxySubset); - Result := TableProxySubset; -end; - -procedure TFFSqlTableProxySubsetList.Assign( - const Source: TFFSqlTableProxySubsetList); -var - i : Integer; -begin - Clear; - for i := 0 to pred(Source.Count) do - Add(TFFSqlTableProxySubset.Create(Source.Item[i].Table)).Assign(Source.Item[i]); - OuterJoin := Source.OuterJoin; -end; - -constructor TFFSqlTableProxySubsetList.Create; -begin - Assert(AOwner <> nil); - FOwner := AOwner; - FList := TList.Create; -end; - -procedure TFFSqlTableProxySubsetList.Delete(Index: Integer); -begin - FList.Delete(Index); -end; - -procedure TFFSqlTableProxySubsetList.Clear; -var - i : Integer; -begin - for i := 0 to pred(FList.Count) do - Item[i].Free; - FList.Clear; -end; - -destructor TFFSqlTableProxySubsetList.Destroy; -begin - Clear; - FList.Free; - inherited; -end; - -function TFFSqlTableProxySubsetList.GetCount: Integer; -begin - Result := FList.Count; -end; - -function TFFSqlTableProxySubsetList.GetItem( - Index: Integer): TFFSqlTableProxySubset; -begin - Result := TFFSqlTableProxySubset(FList[Index]); -end; - -function TFFSqlTableProxySubsetList.RelationUsed( - Relation: TffSqlCondFactor): Boolean; -var - i : Integer; -begin - for i := 0 to pred(Count) do - if Item[i].KeyRelation.CondF = Relation then begin - Result := True; - exit; - end; - Result := False; -end; - -function TFFSqlTableProxySubsetList.DependencyExists( - Table : TFFSqlTableProxy): Boolean; -var - i, j : Integer; -begin - for i := 0 to pred(Count) do - for j := 0 to Item[i].KeyRelation.RelationFieldCount - 1 do begin - if Item[i].KeyRelation.ArgExpressions[j].DependsOn(Table) then begin - Result := True; - exit; - end; - if (Item[i].KeyRelation.ArgExpressionB[j] <> nil) {!!.11} - and Item[i].KeyRelation.ArgExpressionB[j].DependsOn(Table) then begin {!!.11} - Result := True; - exit; - end; - end; - Result := False; -end; - -function TFFSqlTableProxySubsetList.ProcessLevel(Cookie1: TffWord32): Boolean; -begin - inc(FRecordsRead); - inc(Owner.RecordsRead); - { Time to check for timeout? } - if FRecordsRead mod 1000 = 0 then - FFCheckRemainingTime; - Result := True; {continue} - if Level = 0 then begin - if FCondTerm.AsBoolean then - if not SkipInner then - FCreateResultRecord; - if SkipInner then - {SkipInner means we're writing NULL records for outer join - records with no match, so we just need to know if there - were any here; we don't need to see the rest, so stop reading:} - Result := False; - WroteRow := True; - end else begin - if FCondTerm.AsBooleanLevel(Level) then begin - dec(Level); - ReadSources; - inc(Level); - end; - end; -end; - -procedure TFFSqlTableProxySubsetList.ReadSources; -var - {V : array[0..pred(ffcl_MaxIndexFlds)] of Variant; - VB : array[0..pred(ffcl_MaxIndexFlds)] of Variant;} {!!.11} - i : Integer; - NullLimit, - BUsed : Boolean; - KeyHasIntervals: Boolean; {!!.11} -begin - with Item[Level] do begin - NullLimit := False; - if KeyRelation.CondF <> nil then begin - Table.SetIndex(KeyRelation.NativeKeyIndex - 1); - for i := 0 to KeyRelation.RelationFieldCount - 1 do begin - Assert(KeyRelation.ArgExpressions[i] is TffSqlSimpleExpression); - V[i] := TffSqlSimpleExpression(KeyRelation.ArgExpressions[i]).GetValue; - if VarIsNull(V[i]) then - NullLimit := True; - VB[i] := V[i]; - end; - - {!!.11 begin} - KeyHasIntervals := False; - for i := 0 to KeyRelation.RelationFieldCount - 2 do - if KeyRelation.RelationOperators[i] <> roEQ then begin - KeyHasIntervals := True; - break; - end; - {!!.11 end} - {!!.13} - {can't preevaluate open intervals on key alone because of possible null values} - for i := 0 to KeyRelation.RelationFieldCount - 1 do - case KeyRelation.RelationOperators[i] of - roL, roG : begin - KeyHasIntervals := True; - break; - end; - end; - {!!.13} - - if not KeyHasIntervals and {!!.11} - not KeyRelation.RelationKeyIsCaseInsensitive then - KeyRelation.CondF.MarkTrue; - - for i := 0 to KeyRelation.RelationFieldCount - 1 do {!!.11} - if KeyRelation.RelationOperatorB[i] <> roNone then begin {!!.11} - Assert(KeyRelation.ArgExpressionB[i] is TffSqlSimpleExpression); {!!.11} - VB[i{KeyRelation.RelationFieldCount - 1}] := {!!.11} - TffSqlSimpleExpression(KeyRelation.ArgExpressionB[i]).GetValue; {!!.11} - if VarIsNull(VB[i{KeyRelation.RelationFieldCount - 1}]) then {!!.11} - NullLimit := True; - end; - BUsed := False; - if not NullLimit then - case KeyRelation.RelationOperators[KeyRelation.RelationFieldCount - 1] of - roEQ : - Table.SetRange(V, VB, KeyRelation.RelationFieldCount, {!!.11} - KeyRelation.RelationFieldCount, True, True, - KeyRelation.RelationKeyIndexAsc); - roLE : - case KeyRelation.RelationOperatorB[KeyRelation.RelationFieldCount - 1] of {!!.11} - roG : - begin - Table.SetRange(VB, V, KeyRelation.RelationFieldCount, - KeyRelation.RelationFieldCount, False, True, - KeyRelation.RelationKeyIndexAsc); - BUsed := True; - end; - roGE : - begin - Table.SetRange(VB, V, KeyRelation.RelationFieldCount, - KeyRelation.RelationFieldCount, True, True, - KeyRelation.RelationKeyIndexAsc); - BUsed := True; - end; - else - Table.SetRange(V, V, KeyRelation.RelationFieldCount - 1, - KeyRelation.RelationFieldCount, True, True, - KeyRelation.RelationKeyIndexAsc); - end; - roL : - case KeyRelation.RelationOperatorB[KeyRelation.RelationFieldCount - 1] of {!!.11} - roG : - begin - Table.SetRange(VB, V, KeyRelation.RelationFieldCount, - KeyRelation.RelationFieldCount, False, False, - KeyRelation.RelationKeyIndexAsc); - BUsed := True; - end; - roGE : - begin - Table.SetRange(VB, V, KeyRelation.RelationFieldCount, - KeyRelation.RelationFieldCount, True, False, - KeyRelation.RelationKeyIndexAsc); - BUsed := True; - end; - else - Table.SetRange(V, V, KeyRelation.RelationFieldCount - 1, - KeyRelation.RelationFieldCount, True, False, - KeyRelation.RelationKeyIndexAsc); - end; - roG : - case KeyRelation.RelationOperatorB[KeyRelation.RelationFieldCount - 1] of {!!.11} - roLE : - begin - Table.SetRange(V, VB, KeyRelation.RelationFieldCount, - KeyRelation.RelationFieldCount, False, True, - KeyRelation.RelationKeyIndexAsc); - BUsed := True; - end; - roL : - begin - Table.SetRange(V, VB, KeyRelation.RelationFieldCount, - KeyRelation.RelationFieldCount, False, False, - KeyRelation.RelationKeyIndexAsc); - BUsed := True; - end; - else - Table.SetRange(V, V, KeyRelation.RelationFieldCount, - KeyRelation.RelationFieldCount - 1, False, True, - KeyRelation.RelationKeyIndexAsc); - end; - roGE : - case KeyRelation.RelationOperatorB[KeyRelation.RelationFieldCount - 1] of {!!.11} - roLE : - begin - Table.SetRange(V, VB, KeyRelation.RelationFieldCount, - KeyRelation.RelationFieldCount, True, True, - KeyRelation.RelationKeyIndexAsc); - BUsed := True; - end; - roL : - begin - Table.SetRange(V, VB, KeyRelation.RelationFieldCount, - KeyRelation.RelationFieldCount, True, False, - KeyRelation.RelationKeyIndexAsc); - BUsed := True; - end; - else - Table.SetRange(V, V, KeyRelation.RelationFieldCount, - KeyRelation.RelationFieldCount - 1, True, True, - KeyRelation.RelationKeyIndexAsc); - end; - else - Assert(False); - end; - if not KeyHasIntervals and {!!.11} - not KeyRelation.RelationKeyIsCaseInsensitive and BUsed then - KeyRelation.RelationB[KeyRelation.RelationFieldCount - 1].MarkTrue; {!!.11} - end else - Table.SetIndex(-1); - {if not NullLimit then begin} {!!.11} - WroteRow := False; - if not NullLimit then {!!.11} - Iterate(ProcessLevel, 0); - if OuterJoin and not WroteRow and (Level = 0) then begin - Item[0].Table.NullRecord; - FCreateResultRecord; - end; - {end;} {!!.11} - if KeyRelation.CondF <> nil then begin - KeyRelation.CondF.MarkUnknown; - if KeyRelation.RelationOperatorB[KeyRelation.RelationFieldCount - 1] <> roNone then {!!.11} - KeyRelation.RelationB[KeyRelation.RelationFieldCount - 1].MarkUnknown; {!!.11} - end; - end; -end; - -procedure TFFSqlTableProxySubsetList.Join; -begin - FCondTerm := CondTerm; - CondTerm.SetLevelDep(Self); - FCreateResultRecord := CreateResultRecord; - Level := Count - 1; - ReadSources; -end; - -{ TffSqlINSERT } - -procedure TffSqlINSERT.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlINSERT then begin - Clear; - DefaultValues := TffSqlINSERT(Source).DefaultValues; - TableName := TffSqlINSERT(Source).TableName; - if TffSqlINSERT(Source).InsertColumnList <> nil then begin - InsertColumnList := TffSqlInsertColumnList.Create(Self); - InsertColumnList.Assign(TffSqlINSERT(Source).InsertColumnList); - end; - - if TffSqlINSERT(Source).TableExp <> nil then begin - TableExp := TffSqlTableExp.Create(Self); - TableExp.Assign(TffSqlINSERT(Source).TableExp); - end; - - end else - AssignError(Source); -end; - -procedure TffSqlINSERT.AddColumns(Node: TffSqlNode); -begin - Node.AddColumnDef(Self); -end; -{--------} -procedure TffSqlINSERT.Bind; -var - i: Integer; - F: TFFSqlFieldProxy; -begin - if InsertColumnList <> nil then - InsertColumnList.EnumNodes(ClearBindings, False); - T := Owner.FDatabase.TableByName(Self, TableName, False, ''); {!!.11} - if T = nil then - SQLError('Unable to open table: ' + TableName + - '. Ensure the table exists and is not in use by ' + - 'another process.'); - - {build column list} - Assert(Assigned(Columns)); - Columns.Clear; - if InsertColumnList <> nil then - InsertColumnList.EnumNodes(AddColumns, False); - if Columns.Count = 0 then begin - for i := 0 to T.FieldCount - 1 do begin - F := T.Field(i); - if not F.CanUpdate then - SQLError('Changing fields of this type is not currently supported ' + - 'through SQL:' + Columns[i]); - Columns.AddObject(T.Field(i).Name, F); - end; - end else begin - for i := 0 to Columns.Count - 1 do begin - F := T.FieldByName(Columns[i]); - if F = nil then - SQLError('Unknown field for table ' + TableName + 'in INSERT statement:' + - Columns[i]); - - if not F.CanUpdate then - SQLError('Changing fields of this type is not currently supported through SQL:' + - Columns[i]); - - Columns.Objects[i] := F; - end; - end; - Bound := True; -end; -{--------} -procedure TffSqlINSERT.Clear; -begin - TableName := ''; - InsertColumnList.Free; - InsertColumnList := nil; - TableExp.Free; - TableExp := nil; -end; -{--------} -procedure TffSqlINSERT.ClearBindings(Node: TffSqlNode); -begin - Node.ClearBinding; -end; -{--------} -destructor TffSqlINSERT.Destroy; -begin - Clear; - if T <> nil then - if T.Owner = Self then begin - T.Owner := nil; - T.Free; - end; - inherited; -end; -{--------} -procedure TffSqlINSERT.EmitSQL(Stream: TStream); -begin - WriteStr(Stream, 'INSERT INTO '); - WriteStr(Stream, TableName); - WriteStr(Stream,' '); - if DefaultValues then - WriteStr(Stream,'DEFAULT VALUES ') - else begin - if assigned(InsertColumnList) then begin - WriteStr(Stream,'('); - InsertColumnList.EmitSQL(Stream); - WriteStr(Stream,') '); - end; - if assigned(TableExp) then - TableExp.EmitSQL(Stream); - end; -end; -{--------} -procedure TffSqlINSERT.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); - if assigned(InsertColumnList) then - InsertColumnList.EnumNodes(EnumMethod,Deep); - if assigned(TableExp) then - TableExp.EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlINSERT.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlINSERT) - and (DefaultValues = TffSqlINSERT(Other).DefaultValues) - and (TableName = TffSqlINSERT(Other).TableName) - and (BothNil(InsertColumnList, TffSqlINSERT(Other).InsertColumnList) - or (BothNonNil(InsertColumnList, TffSqlINSERT(Other).InsertColumnList) - and InsertColumnList.Equals(TffSqlINSERT(Other).InsertColumnList)) - ) - and (BothNil(TableExp, TffSqlINSERT(Other).TableExp) - or (BothNonNil(TableExp, TffSqlINSERT(Other).TableExp) - and TableExp.Equals(TffSqlINSERT(Other).TableExp)) - ); -end; -{Begin !!.13} -{--------} -function CanInsert(const SrcType, TgtType : TffFieldType) : Boolean; -begin - { According to our past rules, which are very lax, most every type is - compatible with all other types. New rules: - - BLOBs may not be inserted into non-BLOB fields - - strings may be inserted into BLOBs - - strings cannot be inserted into numerics or date time } - if SrcType <> TgtType then - case TgtType of - { Numerics & datetime values may be inserted into numerics. } - fftByte..fftCurrency : - case SrcType of - fftByte..fftCurrency, fftStDate..fftDateTime : - Result := True; - else - Result := False; - end; - fftStDate..fftDateTime : - { Numerics, datetime, and string values may be inserted into datetime - columns. If a date is to be inserted via a string, the string must - be preceded via the DATE keyword. } - case SrcType of - fftByte..fftCurrency, - fftStDate..fftDateTime : - Result := True; - else - Result := False; - end; { case } - fftChar, - fftWideChar, - fftShortString..fftWideString : - { Everything except BLOBs may be inserted into a string. } - case SrcType of - fftBLOB..fftBLOBTypedBIN : - Result := False; - else - Result := True; - end; { case } - fftBLOB..fftBLOBTypedBIN : - { Strings & other BLOBs may be inserted into BLOBs. } - case SrcType of - fftChar, fftWideChar, - fftShortString..fftWideString, - fftBLOB..fftBLOBTypedBIN : - Result := True; - else - Result := False; - end; { case } - else - Result := False; - end { case } - else - Result := True; -end; -{End !!.13} -{--------} -function TffSqlINSERT.Execute(var RowsAffected: Integer) : TffResult; -{Revised !!.13} -var - i : Integer; - ST : TffSQLTableProxy; -begin - Result := Owner.FDatabase.StartTransaction([T]); - if Result = DBIERR_NONE then - try - RowsAffected := 0; - if not Bound then - Bind; - { Make sure the target table can be modified. } - Result := T.EnsureWritable; - if Result <> DBIERR_NONE then begin - Owner.FDatabase.AbortTransaction; - Exit; - end; - - { If inserting default values only then do so. } - if DefaultValues then begin - T.Insert; - T.SetDefaults; - Result := T.Post; - if Result = DBIERR_NONE then begin - Owner.FDatabase.Commit; - RowsAffected := 1; - end - else - Owner.FDatabase.AbortTransaction; - end - else if TableExp <> nil then begin - { Values are coming from a valuelist or subquery. } - ST := TableExp.ResultTable; - { Validate the number of source and target columns. } - if ST.FieldCount <> Columns.Count then - SQLError('The number of columns in the source clause must match ' + - 'the number of columns in the INSERT statement.'); - - { Do the field types match? } - for i := 0 to Pred(ST.FieldCount) do - if not CanInsert(ST.Field(i).GetType, - TffSqlFieldProxy(Columns.Objects[i]).GetType) then - SQLError(Format('The type for source column %d (column name ' + - '"%s") is incompatible with the type for ' + - 'target column %d (column name "%s")', - [i, ST.Field(i).Name, i, Columns[i]])); - - { Roll through the source table, inserting its rows into the result - table. } - ST.First; - while not ST.EOF do begin - T.Insert; - T.SetDefaults; - for i := 0 to FFMinI(Pred(ST.FieldCount), Pred(Columns.Count)) do - TFFSqlFieldProxy(Columns.Objects[i]).SetValue(ST.Field(i).GetValue); - Result := T.PostNoDefaults; - if Result = DBIERR_NONE then - inc(RowsAffected) - else - break; - ST.Next; - end; - if Result = DBIERR_NONE Then - Owner.FDatabase.Commit - else begin - Owner.FDatabase.AbortTransaction; - RowsAffected := 0; - end; - end else - Assert(False, 'Unexpected INSERT scenario'); - except - Owner.FDatabase.AbortTransaction; - RowsAffected := 0; - raise; - end - else if Result = DBIERR_LOCKED then - FFRaiseException(EffException, ffStrResServer, fferrLockRejected, - [ffcLockExclusive, '', T.Name]) - else - FFRaiseException(EffException, ffStrResServer, Result, [T.Name]); -end; -{--------} -{!!.11 new} -function TffSqlINSERT.Reduce: Boolean; -begin - if TableExp <> nil then - if TableExp.Reduce then begin - Result := True; - exit; - end; - Result := False; -end; - -{ TffSqlInsertItem } - -procedure TffSqlInsertItem.AddColumnDef(Target: TffSqlColumnListOwner); -begin - Target.Columns.Add(ColumnName); -end; - -procedure TffSqlInsertItem.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlInsertItem then begin - ColumnName := TffSqlInsertItem(Source).ColumnName; - end else - AssignError(Source); -end; - -procedure TffSqlInsertItem.EmitSQL(Stream: TStream); -begin - WriteStr(Stream, ColumnName); -end; - -procedure TffSqlInsertItem.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); -end; - -function TffSqlInsertItem.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlInsertItem) - and (ColumnName = TffSqlInsertItem(Other).ColumnName); -end; - -{ TffSqlInsertColumnList } - -function TffSqlInsertColumnList.AddItem( - NewInsertColumn: TffSqlInsertItem): TffSqlInsertItem; -begin - FInsertColumnItemList.Add(NewInsertColumn); - Result := NewInsertColumn; -end; - -procedure TffSqlInsertColumnList.Assign(const Source: TffSqlNode); -var - i : Integer; -begin - if Source is TffSqlInsertColumnList then begin - Clear; - for i := 0 to pred(TffSqlInsertColumnList(Source).InsertColumnCount) do - AddItem(TffSqlInsertItem.Create(Self)).Assign( - TffSqlInsertColumnList(Source).InsertColumnItem[i]); - end else - AssignError(Source); -end; - -procedure TffSqlInsertColumnList.Clear; -var - i : Integer; -begin - for i := 0 to pred(InsertColumnCount) do - InsertColumnItem[i].Free; - FInsertColumnItemList.Clear; -end; - -constructor TffSqlInsertColumnList.Create(AParent: TffSqlNode); -begin - inherited; - FInsertColumnItemList := TList.Create; -end; - -destructor TffSqlInsertColumnList.Destroy; -begin - Clear; - FInsertColumnItemList.Free; - inherited; -end; - -procedure TffSqlInsertColumnList.EmitSQL(Stream: TStream); -var - i : Integer; - First: Boolean; -begin - First := True; - for i := 0 to pred(InsertColumnCount) do begin - if First then - First := False - else - WriteStr(Stream, ', '); - InsertColumnItem[i].EmitSQL(Stream); - end; -end; - -procedure TffSqlInsertColumnList.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -var - i : Integer; -begin - EnumMethod(Self); - for i := 0 to pred(InsertColumnCount) do - InsertColumnItem[i].EnumNodes(EnumMethod, Deep); -end; - -function TffSqlInsertColumnList.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if Other is TffSqlInsertColumnList then begin - if InsertColumnCount <> TffSqlInsertColumnList(Other).InsertColumnCount then - exit; - for i := 0 to pred(InsertColumnCount) do - if not InsertColumnItem[i].Equals(TffSqlInsertColumnList(Other).InsertColumnItem[i]) then - exit; - Result := True; - end; -end; - -function TffSqlInsertColumnList.GetInsertColumnCount: Integer; -begin - Result := FInsertColumnItemList.Count; -end; - -function TffSqlInsertColumnList.GetInsertColumnItem( - Index: Integer): TffSqlInsertItem; -begin - Result := TffSqlInsertItem(FInsertColumnItemList[Index]); -end; - -procedure TffSqlInsertColumnList.SetInsertColumnItem(Index: Integer; - const Value: TffSqlInsertItem); -begin - FInsertColumnItemList[Index] := Value; -end; - -{ TffSqlValueItem } - -procedure TffSqlValueItem.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlValueItem then begin - Simplex.Free; - {Simplex := nil;} {unnecessary} - Default := TffSqlUpdateItem(Source).Default; - Simplex := TffSqlSimpleExpression.Create(Self); - Simplex.Assign(TffSqlValueItem(Source).Simplex); - end else - AssignError(Source); -end; - -destructor TffSqlValueItem.Destroy; -begin - Simplex.Free; - inherited; -end; - -procedure TffSqlValueItem.EmitSQL(Stream: TStream); -begin - if Default then - WriteStr(Stream, 'DEFAULT ') - else if Simplex = nil then - WriteStr(Stream, 'NULL ') - else - Simplex.EmitSQL(Stream); -end; - -procedure TffSqlValueItem.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); - if assigned(Simplex) then - Simplex.EnumNodes(EnumMethod, Deep); -end; - -function TffSqlValueItem.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlValueItem) - and (Default = TffSqlValueItem(Other).Default) - and (BothNil(Simplex, TffSqlValueItem(Other).Simplex) - or (BothNonNil(Simplex, TffSqlValueItem(Other).Simplex) - and Simplex.Equals(TffSqlValueItem(Other).Simplex))); -end; - -function TffSqlValueItem.GetDecimals: Integer; -begin - if assigned(Simplex) then - Result := Simplex.GetDecimals - else - Result := 0; -end; - -function TffSqlValueItem.GetSize: Integer; -begin - if assigned(Simplex) then - Result := Simplex.GetSize - else - Result := 1; -end; - -function TffSqlValueItem.GetType: TffFieldType; -begin - if assigned(Simplex) then - Result := Simplex.GetType - else - Result := fftBoolean; -end; - -{ TffSqlValueList } - -function TffSqlValueList.AddItem( - NewValue: TffSqlValueItem): TffSqlValueItem; -begin - FValueItemList.Add(NewValue); - Result := NewValue; -end; - -procedure TffSqlValueList.Assign(const Source: TffSqlNode); -var - i : Integer; -begin - if Source is TffSqlValueList then begin - Clear; - for i := 0 to pred(TffSqlValueList(Source).ValueCount) do - AddItem(TffSqlValueItem.Create(Self)).Assign( - TffSqlValueList(Source).ValueItem[i]); - end else - AssignError(Source); -end; - -procedure TffSqlValueList.Clear; -var - i : Integer; -begin - for i := 0 to pred(ValueCount) do - ValueItem[i].Free; - FValueItemList.Clear; -end; - -constructor TffSqlValueList.Create(AParent: TffSqlNode); -begin - inherited; - FValueItemList := TList.Create; -end; - -destructor TffSqlValueList.Destroy; -begin - Clear; - FValueItemList.Free; - if FResultTable <> nil then begin - if FResultTable.Owner = Self then begin - FResultTable.Owner := nil; - FResultTable.Free; - end; - end; - inherited; -end; - -procedure TffSqlValueList.EmitSQL(Stream: TStream); -var - i : Integer; - First: Boolean; -begin - First := True; - for i := 0 to pred(ValueCount) do begin - if First then - First := False - else - WriteStr(Stream, ', '); - ValueItem[i].EmitSQL(Stream); - end; -end; - -procedure TffSqlValueList.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -var - i: Integer; -begin - EnumMethod(Self); - for i := 0 to pred(ValueCount) do - ValueItem[i].EnumNodes(EnumMethod, Deep); -end; - -function TffSqlValueList.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if Other is TffSqlValueList then begin - if ValueCount <> TffSqlValueList(Other).ValueCount then - exit; - for i := 0 to pred(ValueCount) do - if not ValueItem[i].Equals(TffSqlValueList(Other).ValueItem[i]) then - exit; - Result := True; - end; -end; - -procedure TffSqlValueList.Execute( - var aLiveResult: Boolean; var aCursorID: TffCursorID; - var RecordsRead: Integer); -begin - raise Exception.Create('Not yet implemented'); -end; - -function TffSqlValueList.GetResultTable: TFFSqlTableProxy; -var - FieldDefList : TffSqlFieldDefList; - i: Integer; - FldName : string; {!!.11} - Field : TffSqlFieldProxy; {!!.11} -begin -{Begin !!.13} - if FResultTable <> nil then - for i := 0 to pred(ValueCount) do - if (ValueItem[i].Simplex <> nil) and - not ValueItem[i].Simplex.IsConstant then begin - FResultTable.Owner := nil; - FResultTable.Free; - FResultTable := nil; - break; - end; { if } -{End !!.13} - if FResultTable = nil then begin - FieldDefList := TffSqlFieldDefList.Create; - try -{Begin !!.11} - for i := 0 to pred(ValueCount) do begin - FldName := 'Value_'+IntToStr(i+1); - Field := OwnerStmt.T.Field(i); - if ValueItem[i].Default then - FieldDefList.AddField(FldName, Field.GetType, Field.GetSize, - Field.GetDecimals) - else - FieldDefList.AddField(FldName, ValueItem[i].GetType, - ValueItem[i].GetSize, ValueItem[i].GetDecimals); - end; { for } -{End !!.11} - FResultTable := Owner.FDatabase.CreateTemporaryTableWithoutIndex(Self, FieldDefList); {!!.10} - finally - FieldDefList.Free; - end; - Owner.FDatabase.StartTransaction([nil]); - try - FResultTable.Insert; - for i := 0 to pred(ValueCount) do - if ValueItem[i].Simplex <> nil then - FResultTable.Field(i).SetValue(ValueItem[i].Simplex.GetValue) -{Begin !!.11} - else if ValueItem[i].Default then - FResultTable.Field(i).SetDefault -{End !!.11} - else - FResultTable.Field(i).SetFieldToNull; - FResultTable.Post; - except - Owner.FDatabase.AbortTransaction; - FResultTable.Owner := nil; - FResultTable.Free; - FResultTable := nil; - raise; - end; - Owner.FDatabase.Commit; - end; - Result := FResultTable; -end; - -function TffSqlValueList.GetValueCount: Integer; -begin - Result := FValueItemList.Count; -end; - -function TffSqlValueList.GetValueItem(Index: Integer): TffSqlValueItem; -begin - Result := TffSqlValueItem(FValueItemList[Index]); -end; - -function TffSqlValueList.Reduce: Boolean; -begin - Result := False; -end; - -procedure TffSqlValueList.SetValueItem(Index: Integer; - const Value: TffSqlValueItem); -begin - FValueItemList[Index] := Value; -end; - -{ TffSqlDELETE } - -procedure TffSqlDELETE.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlDELETE then begin - Clear; - - if TffSqlDELETE(Source).TableRef <> nil then begin - TableRef := TffSqlTableRef.Create(Self); - TableRef.Assign(TffSqlDELETE(Source).TableRef); - end; - - if TffSqlDELETE(Source).CondExpWhere <> nil then begin - CondExpWhere := TffSqlCondExp.Create(Self); - CondExpWhere.Assign(TffSqlDELETE(Source).CondExpWhere); - end; - end else - AssignError(Source); -end; - -procedure TffSqlDELETE.Bind; -begin - Assert(TableRef <> nil); - T := TableRef.GetTable(Self, False); {!!.11} - if T = nil then - SQLError('Unable to open table: ' + TableRef.SQLName + //TableName + - '. Ensure the table exists and is not in use by ' + - 'another process.'); - - if CondExpWhere <> nil then - CondExpWhere.MatchType(fftBoolean); - Bound := True; -end; - -function TffSqlDELETE.BindField(const TableName, - FieldName: string): TFFSqlFieldProxy; -begin - Result := nil; - Assert(T <> nil); - Assert(T is TffSqlTableProxy); - if T.FieldByName(FieldName) <> nil then begin - Result := T.FieldByName(FieldName); - Exit; - end; - SQLError('Unknown field:' + FieldName); -end; - -procedure TffSqlDELETE.Clear; -begin - TableRef.Free; - TableRef := nil; - CondExpWhere.Free; - CondExpWhere := nil; -end; - -procedure TffSqlDELETE.DeleteRecord; -var - Pos: TffInt64; -begin - Pos := T.GetCurrentRecordID; - DeleteList.Add(Pointer(Pos.iLow)); - DeleteList.Add(Pointer(Pos.iHigh)); -end; - -destructor TffSqlDELETE.Destroy; -begin - if T <> nil then - if T.Owner = Self then begin - T.Owner := nil; - T.Free; - end; - Clear; - Joiner.Free; - inherited; -end; - -procedure TffSqlDELETE.EmitSQL(Stream: TStream); -begin - WriteStr(Stream,'DELETE FROM '); - TableRef.EmitSQL(Stream); - WriteStr(Stream,' '); - if assigned(CondExpWhere) then begin - WriteStr(Stream,'WHERE '); - CondExpWhere.EmitSQL(Stream); - end; -end; - -procedure TffSqlDELETE.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); - if assigned(TableRef) then - TableRef.EnumNodes(EnumMethod, Deep); - if assigned(CondExpWhere) then - CondExpWhere.EnumNodes(EnumMethod, Deep); -end; - -function TffSqlDELETE.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlDELETE) - and (BothNil(TableRef, TffSqlDELETE(Other).TableRef) - or (BothNonNil(TableRef, TffSqlDELETE(Other).TableRef) - and TableRef.Equals(TffSqlDELETE(Other).TableRef))) - and (BothNil(CondExpWhere, TffSqlDELETE(Other).CondExpWhere) - or (BothNonNil(CondExpWhere, TffSqlDELETE(Other).CondExpWhere) - and CondExpWhere.Equals(TffSqlDELETE(Other).CondExpWhere))); -end; - -function TffSqlDELETE.Execute(var RowsAffected: Integer) : TffResult; {!!.11} -var - i: Integer; - Pos: TffInt64; -begin - Result := Owner.FDatabase.StartTransaction([T]); - if Result = DBIERR_NONE then - try - if not Bound then - Bind; -{Begin !!.11} - Result := T.EnsureWritable; - if Result <> DBIERR_NONE then begin - Owner.FDatabase.AbortTransaction; - Exit; - end; -{End !!.11} - RowsAffected := 0; - if Joiner = nil then begin - Joiner := TffSqlJoiner.Create(Owner, CondExpWhere); - Joiner.Sources.Add(TFFSqlTableProxySubset.Create(T)); - end; - - Joiner.ClearColumnList; - - Joiner.Target := nil; - DeleteList := TList.Create; - try - Joiner.Execute(Owner.UseIndex, DeleteRecord, jmNone); - T.SetIndex(-1); {switch to raw record id index} {!!.11} - i := 0; - while (Result = DBIERR_NONE) and {!!.11} - (i < DeleteList.Count) do begin {!!.11} - Pos.iLow := TffWord32(DeleteList[i]); - inc(i); - Assert(i < DeleteList.Count); - Pos.iHigh := TffWord32(DeleteList[i]); - inc(i); - T.GetRecordByID(Pos, ffsltExclusive); {!!.11} - Result := T.Delete; {!!.11} - if Result = DBIERR_NONE then {!!.11} - inc(RowsAffected); {!!.11} - end; -// RowsAffected := DeleteList.Count div 2; {Deleted !!.11} - finally - DeleteList.Free; - end; -{Begin !!.11} - if Result = DBIERR_NONE then - Owner.FDatabase.Commit - else - Owner.FDatabase.AbortTransaction; -{End !!.11} - except - Owner.FDatabase.AbortTransaction; - RowsAffected := 0; - raise; - end - else if Result = DBIERR_LOCKED then - FFRaiseException(EffException, ffStrResServer, fferrLockRejected, - [ffcLockExclusive, '', T.Name]) - else - FFRaiseException(EffException, ffStrResServer, Result, [T.Name]); -end; -{--------} - -{!!.11 new} -function TffSqlDELETE.Reduce: Boolean; -begin - if TableRef <> nil then - if TableRef.Reduce then begin - Result := True; - exit; - end; - if CondExpWhere <> nil then - if CondExpWhere.Reduce then begin - Result := True; - exit; - end; - Result := False; -end; - -{ TffSqlUPDATE } - -procedure TffSqlUPDATE.AddColumns(Node: TffSqlNode); -begin - Node.AddColumnDef(Self); -end; - -procedure TffSqlUPDATE.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlUPDATE then begin - Clear; - if TffSqlUPDATE(Source).TableRef <> nil then begin - TableRef := TffSqlTableRef.Create(Self); - TableRef.Assign(TffSqlUPDATE(Source).TableRef); - end; - if TffSqlUPDATE(Source).UpdateList <> nil then begin - UpdateList := TffSqlUpdateList.Create(Self); - UpdateList.Assign(TffSqlUPDATE(Source).UpdateList); - end; - if TffSqlUPDATE(Source).CondExpWhere <> nil then begin - CondExpWhere := TffSqlCondExp.Create(Self); - CondExpWhere.Assign(TffSqlUPDATE(Source).CondExpWhere); - end; - end else - AssignError(Source); -end; - -procedure TffSqlUPDATE.Bind; -var - i: Integer; - F: TFFSqlFieldProxy; -begin - Assert(UpdateList <> nil); - UpdateList.EnumNodes(ClearBindings, False); - T := TableRef.GetTable(Self, False); {!!.11} - if T = nil then - SQLError('Unable to open table: ' + TableRef.SQLName + //TableName + - '. Ensure the table exists and is not in use by ' + - 'another process.'); - - {build column list} - Assert(Assigned(Columns)); - Columns.Clear; - UpdateList.EnumNodes(AddColumns, False); - Assert(Columns.Count > 0); - for i := 0 to Columns.Count - 1 do begin - F := T.FieldByName(Columns[i]); - if F = nil then - SQLError('Unknown field for table ' + TableRef.SQLName + 'in UPDATE statement:' + - Columns[i]); - - if not F.CanUpdate then - SQLError('Changing fields of this type is not currently supported through SQL:' + - Columns[i]); - - TffSqlUpdateItem(Columns.Objects[i]).F := F; - with TffSqlUpdateItem(Columns.Objects[i]) do - if Simplex <> nil then - Simplex.MatchType(F.GetType); - - end; - if CondExpWhere <> nil then - CondExpWhere.MatchType(fftBoolean); - Bound := True; -end; - -function TffSqlUPDATE.BindField(const TableName, - FieldName: string): TFFSqlFieldProxy; -begin - Result := nil; - Assert(T <> nil); - Assert(T is TffSqlTableProxy); - if T.FieldByName(FieldName) <> nil then begin - Result := T.FieldByName(FieldName); - Exit; - end; - SQLError('Unknown field:' + FieldName); -end; - -procedure TffSqlUPDATE.Clear; -begin - TableRef.Free; - TableRef := nil; - UpdateList.Free; - UpdateList := nil; - CondExpWhere.Free; - CondExpWhere := nil; -end; - -procedure TffSqlUPDATE.ClearBindings(Node: TffSqlNode); -begin - Node.ClearBinding; -end; - -destructor TffSqlUPDATE.Destroy; -begin - if T <> nil then - if T.Owner = Self then begin - T.Owner := nil; - T.Free; - end; - Clear; - Joiner.Free; - inherited; -end; - -procedure TffSqlUPDATE.EmitSQL(Stream: TStream); -begin - WriteStr(Stream, 'UPDATE '); - TableRef.EmitSQL(Stream); - WriteStr(Stream,' SET '); - if assigned(UpdateList) then - UpdateList.EmitSQL(Stream); - if assigned(CondExpWhere) then - CondExpWhere.EmitSQL(Stream); -end; - -procedure TffSqlUPDATE.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); - if assigned(TableRef) then - TableRef.EnumNodes(EnumMethod, Deep); - if assigned(UpdateList) then - UpdateList.EnumNodes(EnumMethod, Deep); - if assigned(CondExpWhere) then - CondExpWhere.EnumNodes(EnumMethod, Deep); -end; - -function TffSqlUPDATE.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlUPDATE) - and (BothNil(TableRef, TffSqlUPDATE(Other).TableRef) - or (BothNonNil(TableRef, TffSqlUPDATE(Other).TableRef) - and UpdateList.Equals(TffSqlUPDATE(Other).UpdateList))) - and (BothNil(UpdateList, TffSqlUPDATE(Other).UpdateList) - or (BothNonNil(UpdateList, TffSqlUPDATE(Other).UpdateList) - and UpdateList.Equals(TffSqlUPDATE(Other).UpdateList))) - and (BothNil(CondExpWhere, TffSqlUPDATE(Other).CondExpWhere) - or (BothNonNil(CondExpWhere, TffSqlUPDATE(Other).CondExpWhere) - and CondExpWhere.Equals(TffSqlUPDATE(Other).CondExpWhere))); -end; - -function TffSqlUPDATE.Execute(var RowsAffected: Integer) : TffResult; {!!.11} -var - i: Integer; - Pos: TffInt64; -begin - Result := Owner.FDatabase.StartTransaction([T]); - if Result = DBIERR_NONE then - try - if not Bound then - Bind; -{Begin !!.11} - Result := T.EnsureWritable; - if Result <> DBIERR_NONE then begin - Owner.FDatabase.AbortTransaction; - Exit; - end; -{End !!.11} - FRowsAffected := 0; - if Joiner = nil then begin - Joiner := TffSqlJoiner.Create(Owner, CondExpWhere); - Joiner.Sources.Add( - TFFSqlTableProxySubset.Create( - TFFSqlTableProxy(T))); - end; - - Joiner.ClearColumnList; - - Joiner.Target := nil; - UpdateRecList := TList.Create; - try - Joiner.Execute(Owner.UseIndex, UpdateRecord, jmNone); - T.SetIndex(-1); {switch to raw record id index} {!!.11} - i := 0; - while (Result = DBIERR_NONE) and {!!.11} - (i < UpdateRecList.Count) do begin {!!.11} - Pos.iLow := TffWord32(UpdateRecList[i]); - inc(i); - Assert(i < UpdateRecList.Count); - Pos.iHigh := TffWord32(UpdateRecList[i]); - inc(i); - T.GetRecordByID(Pos, ffsltExclusive); {!!.11} - Result := UpdateList.Update; {!!.11} - if Result = DBIERR_NONE then {!!.11} - inc(FRowsAffected); - end; - finally - UpdateRecList.Free; - end; -{Begin !!.11} - if Result = DBIERR_NONE then begin - Owner.FDatabase.Commit; - RowsAffected := FRowsAffected; - end - else - Owner.FDatabase.AbortTransaction; -{End !!.11} - except - Owner.FDatabase.AbortTransaction; - RowsAffected := 0; - raise; - end - else if Result = DBIERR_LOCKED then - FFRaiseException(EffException, ffStrResServer, fferrLockRejected, - [ffcLockExclusive, '', T.Name]) - else - FFRaiseException(EffException, ffStrResServer, Result, [T.Name]); -end; -{--------} - -{!!.11 new} -function TffSqlUPDATE.Reduce: Boolean; -begin - if TableRef <> nil then - if TableRef.Reduce then begin - Result := True; - exit; - end; - if CondExpWhere <> nil then - if CondExpWhere.Reduce then begin - Result := True; - exit; - end; - if UpdateList <> nil then - if UpdateList.Reduce then begin - Result := True; - exit; - end; - Result := False; -end; - -procedure TffSqlUPDATE.UpdateRecord; -var - Pos: TffInt64; -begin - Pos := T.GetCurrentRecordID; - UpdateRecList.Add(Pointer(Pos.iLow)); - UpdateRecList.Add(Pointer(Pos.iHigh)); -end; - -{ TffSqlUpdateItem } - -procedure TffSqlUpdateItem.AddColumnDef(Target: TffSqlColumnListOwner); -begin - Target.Columns.AddObject(ColumnName, Self); -end; - -procedure TffSqlUpdateItem.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlUpdateItem then begin - Simplex.Free; - Simplex := nil; - ColumnName := TffSqlUpdateItem(Source).ColumnName; - Default := TffSqlUpdateItem(Source).Default; - if TffSqlUpdateItem(Source).Simplex <> nil then begin - Simplex := TffSqlSimpleExpression.Create(Self); - Simplex.Assign(TffSqlUpdateItem(Source).Simplex); - end; - end else - AssignError(Source); -end; - -destructor TffSqlUpdateItem.Destroy; -begin - Simplex.Free; - inherited; -end; - -procedure TffSqlUpdateItem.EmitSQL(Stream: TStream); -begin - WriteStr(Stream, ColumnName); - WriteStr(Stream,' = '); - if Default then - WriteStr(Stream, 'DEFAULT ') - else - if Simplex = nil then - WriteStr(Stream, 'NULL ') - else - Simplex.EmitSQL(Stream); -end; - -procedure TffSqlUpdateItem.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); - if Simplex <> nil then - Simplex.EnumNodes(EnumMethod, Deep); -end; - -function TffSqlUpdateItem.Equals(Other: TffSqlNode): Boolean; -begin - Result := - (Other is TffSqlUpdateItem) - and (ColumnName = TffSqlUpdateItem(Other).ColumnName) - and (Default = TffSqlUpdateItem(Other).Default) - and (BothNil(Simplex, TffSqlUpdateItem(Other).Simplex) - or (BothNonNil(Simplex, TffSqlUpdateItem(Other).Simplex) - and Simplex.Equals(TffSqlUpdateItem(Other).Simplex))); -end; - -function TffSqlUpdateItem.Reduce: Boolean; -begin - Result := (Simplex <> nil) and Simplex.Reduce; -end; - -procedure TffSqlUpdateItem.Update; -begin - Assert(F <> nil); - if Simplex <> nil then - F.SetValue(Simplex.GetValue) - else - F.SetFieldToNull; -end; - -{ TffSqlUpdateList } - -function TffSqlUpdateList.AddItem( - NewValue: TffSqlUpdateItem): TffSqlUpdateItem; -begin - FUpdateItemList.Add(NewValue); - Result := NewValue; -end; - -procedure TffSqlUpdateList.Assign(const Source: TffSqlNode); -var - i : Integer; -begin - if Source is TffSqlValueList then begin - Clear; - for i := 0 to pred(TffSqlValueList(Source).ValueCount) do - AddItem(TffSqlUpdateItem.Create(Self)).Assign( - TffSqlValueList(Source).ValueItem[i]); - end else - AssignError(Source); -end; - -procedure TffSqlUpdateList.Clear; -var - i : Integer; -begin - for i := 0 to pred(UpdateCount) do - UpdateItem[i].Free; - FUpdateItemList.Clear; -end; - -constructor TffSqlUpdateList.Create(AParent: TffSqlNode); -begin - inherited; - FUpdateItemList := TList.Create; -end; - -destructor TffSqlUpdateList.Destroy; -begin - Clear; - FUpdateItemList.Free; - inherited; -end; - -procedure TffSqlUpdateList.EmitSQL(Stream: TStream); -var - i : Integer; - First: Boolean; -begin - First := True; - for i := 0 to pred(UpdateCount) do begin - if First then - First := False - else - WriteStr(Stream, ', '); - UpdateItem[i].EmitSQL(Stream); - end; -end; - -procedure TffSqlUpdateList.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -var - i: Integer; -begin - EnumMethod(Self); - for i := 0 to pred(UpdateCount) do - UpdateItem[i].EnumNodes(EnumMethod, Deep); -end; - -function TffSqlUpdateList.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if Other is TffSqlValueList then begin - if UpdateCount <> TffSqlUpdateList(Other).UpdateCount then - exit; - for i := 0 to pred(UpdateCount) do - if not UpdateItem[i].Equals(TffSqlUpdateList(Other).UpdateItem[i]) then - exit; - Result := True; - end; -end; - -function TffSqlUpdateList.GetUpdateCount: Integer; -begin - Result := FUpdateItemList.Count; -end; - -function TffSqlUpdateList.GetUpdateItem(Index: Integer): TffSqlUpdateItem; -begin - Result := TffSqlUpdateItem(FUpdateItemList[Index]); -end; - -{!!.11 new} -function TffSqlUpdateList.Reduce: Boolean; -var - i: Integer; -begin - for i := 0 to UpdateCount - 1 do - if UpdateItem[i].Reduce then begin - Result := True; - exit; - end; - Result := False; -end; - -function TffSqlUpdateList.Update : TffResult; {!!.11} -var - i: Integer; -begin - for i := 0 to UpdateCount - 1 do - UpdateItem[i].Update; - Assert(Parent <> nil); - Assert(TObject(Parent) is TffSqlUpdate); - Result := TffSqlUpdate(Parent).T.Update; {!!.11} -end; - -{ TffSqlColumnListOwner } - -constructor TffSqlColumnListOwner.Create(AParent: TffSqlNode); -begin - inherited; - Columns := TStringList.Create; -end; - -destructor TffSqlColumnListOwner.Destroy; -begin - Columns.Free; - inherited; -end; - -{ TffSqlNonJoinTablePrimary } - -procedure TffSqlNonJoinTablePrimary.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlNonJoinTablePrimary then begin - Clear; - if TffSqlNonJoinTablePrimary(Source).SelectSt <> nil then begin - SelectSt := TFFSqlSELECT.Create(Self); - SelectSt.Assign(TffSqlNonJoinTablePrimary(Source).SelectSt); - end; - if TffSqlNonJoinTablePrimary(Source).ValueList <> nil then begin - ValueList := TffSqlValueList.Create(Self); - ValueList.Assign(TffSqlNonJoinTablePrimary(Source).ValueList); - end; - if TffSqlNonJoinTablePrimary(Source).NonJoinTableExp <> nil then begin - NonJoinTableExp := TffSqlNonJoinTableExp.Create(Self); - NonJoinTableExp.Assign(TffSqlNonJoinTablePrimary(Source).NonJoinTableExp); - end; - if TffSqlNonJoinTablePrimary(Source).TableRef <> nil then begin - TableRef := TffSqlTableRef.Create(Self); - TableRef.Assign(TffSqlNonJoinTablePrimary(Source).TableRef); - end; - end else - AssignError(Source); -end; - -function TffSqlNonJoinTablePrimary.BindFieldDown(const TableName, - FieldName: string): TFFSqlFieldProxy; -begin - if SelectSt <> nil then - Result := SelectSt.BindField(TableName, FieldName) - else - if NonJoinTableExp <> nil then - Result := NonJoinTableExp.BindFieldDown(TableName, FieldName) - else - if TableRef <> nil then - Result := TableRef.BindFieldDown(TableName, FieldName) - else - Result := nil; -end; - -function TffSqlNonJoinTablePrimary.BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; -begin - if SelectSt <> nil then - Result := SelectSt.BindTable(AOwner, TableName) - else - if NonJoinTableExp <> nil then - Result := NonJoinTableExp.BindTable(AOwner, TableName) - else - if TableRef <> nil then - Result := TableRef.BindTable(AOwner, TableName) - else - Result := nil; -end; - -procedure TffSqlNonJoinTablePrimary.Clear; -begin - SelectSt.Free; - SelectSt := nil; - ValueList.Free; - ValueList := nil; - NonJoinTableExp.Free; - NonJoinTableExp := nil; - TableRef.Free; - TableRef := nil; -end; - -function TffSqlNonJoinTablePrimary.DependsOn( - Table: TFFSqlTableProxy): Boolean; -begin - if SelectSt <> nil then - Result := SelectSt.DependsOn(Table) - else - if NonJoinTableExp <> nil then - Result := NonJoinTableExp.DependsOn(Table) - else - if TableRef <> nil then - Result := TableRef.DependsOn(Table) - else - Result := False; -end; - -destructor TffSqlNonJoinTablePrimary.Destroy; -begin - Clear; - inherited; -end; - -procedure TffSqlNonJoinTablePrimary.EmitSQL(Stream: TStream); -begin - if SelectSt <> nil then - SelectSt.EmitSQL(Stream); - if ValueList <> nil then - ValueList.EmitSQL(Stream); - if NonJoinTableExp <> nil then begin - WriteStr(Stream,' ('); - NonJoinTableExp.EmitSQL(Stream); - WriteStr(Stream,')'); - end; - if TableRef <> nil then begin - WriteStr(Stream,' TABLE '); - TableRef.EmitSQL(Stream); - end; -end; - -procedure TffSqlNonJoinTablePrimary.EnsureResultTable(NeedData: Boolean); -begin - if SelectSt <> nil then - SelectSt.EnsureResultTable(NeedData); - if NonJoinTableExp <> nil then - NonJoinTableExp.EnsureResultTable(NeedData); -end; - -procedure TffSqlNonJoinTablePrimary.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); - if SelectSt <> nil then - SelectSt.EnumNodes(EnumMethod, Deep); - if ValueList <> nil then - ValueList.EnumNodes(EnumMethod, Deep); - if NonJoinTableExp <> nil then - NonJoinTableExp.EnumNodes(EnumMethod, Deep); - if TableRef <> nil then - TableRef.EnumNodes(EnumMethod, Deep); -end; - -function TffSqlNonJoinTablePrimary.Equals(Other: TffSqlNode): Boolean; -begin - Result := - Other is TffSqlNonJoinTablePrimary - and ((BothNil(SelectSt, TffSqlNonJoinTablePrimary(Other).SelectSt) - or (BothNonNil(SelectSt, TffSqlNonJoinTablePrimary(Other).SelectSt) - and SelectSt.Equals(TffSqlNonJoinTablePrimary(Other).SelectSt)))) - and ((BothNil(ValueList, TffSqlNonJoinTablePrimary(Other).ValueList) - or (BothNonNil(ValueList, TffSqlNonJoinTablePrimary(Other).ValueList) - and ValueList.Equals(TffSqlNonJoinTablePrimary(Other).ValueList)))) - and ((BothNil(NonJoinTableExp, TffSqlNonJoinTablePrimary(Other).NonJoinTableExp) - or (BothNonNil(NonJoinTableExp, TffSqlNonJoinTablePrimary(Other).NonJoinTableExp) - and NonJoinTableExp.Equals(TffSqlNonJoinTablePrimary(Other).NonJoinTableExp)))) - and ((BothNil(TableRef, TffSqlNonJoinTablePrimary(Other).TableRef) - or (BothNonNil(TableRef, TffSqlNonJoinTablePrimary(Other).TableRef) - and TableRef.Equals(TffSqlNonJoinTablePrimary(Other).TableRef)))); -end; - -procedure TffSqlNonJoinTablePrimary.Execute( - var aLiveResult: Boolean; var aCursorID: TffCursorID; - var RecordsRead: Integer); -begin - if assigned(SelectSt) then - SelectSt.Execute(aLiveResult, aCursorID, RecordsRead) - else - if assigned(ValueList) then - ValueList.Execute(aLiveResult, aCursorID, RecordsRead) - else - if assigned(NonJoinTableExp) then - NonJoinTableExp.Execute(aLiveResult, aCursorID, RecordsRead) - else - if assigned(TableRef) then - TableRef.Execute(aLiveResult, aCursorID, RecordsRead) - else - Assert(False); -end; - -function TffSqlNonJoinTablePrimary.GetResultTable: TffSqlTableProxy; -begin - Result := nil; - if assigned(SelectSt) then - Result := SelectSt.ResultTable - else - if assigned(ValueList) then - Result := ValueList.ResultTable - else - if assigned(NonJoinTableExp) then - Result := NonJoinTableExp.ResultTable - else - if assigned(TableRef) then - Result := TableRef.ResultTable - else - Assert(False); -end; - -function TffSqlNonJoinTablePrimary.Reduce: Boolean; -begin - Result := False; - if assigned(SelectSt) then - Result := SelectSt.Reduce - else - if assigned(ValueList) then - Result := ValueList.Reduce - else - if assigned(NonJoinTableExp) then - Result := NonJoinTableExp.Reduce - else - if assigned(TableRef) then - Result := False //TableRef.Reduce - else - Assert(False); -end; - -function TffSqlNonJoinTablePrimary.TargetFieldFromSourceField( - const F: TffSqlFieldProxy): TffSqlFieldProxy; -begin - Result := nil; - if assigned(SelectSt) then - Result := SelectSt.TargetFieldFromSourceField(F) - else - if assigned(ValueList) then - Result := nil - else - if assigned(NonJoinTableExp) then - Result := NonJoinTableExp.TargetFieldFromSourceField(F) - else - if assigned(TableRef) then - Result := TableRef.TargetFieldFromSourceField(F) - else - Assert(False); -end; - -{ TffSqlTableExp } - -procedure TffSqlTableExp.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlTableExp then begin - Clear; - if TffSqlTableExp(Source).NestedTableExp <> nil then begin - NestedTableExp := TffSqlTableExp.Create(Self); - NestedTableExp.Assign(TffSqlTableExp(Source).NestedTableExp); - end; - if TffSqlTableExp(Source).JoinTableExp <> nil then begin - JoinTableExp := TffSqlJoinTableExp.Create(Self); - JoinTableExp.Assign(TffSqlTableExp(Source).JoinTableExp); - end; - if TffSqlTableExp(Source).NonJoinTableExp <> nil then begin - NonJoinTableExp := TffSqlNonJoinTableExp.Create(Self); - NonJoinTableExp.Assign(TffSqlTableExp(Source).NonJoinTableExp); - end; - end else - AssignError(Source); -end; - -procedure TffSqlTableExp.Clear; -begin - NestedTableExp.Free; - NestedTableExp := nil; - JoinTableExp.Free; - JoinTableExp := nil; - NonJoinTableExp.Free; - NonJoinTableExp := nil; -end; - -destructor TffSqlTableExp.Destroy; -begin - Clear; - inherited; -end; - -procedure TffSqlTableExp.EmitSQL(Stream: TStream); -begin - if assigned(NestedTableExp) then - NestedTableExp.EmitSQL(Stream); - if assigned(JoinTableExp) then - JoinTableExp.EmitSQL(Stream); - if assigned(NonJoinTableExp) then - NonJoinTableExp.EmitSQL(Stream); -end; - -function TffSqlTableExp.BindFieldDown(const TableName, - FieldName: string): TFFSqlFieldProxy; -begin - if assigned(NestedTableExp) then - Result := NestedTableExp.BindFieldDown(TableName, FieldName) - else - if assigned(JoinTableExp) then - Result := JoinTableExp.BindFieldDown(TableName, FieldName) - else - if assigned(NonJoinTableExp) then - Result := NonJoinTableExp.BindFieldDown(TableName, FieldName) - else - Result := nil; -end; - -function TffSqlTableExp.BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; -begin - if assigned(NestedTableExp) then - Result := NestedTableExp.BindTable(AOwner, TableName) - else - if assigned(JoinTableExp) then - Result := JoinTableExp.BindTable(AOwner, TableName) - else - if assigned(NonJoinTableExp) then - Result := NonJoinTableExp.BindTable(AOwner, TableName) - else - Result := nil; -end; - -function TffSqlTableExp.CheckNoDups: Boolean; -begin - EnsureResultTable(True); - Result := not ResultTable.HasDuplicates(True); {!!.13} -end; - -function TffSqlTableExp.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - if assigned(NestedTableExp) then - Result := NestedTableExp.DependsOn(Table) - else - if assigned(JoinTableExp) then - Result := JoinTableExp.DependsOn(Table) - else - if assigned(NonJoinTableExp) then - Result := NonJoinTableExp.DependsOn(Table) - else - Result := False; -end; - -procedure TffSqlTableExp.EnsureResultTable(NeedData: Boolean); -begin - if assigned(NestedTableExp) then - NestedTableExp.EnsureResultTable(NeedData); - if assigned(JoinTableExp) then - JoinTableExp.EnsureResultTable(NeedData); - if assigned(NonJoinTableExp) then - NonJoinTableExp.EnsureResultTable(NeedData); -end; - -procedure TffSqlTableExp.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); - if assigned(NestedTableExp) then - NestedTableExp.EnumNodes(EnumMethod, Deep); - if assigned(JoinTableExp) then - JoinTableExp.EnumNodes(EnumMethod, Deep); - if assigned(NonJoinTableExp) then - NonJoinTableExp.EnumNodes(EnumMethod, Deep); -end; - -function TffSqlTableExp.Equals(Other: TffSqlNode): Boolean; -begin - Result := - Other is TffSqlTableExp - and ((BothNil(NestedTableExp, TffSqlTableExp(Other).NestedTableExp) - or (BothNonNil(NestedTableExp, TffSqlTableExp(Other).NestedTableExp) - and NestedTableExp.Equals(TffSqlTableExp(Other).NestedTableExp)))) - and ((BothNil(JoinTableExp, TffSqlTableExp(Other).JoinTableExp) - or (BothNonNil(JoinTableExp, TffSqlTableExp(Other).JoinTableExp) - and JoinTableExp.Equals(TffSqlTableExp(Other).JoinTableExp)))) - and ((BothNil(NonJoinTableExp, TffSqlTableExp(Other).NonJoinTableExp) - or (BothNonNil(NonJoinTableExp, TffSqlTableExp(Other).NonJoinTableExp) - and NonJoinTableExp.Equals(TffSqlTableExp(Other).NonJoinTableExp)))); -end; - -procedure TffSqlTableExp.Execute( - var aLiveResult: Boolean; var aCursorID: TffCursorID; - var RecordsRead: Integer); -begin - if assigned(NestedTableExp) then - NestedTableExp.Execute(aLiveResult, aCursorID, RecordsRead); - if assigned(JoinTableExp) then - JoinTableExp.Execute(aLiveResult, aCursorID, RecordsRead); - if assigned(NonJoinTableExp) then - NonJoinTableExp.Execute(aLiveResult, aCursorID, RecordsRead); -end; - -{!!.11 new} -function TffSqlTableExp.GetFieldsFromTable(const TableName: string; List: TList): - TffSqlTableProxy; -{-returns fields from table that are ultimately coming from the table - specified in the TableName argument. NIL if not found.} -begin - Result := nil; - if assigned(NestedTableExp) then - Result := NestedTableExp.GetFieldsFromTable(TableName, List) - else - if assigned(JoinTableExp) then - Result := JoinTableExp.GetFieldsFromTable(TableName, List) - else - if assigned(NonJoinTableExp) then - Result := NonJoinTableExp.GetFieldsFromTable(TableName, List) - else - Assert(False); -end; - -function TffSqlTableExp.GetResultTable: TFFSqlTableProxy; -begin - Result := nil; - if assigned(NestedTableExp) then - Result := NestedTableExp.ResultTable - else - if assigned(JoinTableExp) then - Result := JoinTableExp.ResultTable - else - if assigned(NonJoinTableExp) then - Result := NonJoinTableExp.ResultTable - else - Assert(False); -end; - -function TffSqlTableExp.Reduce: Boolean; -begin - if assigned(NestedTableExp) then - Result := NestedTableExp.Reduce - else - if assigned(JoinTableExp) then - Result := JoinTableExp.Reduce - else - Result := False; - if assigned(NonJoinTableExp) then - Result := Result or NonJoinTableExp.Reduce; -end; - -function TffSqlTableExp.TargetFieldFromSourceField( - const F: TffSqlFieldProxy): TffSqlFieldProxy; -begin - Result := nil; - if assigned(NestedTableExp) then - Result := NestedTableExp.TargetFieldFromSourceField(F) - else - if assigned(JoinTableExp) then - Result := JoinTableExp.TargetFieldFromSourceField(F) - else - if assigned(NonJoinTableExp) then - NonJoinTableExp.TargetFieldFromSourceField(F) - else - Assert(False); -end; - -{ TffSqlJoinTableExp } - -function TffSqlJoinTableExp.BuildSimpleFieldExpr(AOwner: TffSqlNode; - const ATableName, AFieldName: string; AField: TffSqlFieldProxy - ): TffSqlSimpleExpression; -var - Term: TffSqlTerm; - Fact: TffSqlFactor; - FieldRef: TffSqlFieldRef; -begin - Result := TffSqlSimpleExpression.Create(AOwner); - Term := TffSqlTerm.Create(Result); - Fact := TffSqlFactor.Create(Term); - FieldRef := TffSqlFieldRef.Create(Fact); - FieldRef.TableName := ATableName; - FieldRef.FieldName := AFieldName; - FieldRef.FField := AField; - Fact.FieldRef := FieldRef; - Term.AddFactor(Fact); - Result.AddTerm(Term); -end; - -procedure TffSqlJoinTableExp.ClearColumns; -var - i: Integer; -begin - if Columns = nil then exit; - for i := 0 to Columns.Count - 1 do - if TObject(Columns.Objects[i]) is TffSqlSimpleExpression then - TObject(Columns.Objects[i]).Free; - Columns.Clear; -end; - -procedure TffSqlJoinTableExp.Bind; -var - i, j : Integer; - FL, FR: TffSqlFieldProxy; - lCondTerm: TffSqlCondTerm; - lCondFact: TffSqlCondFactor; - lCondPrim: TffSqlCondPrimary; - lSimp1, lSimp2, cSimp, cSimp1, cSimp2: TffSqlSimpleExpression; - cTerm: TffSqlTerm; - cFact: TffSqlFactor; - cScalar : TffSqlScalarFunc; - cCoalesce : TffSqlCoalesceExpression; - S: string; {!!.11} - OS: TffSqlSELECT; - CF, NewCF: TffSqlCondFactor; - CP: TffSqlCondPrimary; -const - UorN: array[Boolean] of string = ('UNION', 'NATURAL'); -begin - if JoinType = jtUnion then - SQLError('UNION JOIN is not currently supported by FlashFiler SQL'); - if Natural and (JoinType = jtUnion) then - SQLError('NATURAL and UNION cannot both be specified on a JOIN'); - if Natural or (JoinType = jtUnion) then begin - if CondExp <> nil then - SQLError(UorN[Natural] + ' joins do not accept an ON clause'); - if UsingList <> nil then - sQLError(UorN[Natural] + ' joins do not accept a USING clause'); - end; - if not Natural and not (JoinType in [jtCross,jtUnion]) then begin - if (CondExp = nil) and (UsingList = nil) then - SQLError('The join must have either an ON or a USING clause'); - end; - if CondExp <> nil then - CondExp.EnumNodes(ClearBindings, False); - Assert(assigned(TableRef1)); - TL := TableRef1.BindTable(Self, TableRef1.TableName); - Assert(assigned(TL)); - Assert(assigned(TableRef2)); - TR := TableRef2.BindTable(Self, TableRef2.TableName); - Assert(assigned(TR)); - - {build column list} - Assert(Assigned(Columns)); - ClearColumns; - - if Natural then begin - UsingCondExp := TffSqlCondExp.Create(Self); - lCondTerm := TffSqlCondTerm.Create(UsingCondExp); - for i := 0 to TL.FieldCount - 1 do begin - FL := TL.Field(i); - FR := TR.FieldByName(FL.Name); - if FR <> nil then begin - {common field} - lCondFact := TffSqlCondFactor.Create(lCondTerm); - lCondPrim := TffSqlCondPrimary.Create(lCondFact); - lSimp1 := BuildSimpleFieldExpr(lCondPrim, TableRef1.SQLName, - FL.Name, FL); - lSimp2 := BuildSimpleFieldExpr(lCondPrim, TableRef2.SQLName, - FR.Name, FR); - case JoinType of - jtRightOuter : - Columns.AddObject(FL.Name, FR); - jtFullOuter : - begin - cSimp := TffSqlSimpleExpression.Create(Self); - cTerm := TffSqlTerm.Create(cSimp); - cFact := TffSqlFactor.Create(cTerm); - cScalar := TffSqlScalarFunc.Create(cFact); - cScalar.SQLFunction := sfCoalesce; - cCoalesce := TffSqlCoalesceExpression.Create(cScalar); - cSimp1 := BuildSimpleFieldExpr(cCoalesce, TableRef1.SQLName, - FL.Name, FL); - cSimp2 := BuildSimpleFieldExpr(cCoalesce, TableRef2.SQLName, - FR.Name, FR); - cCoalesce.AddArg(cSimp1); - cCoalesce.AddArg(cSimp2); - cScalar.CoalesceExp := cCoalesce; - cFact.ScalarFunc := cScalar; - cTerm.AddFactor(cFact); - cSimp.AddTerm(cTerm); - Columns.AddObject(FL.Name, cSimp); - end; - else - Columns.AddObject(FL.Name, FL); - end; - lCondPrim.SimpleExp1 := lSimp1; - lCondPrim.SimpleExp2 := lSimp2; - lCondPrim.RelOp := roEQ; - lCondFact.CondPrimary := lCondPrim; - lCondTerm.AddCondFactor(lCondFact); - end; - end; - if lCondTerm.CondFactorCount = 0 then begin - lCondTerm.Free; - UsingCondExp.Free; - UsingCondExp := nil; - end else begin - UsingCondExp.AddCondTerm(lCondTerm); - UsingCondExp.MatchType(fftBoolean); - end; - for i := 0 to TL.FieldCount - 1 do begin - FL := TL.Field(i); - if Columns.IndexOf(FL.Name) = -1 then - Columns.AddObject(FL.Name, FL); - end; - for i := 0 to TR.FieldCount - 1 do begin - FR := TR.Field(i); - if Columns.IndexOf(FR.Name) = -1 then - Columns.AddObject(FR.Name, FR); - end; - end else - if UsingList <> nil then begin - UsingCondExp := TffSqlCondExp.Create(Self); - lCondTerm := TffSqlCondTerm.Create(UsingCondExp); - for i := 0 to UsingList.UsingCount - 1 do begin - lCondFact := TffSqlCondFactor.Create(lCondTerm); - lCondPrim := TffSqlCondPrimary.Create(lCondFact); - FL := TL.FieldByName(UsingList.UsingItem[i].ColumnName); - if FL = nil then - SQLError(format('Field %s does not exist in table %s.', - [UsingList.UsingItem[i].ColumnName, TableRef1.SQLName])); - FR := TR.FieldByName(UsingList.UsingItem[i].ColumnName); - if FR = nil then - SQLError(format('Field %s does not exist in table %s.', - [UsingList.UsingItem[i].ColumnName, TableRef2.SQLName])); - lSimp1 := BuildSimpleFieldExpr(lCondPrim, TableRef1.SQLName, - FL.Name, FL); - lSimp2 := BuildSimpleFieldExpr(lCondPrim, TableRef2.SQLName, - FR.Name, FR); - case JoinType of - jtRightOuter : - Columns.AddObject(FL.Name, FR); - jtFullOuter : - begin - cSimp := TffSqlSimpleExpression.Create(Self); - cTerm := TffSqlTerm.Create(cSimp); - cFact := TffSqlFactor.Create(cTerm); - cScalar := TffSqlScalarFunc.Create(cFact); - cScalar.SQLFunction := sfCoalesce; - cCoalesce := TffSqlCoalesceExpression.Create(cScalar); - cSimp1 := BuildSimpleFieldExpr(cCoalesce, TableRef1.SQLName, - FL.Name, FL); - cSimp2 := BuildSimpleFieldExpr(cCoalesce, TableRef2.SQLName, - FR.Name, FR); - cCoalesce.AddArg(cSimp1); - cCoalesce.AddArg(cSimp2); - cScalar.CoalesceExp := cCoalesce; - cFact.ScalarFunc := cScalar; - cTerm.AddFactor(cFact); - cSimp.AddTerm(cTerm); - Columns.AddObject(FL.Name, cSimp); - end; - else - Columns.AddObject(FL.Name, FL); - end; - lCondPrim.SimpleExp1 := lSimp1; - lCondPrim.SimpleExp2 := lSimp2; - lCondPrim.RelOp := roEQ; - lCondFact.CondPrimary := lCondPrim; - lCondTerm.AddCondFactor(lCondFact); - end; - UsingCondExp.AddCondTerm(lCondTerm); - (* - {!!.11 begin} - {if this join is enclosed in a SELECT with a WHERE clause, - and if the WHERE clause consists only of a single conditional term, - and if any of the conditional factors limit either side of the join, - then copy those conditional factors into the join condition} - //writeln(SqlText); - //writeln(' ',CondExp.SqlText); - OS := OwnerSelect; - if (OS <> nil) - and (OS.CondExpWhere <> nil) - and (OS.CondExpWhere.CondTermCount = 1) then begin - for i := 0 to OS.CondExpWhere.CondTerm[0].CondFactorCount - 1 do begin - CF := OS.CondExpWhere.CondTerm[0].CondFactor[i]; - //writeln(' ',CF.SqlText); - if not CF.IsConstant - and not CF.UnaryNot then begin - CP := CF.CondPrimary; - if CP.RelOp in [roEQ, roLE, roL, roG, roGE] then begin - if CP.SimpleExp2.IsConstant or CP.SimpleExp2.IsParameter then begin - if Cp.SimpleExp1.TermCount = 1 then - if Cp.SimpleExp1.Term[0].FactorCount = 1 then - if Cp.SimpleExp1.Term[0].Factor[0].FieldRef <> nil then - if (Cp.SimpleExp1.Term[0].Factor[0].FieldRef.TableName - = TableRef1.TableName) - or (Cp.SimpleExp1.Term[0].Factor[0].FieldRef.TableName - = TableRef1.Alias) then begin - //writeln(' found left constraint:', CP.SqlText); - NewCF := TffSqlCondFactor.Create(lCondTerm); - NewCF.Assign(CF); - lCondTerm.AddCondFactor(NewCF); - //writeln(' ',CondExp.SqlText); - end - else - if Cp.SimpleExp1.Term[0].Factor[0].FieldRef <> nil then - if (Cp.SimpleExp1.Term[0].Factor[0].FieldRef.TableName - = TableRef2.TableName) - or (Cp.SimpleExp1.Term[0].Factor[0].FieldRef.TableName - = TableRef2.Alias) then begin - //writeln(' found right constraint', CP.SqlText); - NewCF := TffSqlCondFactor.Create(lCondTerm); - NewCF.Assign(CF); - lCondTerm.AddCondFactor(NewCF); - //writeln(' ',CondExp.SqlText); - end; - end; - end; - end; - end; - - end; - {!!.11 end} - *) - UsingCondExp.MatchType(fftBoolean); - for i := 0 to TL.FieldCount - 1 do begin - FL := TL.Field(i); - if Columns.IndexOf(FL.Name) = -1 then - Columns.AddObject(FL.Name, FL); - end; - for i := 0 to TR.FieldCount - 1 do begin - FL := TR.Field(i); - j := Columns.IndexOf(FL.Name); - if j = -1 then - Columns.AddObject(FL.Name, FL) - else - if j >= UsingList.UsingCount then - Columns.AddObject(TR.Name + '.' + FL.Name, FL); - end; - end else begin - for i := 0 to TL.FieldCount - 1 do - Columns.AddObject(TL.Field(i).Name, TL.Field(i)); - for i := 0 to TR.FieldCount - 1 do - if Columns.IndexOf(TR.Field(i).Name) = -1 then - Columns.AddObject(TR.Field(i).Name, TR.Field(i)) - {!!.11 begin} - else begin - S := TR.Name + '.' + TR.Field(i).Name; - if Columns.IndexOf(S) = -1 then - Columns.AddObject(S, TR.Field(i)) - else begin - j := 2; - while Columns.IndexOf(S + '_' + IntToStr(j)) <> -1 do - inc(j); - Columns.AddObject(S+ '_' + IntToStr(j), TR.Field(i)); - end; - end; - {!!.11 end} - end; - - if (CondExp <> nil) then begin - {!!.11 begin} - if (CondExp.CondTermCount = 1) then begin - {if this join is enclosed in a SELECT with a WHERE clause, - and if the WHERE clause consists only of a single conditional term, - and if any of the conditional factors limit either side of the join, - then copy those conditional factors into the join condition} - //writeln(SqlText); - //writeln(' ',CondExp.SqlText); - OS := OwnerSelect; - if (OS <> nil) - and (OS.CondExpWhere <> nil) - and (OS.CondExpWhere.CondTermCount = 1) then begin - for i := 0 to OS.CondExpWhere.CondTerm[0].CondFactorCount - 1 do begin - CF := OS.CondExpWhere.CondTerm[0].CondFactor[i]; - //writeln(' ',CF.SqlText); - if not CF.IsConstant - and not CF.UnaryNot then begin - CP := CF.CondPrimary; - if CP.RelOp in [roEQ, roLE, roL, roG, roGE, roNE] then begin - if CP.SimpleExp2.IsConstant or CP.SimpleExp2.IsParameter then begin - if Cp.SimpleExp1.TermCount = 1 then - if Cp.SimpleExp1.Term[0].FactorCount = 1 then - if Cp.SimpleExp1.Term[0].Factor[0].FieldRef <> nil then - if (Cp.SimpleExp1.Term[0].Factor[0].FieldRef.TableName <> '') {!!.13} - and ( {!!.13} - (Cp.SimpleExp1.Term[0].Factor[0].FieldRef.TableName - = TableRef1.TableName) - or (Cp.SimpleExp1.Term[0].Factor[0].FieldRef.TableName - = TableRef1.Alias)) then begin {!!.13} - //writeln(' found left constraint:', CP.SqlText); - NewCF := TffSqlCondFactor.Create(CondExp.CondTerm[0]); - NewCF.Assign(CF); - CondExp.CondTerm[0].AddCondFactor(NewCF); - //writeln(' ',CondExp.SqlText); - end - else - if Cp.SimpleExp1.Term[0].Factor[0].FieldRef <> nil then - if (Cp.SimpleExp1.Term[0].Factor[0].FieldRef.TableName <> '') {!!.13} - and ( {!!.13} - ((Cp.SimpleExp1.Term[0].Factor[0].FieldRef.TableName - = TableRef2.TableName) - or (Cp.SimpleExp1.Term[0].Factor[0].FieldRef.TableName - = TableRef2.Alias))) then begin {!!.13} - //writeln(' found right constraint', CP.SqlText); - NewCF := TffSqlCondFactor.Create(CondExp.CondTerm[0]); - NewCF.Assign(CF); - CondExp.CondTerm[0].AddCondFactor(NewCF); - //writeln(' ',CondExp.SqlText); - end; - end; - end; - end; - end; - - end; - end; - {!!.11 end} - CondExp.MatchType(fftBoolean); - end; - - Bound := True; -end; - -function TffSqlJoinTableExp.BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; -begin - Result := TableRef1.BindTable(AOwner, TableName); - if Result = nil then - Result := TableRef2.BindTable(AOwner, TableName); -end; - -function TffSqlJoinTableExp.BindField(const TableName, - FieldName: string): TFFSqlFieldProxy; -var - T: TFFSqlTableProxy; -begin - Result := nil; - if TableName <> '' then begin - T := TableRef1.BindTable(Self, TableName); - if T <> nil then - if T <> TL then begin - Result := TableRef1.TargetFieldFromSourceField(T.FieldByName(FieldName)); - exit; - end; - if T = nil then begin - T := TableRef2.BindTable(Self, TableName); - if T <> nil then {!!.11} - if T <> TR then begin - Result := TableRef2.TargetFieldFromSourceField(T.FieldByName(FieldName)); - exit; - end; - end; - if T = nil then - SQLError('Unknown field:' + TableName + '.' + FieldName); - - Assert(T <> nil); - Result := T.FieldByName(FieldName); - if Result = nil then - SQLError('Unknown field:' + TableName + '.' + FieldName); - end else begin - if TL.FieldByName(FieldName) <> nil then begin - Result := TL.FieldByName(FieldName); - Exit; - end; - if TR.FieldByName(FieldName) <> nil then begin - Result := TR.FieldByName(FieldName); - Exit; - end; - SQLError('Unknown field:' + FieldName); - end; -end; - -function TffSqlJoinTableExp.BindFieldDown(const TableName, - FieldName: string): TFFSqlFieldProxy; -var - i: Integer; -begin - Result := nil; - if TableName <> '' then begin - Result := TableRef1.BindFieldDown(TableName, FieldName); - if Result = nil then - Result := TableRef2.BindFieldDown(TableName, FieldName); - if Result = nil then - exit; - - EnsureResultTable(False{True}); - - for i := 0 to pred(Columns.Count) do - if Columns.Objects[i] = Result then begin - Result := FResultTable.Field(i); - exit; - end; - - Result := nil; - end else begin - if TL.FieldByName(FieldName) <> nil then begin - Result := TL.FieldByName(FieldName); - Exit; - end; - if TR.FieldByName(FieldName) <> nil then begin - Result := TR.FieldByName(FieldName); - Exit; - end; - SQLError('Unknown field:' + FieldName); - end; -end; - -procedure TffSqlJoinTableExp.ClearBindings(Node: TffSqlNode); -begin - Node.ClearBinding; -end; - -function TffSqlJoinTableExp.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - if not Bound then - Bind; - Result := - ((UsingCondExp <> nil) and UsingCondExp.DependsOn(Table)) - or ((CondExp <> nil) and CondExp.DependsOn(Table)); -end; - -function TffSqlJoinTableExp.DoJoin(NeedData: Boolean): TffSqlTableProxy; -var - i : Integer; - T2 : TffSqlTableProxy; - F : TffSqlFieldProxy; - N : TffSqlNode; - FieldDefList: TffSqlFieldDefList; - OuterJoinMode: TffSqlOuterJoinMode; -begin - - {build a normal answer table} - - {build field definition for answer table} - FieldDefList := TffSqlFieldDefList.Create; - try - Assert(Assigned(Columns)); - for i := 0 to pred(Columns.Count) do begin - if Columns.Objects[i] is TffSqlFieldProxy then begin - F := TffSqlFieldProxy(Columns.Objects[i]); - FieldDefList.AddField(Columns[i], F.GetType, F.GetSize, F.GetDecimals); - end else begin - N := TffSqlNode(Columns.Objects[i]); - FieldDefList.AddField(Columns[i], N.GetType, N.GetSize, N.GetDecimals); - end; - end; - - Result := Owner.FDatabase.CreateTemporaryTableWithoutIndex(Self, FieldDefList); - finally - FieldDefList.Free; - end; - - try - - if Joiner = nil then begin - - if UsingCondExp <> nil then - Joiner := TffSqlJoiner.Create(Owner, UsingCondExp) - else - Joiner := TffSqlJoiner.Create(Owner, CondExp); - - Joiner.Sources.Add( - TFFSqlTableProxySubset.Create(TL)); - Joiner.Sources.Add( - TFFSqlTableProxySubset.Create(TR)); - - end; - - Joiner.ClearColumnList; - - Assert(Assigned(Columns)); - for i := 0 to pred(Columns.Count) do - if Columns.Objects[i] is TffSqlFieldProxy then - Joiner.AddColumn( - nil, - TffSqlFieldProxy(Columns.Objects[i]), - Result.Field(i)) - else - Joiner.AddColumn( - TffSqlSimpleExpression(Columns.Objects[i]), - nil, - Result.Field(i)); - - if NeedData then begin - Joiner.Target := Result; - Owner.FDatabase.StartTransaction([nil]); - try - case JoinType of - jtLeftOuter : - OuterJoinMode := jmLeft; - jtRightOuter : - OuterJoinMode := jmRight; - jtFullOuter : - OuterJoinMode := jmFull; - else - OuterJoinMode := jmNone; - end; - - Joiner.Execute(Owner.UseIndex, nil, OuterJoinMode); - except - Owner.FDatabase.AbortTransaction; - raise; - end; - Owner.FDatabase.Commit; - end; - - for i := 0 to Result.FieldCount - 1 do - Result.Field(i).IsTarget := False; - - if (Parent is TffSqlInClause) or (Parent is TffSqlMatchClause) then begin - {need an index to allow the IN and MATCH clauses to be evaluated} - - T2 := Result.CopySortedOnAllFields(Self); - - Result.Owner := nil; - Result.Free; - Result := T2; - end; - except - Result.Owner := nil; - Result.Free; - raise; - end; -end; - -procedure TffSqlJoinTableExp.EnsureResultTable(NeedData: Boolean); -begin - if (NeedData and not HaveData) then begin - FResultTable.Free; - FResultTable := nil; - end; - if FResultTable = nil then begin - FResultTable := Execute2(NeedData); - HaveData := NeedData; - end; -end; - -function TffSqlJoinTableExp.Execute2(NeedData: Boolean): TffSqlTableProxy; -begin - {check that all referenced tables and fields exist} - if not Bound then - Bind; - - {create the result} - Result := DoJoin(NeedData); -end; - -function TffSqlJoinTableExp.GetResultTable: TffSqlTableProxy; -begin - EnsureResultTable(True); - Result := FResultTable; -end; - -procedure TffSqlJoinTableExp.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlJoinTableExp then begin - Clear; - JoinType := TffSqlJoinTableExp(Source).JoinType; - Natural := TffSqlJoinTableExp(Source).Natural; - if TffSqlJoinTableExp(Source).TableRef1 <> nil then begin - TableRef1 := TffSqlTableRef.Create(Self); - TableRef1.Assign(TffSqlJoinTableExp(Source).TableRef1); - end; - if TffSqlJoinTableExp(Source).TableRef2 <> nil then begin - TableRef2 := TffSqlTableRef.Create(Self); - TableRef2.Assign(TffSqlJoinTableExp(Source).TableRef2); - end; - if TffSqlJoinTableExp(Source).CondExp <> nil then begin - CondExp := TFFSqlCondExp.Create(Self); - CondExp.Assign(TffSqlJoinTableExp(Source).CondExp); - end; - if TffSqlJoinTableExp(Source).UsingList <> nil then begin - UsingList := TFFSqlUsingList.Create(Self); - UsingList.Assign(TffSqlJoinTableExp(Source).UsingList); - end; - end else - AssignError(Source); -end; - -procedure TffSqlJoinTableExp.Clear; -begin - ClearColumns; - UsingCondExp.Free; - UsingCondExp := nil; - TableRef1.Free; - TableRef1 := nil; - TableRef2.Free; - TableRef2 := nil; - CondExp.Free; - CondExp := nil; - UsingList.Free; - UsingList := nil; -end; - -destructor TffSqlJoinTableExp.Destroy; -begin - ClearColumns; - Columns.Free; - Columns := nil; - {only free the tables if they belongs to us} - {if they are sub-expressions they will be - destroyed by the owning expression object} - if (TL <> nil) and (TL.Owner = Self) then begin - TL.Owner := nil; - TL.Free; - end; - if (TR <> nil) and (TR.Owner = Self) then begin - TR.Owner := nil; - TR.Free; - end; - Clear; - Joiner.Free; - if FResultTable <> nil then - if FResultTable.Owner = Self then begin - FResultTable.Owner := nil; - FResultTable.Free; - FResultTable := nil; - end; - UsingCondExp.Free; - inherited; -end; - -procedure TffSqlJoinTableExp.EmitSQL(Stream: TStream); -begin - WriteStr(Stream,' '); - TableRef1.EmitSQL(Stream); - if JoinType = jtCross then - WriteStr(Stream,' CROSS JOIN ') - else begin - if Natural then - WriteStr(Stream,' NATURAL'); - case JoinType of - jtInner : - WriteStr(Stream,' INNER'); - jtLeftOuter : - WriteStr(Stream,' LEFT OUTER'); - jtRightOuter : - WriteStr(Stream,' RIGHT OUTER'); - jtFullOuter : - WriteStr(Stream,' FULL OUTER'); - jtUnion : - WriteStr(Stream,' UNION'); - end; - WriteStr(Stream,' JOIN'); - end; - TableRef2.EmitSQL(Stream); - if CondExp <> nil then begin - WriteStr(Stream,' ON'); - CondExp.EmitSQL(Stream); - end; - if UsingList <> nil then begin - WriteStr(Stream,' USING ('); - UsingList.EmitSQL(Stream); - WriteStr(Stream,')'); - end; -end; - -procedure TffSqlJoinTableExp.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); - if assigned(TableRef1) then - TableRef1.EnumNodes(EnumMethod, Deep); - if assigned(TableRef2) then - TableRef2.EnumNodes(EnumMethod, Deep); - if assigned(CondExp) then - CondExp.EnumNodes(EnumMethod, Deep); - if assigned(UsingList) then - UsingList.EnumNodes(EnumMethod, Deep); -end; - -function TffSqlJoinTableExp.Equals(Other: TffSqlNode): Boolean; -begin - Result := - Other is TffSqlJoinTableExp - and (JoinType = TffSqlJoinTableExp(Other).JoinType) - and (Natural = TffSqlJoinTableExp(Other).Natural) - and ((BothNil(TableRef1, TffSqlJoinTableExp(Other).TableRef1) - or (BothNonNil(TableRef1, TffSqlJoinTableExp(Other).TableRef1) - and TableRef1.Equals(TffSqlJoinTableExp(Other).TableRef1)))) - and ((BothNil(TableRef2, TffSqlJoinTableExp(Other).TableRef2) - or (BothNonNil(TableRef2, TffSqlJoinTableExp(Other).TableRef2) - and TableRef2.Equals(TffSqlJoinTableExp(Other).TableRef2)))) - and ((BothNil(CondExp, TffSqlJoinTableExp(Other).CondExp) - or (BothNonNil(CondExp, TffSqlJoinTableExp(Other).CondExp) - and CondExp.Equals(TffSqlJoinTableExp(Other).CondExp)))) - and ((BothNil(UsingList, TffSqlJoinTableExp(Other).UsingList) - or (BothNonNil(UsingList, TffSqlJoinTableExp(Other).UsingList) - and UsingList.Equals(TffSqlJoinTableExp(Other).UsingList)))); -end; - -procedure TffSqlJoinTableExp.Execute( - var aLiveResult: Boolean; var aCursorID: TffCursorID; - var RecordsRead: Integer); -var - T : TffSqlTableProxy; -begin - Assert(Owner <> nil); - aLiveResult := False; - T := Execute2(True); - aCursorID := T.CursorID; - T.LeaveCursorOpen := True; - if T.Owner = self then begin - T.Owner := nil; - T.Free; - end; -end; - -function TffSqlJoinTableExp.GetFieldsFromTable(const TableName: string; List: TList): TffSqlTableProxy; -var - i: Integer; -begin - Result := nil; - if SameText(TableRef1.Alias, TableName) - or SameText(TableRef1.TableName, TableName) then begin - Result := ResultTable; - for i := 0 to pred(Columns.Count) do - if Columns.Objects[i] is TffSqlFieldProxy then - if TffSqlFieldProxy(Columns.Objects[i]).OwnerTable = TableRef1.FTable then - List.Add(Columns.Objects[i]); - exit; - end; - if SameText(TableRef2.Alias, TableName) - or SameText(TableRef2.TableName, TableName) then begin - Result := ResultTable; - for i := 0 to pred(Columns.Count) do - if Columns.Objects[i] is TffSqlFieldProxy then - if TffSqlFieldProxy(Columns.Objects[i]).OwnerTable = TableRef2.FTable then - List.Add(Columns.Objects[i]); - exit; - end; -end; - -function TffSqlJoinTableExp.Reduce: Boolean; -begin - if assigned(CondExp) then - Result := CondExp.Reduce - else - Result := False; - {!!.11 begin} - if not Result then - if TableRef1.Reduce then - Result := True - else - if TableRef2.Reduce then - Result := True; - {!!.11 end} -end; - -function TffSqlJoinTableExp.TargetFieldFromSourceField( - const F: TffSqlFieldProxy): TffSqlFieldProxy; -var - i: Integer; -begin - for i := 0 to pred(Columns.Count) do - if Columns.Objects[i] = F then begin - Result := ResultTable.Field(i); - exit; - end; - {!!.11 begin} - {We don't have the sought after source field represented in - our answer table directly, but it might be represented - indirectly as a field in a nested table expression} - Result := TableRef1.TargetFieldFromSourceField(F); - if Result <> nil then begin - for i := 0 to pred(Columns.Count) do - if Columns.Objects[i] = Result then begin - Result := ResultTable.Field(i); - exit; - end; - end; - Result := TableRef2.TargetFieldFromSourceField(F); - if Result <> nil then begin - for i := 0 to pred(Columns.Count) do - if Columns.Objects[i] = Result then begin - Result := ResultTable.Field(i); - exit; - end; - end; - {!!.11 end} - Result := nil; -end; - -{ TffSqlNonJoinTableTerm } - -procedure TffSqlNonJoinTableTerm.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlNonJoinTableTerm then begin - Clear; - if TffSqlNonJoinTableTerm(Source).NonJoinTablePrimary <> nil then begin - NonJoinTablePrimary := TffSqlNonJoinTablePrimary.Create(Self); - NonJoinTablePrimary.Assign(TffSqlNonJoinTableTerm(Source).NonJoinTablePrimary); - end; - end else - AssignError(Source); -end; - -function TffSqlNonJoinTableTerm.BindFieldDown(const TableName, - FieldName: string): TFFSqlFieldProxy; -begin - Result := NonJoinTablePrimary.BindFieldDown(TableName, FieldName); -end; - -function TffSqlNonJoinTableTerm.BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; -begin - Result := NonJoinTablePrimary.BindTable(AOwner, TableName); -end; - -procedure TffSqlNonJoinTableTerm.Clear; -begin - NonJoinTablePrimary.Free; - NonJoinTablePrimary := nil; -end; - -function TffSqlNonJoinTableTerm.DependsOn( - Table: TFFSqlTableProxy): Boolean; -begin - Assert(NonJoinTablePrimary <> nil); - Result := NonJoinTablePrimary.DependsOn(Table); -end; - -destructor TffSqlNonJoinTableTerm.Destroy; -begin - Clear; - inherited; -end; - -procedure TffSqlNonJoinTableTerm.EmitSQL(Stream: TStream); -begin - if assigned(NonJoinTablePrimary) then - NonJoinTablePrimary.EmitSQL(Stream); -end; - -procedure TffSqlNonJoinTableTerm.EnsureResultTable(NeedData: Boolean); -begin - assert(assigned(NonJoinTablePrimary)); - NonJoinTablePrimary.EnsureResultTable(NeedData); -end; - -procedure TffSqlNonJoinTableTerm.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); - if assigned(NonJoinTablePrimary) then - NonJoinTablePrimary.EnumNodes(EnumMethod, Deep); -end; - -function TffSqlNonJoinTableTerm.Equals(Other: TffSqlNode): Boolean; -begin - Result := - Other is TffSqlNonJoinTableTerm - and ((BothNil(NonJoinTablePrimary, TffSqlNonJoinTableTerm(Other).NonJoinTablePrimary) - or (BothNonNil(NonJoinTablePrimary, TffSqlNonJoinTableTerm(Other).NonJoinTablePrimary) - and NonJoinTablePrimary.Equals(TffSqlNonJoinTableTerm(Other).NonJoinTablePrimary)))) -end; - -procedure TffSqlNonJoinTableTerm.Execute( - var aLiveResult: Boolean; var aCursorID: TffCursorID; - var RecordsRead: Integer); -begin - Assert(NonJoinTablePrimary <> nil); - NonJoinTablePrimary.Execute(aLiveResult, aCursorID, RecordsRead); -end; - -function TffSqlNonJoinTableTerm.GetResultTable: TffSqlTableProxy; -begin - Assert(NonJoinTablePrimary <> nil); - Result := NonJoinTablePrimary.ResultTable; -end; - -function TffSqlNonJoinTableTerm.Reduce: Boolean; -begin - Assert(NonJoinTablePrimary <> nil); - Result := NonJoinTablePrimary.Reduce; -end; - -function TffSqlNonJoinTableTerm.TargetFieldFromSourceField( - const F: TffSqlFieldProxy): TffSqlFieldProxy; -begin - Result := NonJoinTablePrimary.TargetFieldFromSourceField(F); -end; - -{ TffSqlNonJoinTableExp } - -procedure TffSqlNonJoinTableExp.Assign(const Source: TffSqlNode); -begin - if Source is TffSqlNonJoinTableExp then begin - Clear; - if TffSqlNonJoinTableExp(Source).NonJoinTableTerm <> nil then begin - NonJoinTableTerm := TffSqlNonJoinTableTerm.Create(Self); - NonJoinTableTerm.Assign(TffSqlNonJoinTableExp(Source).NonJoinTableTerm); - end; - end else - AssignError(Source); -end; - -function TffSqlNonJoinTableExp.BindFieldDown(const TableName, - FieldName: string): TFFSqlFieldProxy; -begin - Result := NonJoinTableTerm.BindFieldDown(TableName, FieldName); -end; - -function TffSqlNonJoinTableExp.BindTable(AOwner: TObject; - const TableName: string): TFFSqlTableProxy; -begin - Result := NonJoinTableTerm.BindTable(AOwner, TableName); -end; - -procedure TffSqlNonJoinTableExp.Clear; -begin - NonJoinTableTerm.Free; - NonJoinTableTerm := nil; -end; - -function TffSqlNonJoinTableExp.DependsOn(Table: TFFSqlTableProxy): Boolean; -begin - Assert(NonJoinTableTerm <> nil); - Result := NonJoinTableTerm.DependsOn(Table); -end; - -destructor TffSqlNonJoinTableExp.Destroy; -begin - Clear; - inherited; -end; - -procedure TffSqlNonJoinTableExp.EmitSQL(Stream: TStream); -begin - if assigned(NonJoinTableTerm) then - NonJoinTableTerm.EmitSQL(Stream); -end; - -procedure TffSqlNonJoinTableExp.EnsureResultTable(NeedData: Boolean); -begin - Assert(Assigned(NonJoinTableTerm)); - NonJoinTableTerm.EnsureResultTable(NeedData); -end; - -procedure TffSqlNonJoinTableExp.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); - if assigned(NonJoinTableTerm) then - NonJoinTableTerm.EnumNodes(EnumMethod, Deep); -end; - -function TffSqlNonJoinTableExp.Equals(Other: TffSqlNode): Boolean; -begin - Result := - Other is TffSqlNonJoinTableExp - and ((BothNil(NonJoinTableTerm, TffSqlNonJoinTableExp(Other).NonJoinTableTerm) - or (BothNonNil(NonJoinTableTerm, TffSqlNonJoinTableExp(Other).NonJoinTableTerm) - and NonJoinTableTerm.Equals(TffSqlNonJoinTableExp(Other).NonJoinTableTerm)))) -end; - -procedure TffSqlNonJoinTableExp.Execute( - var aLiveResult: Boolean; var aCursorID: TffCursorID; - var RecordsRead: Integer); -begin - Assert(NonJoinTableTerm <> nil); - NonJoinTableTerm.Execute(aLiveResult, aCursorID, RecordsRead); -end; - -{!!.11 new} -function TffSqlNonJoinTableExp.GetFieldsFromTable(const TableName: string; List: TList): TffSqlTableProxy; {!!.11} -begin - Result := nil; -end; - -function TffSqlNonJoinTableExp.GetResultTable: TffSqlTableProxy; -begin - Assert(NonJoinTableTerm <> nil); - Result := NonJoinTableTerm.ResultTable; -end; - -function TffSqlNonJoinTableExp.Reduce: Boolean; -begin - Assert(NonJoinTableTerm <> nil); - Result := NonJoinTableTerm.Reduce; -end; - -constructor TffSqlJoinTableExp.Create; -begin - inherited; - Columns := TStringList.Create; -end; - -function TffSqlNonJoinTableExp.TargetFieldFromSourceField( - const F: TffSqlFieldProxy): TffSqlFieldProxy; -begin - Result := NonJoinTableTerm.TargetFieldFromSourceField(F); -end; - -{ TFFSqlUsingItem } - -procedure TFFSqlUsingItem.Assign(const Source: TffSqlNode); -begin - if Source is TFFSqlUsingItem then begin - ColumnName := TFFSqlUsingItem(Source).ColumnName; - end else - AssignError(Source); -end; - -procedure TFFSqlUsingItem.EmitSQL(Stream: TStream); -begin - WriteStr(Stream, ' '); - WriteStr(Stream, ColumnName); -end; - -procedure TFFSqlUsingItem.EnumNodes(EnumMethod: TffSqlEnumMethod; - const Deep: Boolean); -begin - EnumMethod(Self); -end; - -function TFFSqlUsingItem.Equals(Other: TffSqlNode): Boolean; -begin - if Other is TFFSqlUsingItem then - Result := ColumnName = TFFSqlUsingItem(Other).ColumnName - else - Result := False; -end; - -{===TffSqlUsingList==================================================} -function TffSqlUsingList.AddItem(NewUsing: TffSqlUsingItem): TffSqlUsingItem; -begin - FUsingItemList.Add(NewUsing); - Result := NewUsing; -end; -{--------} -procedure TffSqlUsingList.Assign(const Source: TffSqlNode); -var - i: Integer; -begin - if Source is TffSqlUsingList then begin - Clear; - for i := 0 to pred(TffSqlUsingList(Source).UsingCount) do - AddItem(TffSqlUsingItem.Create(Self)).Assign( - TffSqlUsingList(Source).UsingItem[i]); - end else - AssignError(Source); -end; - -constructor TffSqlUsingList.Create(AParent: TffSqlNode); -begin - inherited Create(AParent); - FUsingItemList := TList.Create; -end; -{--------} -procedure TffSqlUsingList.Clear; -var - i : Integer; -begin - for i := 0 to pred(FUsingItemList.Count) do - UsingItem[i].Free; - FUsingItemList.Clear; -end; -{--------} -destructor TffSqlUsingList.Destroy; -begin - Clear; - FUsingItemList.Free; - inherited; -end; -{--------} -procedure TffSqlUsingList.EmitSQL(Stream: TStream); -var - i : Integer; -begin - UsingItem[0].EmitSQL(Stream); - for i := 1 to pred(UsingCount) do begin - WriteStr(Stream,', '); - UsingItem[i].EmitSQL(Stream); - end; -end; -{--------} -procedure TffSqlUsingList.EnumNodes(EnumMethod: TffSqlEnumMethod; const Deep: Boolean); -var - i : Integer; -begin - EnumMethod(Self); - for i := 0 to pred(UsingCount) do - UsingItem[i].EnumNodes(EnumMethod, Deep); -end; -{--------} -function TffSqlUsingList.Equals(Other: TffSqlNode): Boolean; -var - i : Integer; -begin - Result := False; - if Other is TffSqlUsingList then begin - if UsingCount <> TffSqlUsingList(Other).UsingCount then - exit; - for i := 0 to pred(UsingCount) do - if not UsingItem[i].Equals(TffSqlUsingList(Other).UsingItem[i]) then - exit; - Result := True; - end; -end; -{--------} -function TffSqlUsingList.GetUsingCount: Integer; -begin - Result := FUsingItemList.Count; -end; -{--------} -function TffSqlUsingList.GetUsingItem( - Index: Integer): TffSqlUsingItem; -begin - Result := TffSqlUsingItem(FUsingItemList[Index]); -end; -{--------} -procedure TffSqlUsingList.SetUsingItem(Index: Integer; - const Value: TffSqlUsingItem); -begin - FUsingItemList[Index] := Value; -end; -{====================================================================} - -initialization - {calculate TimeDelta as one second} {!!.01} - TimeDelta := EncodeTime(0, 0, 2, 0) - EncodeTime(0, 0, 1, 0); {!!.01} -end. - - diff --git a/components/flashfiler/sourcelaz/ffsqleng.pas b/components/flashfiler/sourcelaz/ffsqleng.pas deleted file mode 100644 index 6c57cebe6..000000000 --- a/components/flashfiler/sourcelaz/ffsqleng.pas +++ /dev/null @@ -1,663 +0,0 @@ -{*********************************************************} -{* FlashFiler: SQL Engine 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} - -{$DEFINE SQLSupported} - -unit ffsqleng; - -interface - -uses - classes, - windows, - sysutils, - ffconst, - ffllbase, - fflleng, - ffllexcp, - fflldict, - ffsql, - ffsqlbas, - ffsrbase, - ffsrbde, - ffsrcvex, - ffsqldb, {!!.11} - fftbdict, - ffsreng; - - -type - { A prepared statement is an SQL query in tokenized, parsed, executable form. - All SQL statements must become prepared statements before they can be - executed (whether the client specifically "prepares" them or not). Trigger - and stored procedure code is loaded from the relevant system tables into - a persistent prepared statement so that it can be executed on demand. } - TffSqlPreparedStatement = class(TffBasePreparedStmt) {!!.01}{!!.10} - protected {private} - spsParser : TffSQL; -// FTimeout : Longint; {Deleted !!.01} - spsDatabaseProxy : TFFSqlDatabaseProxy; {!!.11} - public - constructor Create2(anEngine : TffServerEngine; {!!.01} - aClientID : TffClientID; - aDatabaseID: TffDatabaseID; - aTimeout : Longint); - destructor Destroy; override; - procedure Bind; override; {!!.11} - function Execute(var aLiveResult: Boolean; {!!.10} - var aCursorID: TffCursorID; - var aRowsAffected: Integer; - var aRecordsRead: Integer): TffResult; override;{!!.10} - function Parse(aQuery: PChar): Boolean; override; {!!.10} - function SetParams(aNumParams: Word; aParamInfo: PffSqlParamInfoList; aDataBuffer: PffByteArray): TffResult; - end; - - { The SQL engine orchestrates all the activity in the server relevant to - SQL processing. The TffServerEngine class hands off SQL requests to the - SQL engine for processing, which in turn hands off results back to the - TffServerEngine for return to the client. - - There is only one instance of TffSqlEngine and that is SQLEngine declared - within this unit. All communication with the SQL Engine can take place - through this global variable. } - TffSqlEngine = class(TffBaseSQLEngine) - protected { private} - protected - sqlPreparedStatementsList: TffSrStmtList; - public - constructor Create(aOwner : TComponent); override; - - destructor Destroy; override; - - function Alloc(anEngine : TffBaseServerEngine; - aClientID: TffClientID; - aDatabaseID: TffDatabaseID; - aTimeout : Longint; - var aStmtID: TffSqlStmtID): TffResult; override; - {- Implementation of DbiQAlloc } - -{Begin !!.01} - procedure CollectGarbage; override; - { Clears out SQL prepared statements that were still active when - the client sent a free statement request. } -{End !!.01} - - function Exec(aStmtID: TffSqlStmtID; - aOpenMode: TffOpenMode; - var aCursorID: TffCursorID; - aStream: TStream): TffResult; override; - {- Implementation of DbiQExec. aCursorID is 0 if no result set - returned. aStream is used to pass back dictionary for the - result set (only if aCursorID <> 0). } - - function ExecDirect(anEngine : TffBaseServerEngine; - aClientID : TffClientID; - aDatabaseID : TffDatabaseID; - aQueryText : PChar; - aOpenMode : TffOpenMode; - aTimeout : Longint; - var aCursorID : TffCursorID; - aStream : TStream): TffResult; override; - {- Implementation of DbiQExecDirect. aCursorID is 0 if no result set - is returned. aStream is used to pass back dictionary for the - result set. } - - function FreeStmt(aStmtID: TffSqlStmtID): TffResult; override; - {- Implementation of DbiQFree } - - function Prepare(aStmtID: TffSqlStmtID; - aQueryText: PChar; - aStream : TStream): TffResult; override; - {- Implementation of DbiQPrepare } - -{Begin !!.03} - procedure RemoveForClient(const aClientID : TffClientID); override; - {- Remove the prepared statements associated with a particular client. } - - procedure RequestClose; override; - {- Ask the remaining SQL prepared statements to close. This occurs - when preparing for shutdown with the goal of preventing a cursor - being freed before its SQL table proxy is freed. } -{End !!.03} - - function SetParams(aStmtID: TffSqlStmtID; - aNumParams: Word; - aParamDescs: PffSqlParamInfoList; - aDataBuffer: PffByteArray; - aStream : TStream): TffResult; override; - {- Implementation of DbiQSetParams } - - end; - -implementation - -uses -{$IFDEF DCC6OrLater} - Variants, -{$ENDIF} - ffstdate; - -type - PComp = ^Comp; - -{===TffSqlPreparedStatement==========================================} -constructor TffSqlPreparedStatement.Create2(anEngine : TffServerEngine; {!!.01} - aClientID : TffClientID; - aDatabaseID: TffDatabaseID; - aTimeout : Longint); -var {!!.10} - parentDB : TffSrDatabase; {!!.10} -begin - inherited Create(aTimeout); {!!.01} - bpsEngine := anEngine; - bpsDatabaseID := aDatabaseID; - spsParser := TffSql.Create(nil); - bpsClientID := aClientID; - soClient := TffSrClient(aClientID); {!!.01}{!!.10} -// FTimeout := aTimeout; {Deleted !!.01} -{Begin !!.10} - parentDB := TffSrDatabase(bpsDatabaseID); - parentDB.StmtList.BeginWrite; - try - parentDB.StmtList.AddStmt(Self); - finally - parentDB.StmtList.EndWrite; - end; -{End !!.10} -end; -{--------} -destructor TffSqlPreparedStatement.Destroy; -begin - spsDatabaseProxy.Free; {!!.12} - if assigned(spsParser) then begin - if spsParser.RootNode <> nil then begin - spsParser.RootNode.Free; - spsParser.RootNode := nil; - end; - spsParser.Free; - end; -{Begin !!.10} - { Assumption: By this point, the SQL prepared statement has been removed - or is in the processor of being removed from the client's statement list. } -{End !!.10} - inherited Destroy; -end; -{Begin !!.11} -{--------} -procedure TffSqlPreparedStatement.Bind; -begin - if (spsParser <> nil) and - (spsParser.RootNode <> nil) then begin - spsDatabaseProxy := TFFSqlDatabaseProxy.Create(bpsEngine, bpsDatabaseID); - spsParser.RootNode.Bind(bpsClientID, 0, spsDatabaseProxy); - end; -end; -{--------} -function TffSqlPreparedStatement.Execute(var aLiveResult: Boolean; - var aCursorID: TffCursorID; - var aRowsAffected: Integer; - var aRecordsRead: Integer): TffResult; -begin - {try} {!!.12} - Result := - spsParser.RootNode.Execute(aLiveResult, aCursorID, - aRowsAffected, aRecordsRead); - { !!.12 - finally - spsDatabaseProxy.Free; - end; - } -end; -{End !!.11} -{--------} -function TffSqlPreparedStatement.Parse(aQuery: PChar): Boolean; -begin - if spsParser.RootNode <> nil then begin - spsParser.RootNode.Free; - spsParser.RootNode := nil; - end; - spsParser.SourceStream.SetSize(StrLen(aQuery) + 1); - move(aQuery^, spsParser.SourceStream.Memory^, StrLen(aQuery) + 1); - spsParser.Execute; - Result := spsParser.Successful; -end; -{--------} -function TffSqlPreparedStatement.SetParams(aNumParams: Word; - aParamInfo: PffSqlParamInfoList; - aDataBuffer: PffByteArray): TffResult; -var - I: Integer; - Value : Variant; - FieldBuffer : PffByteArray; - D : double; - W : WideString; - WC : WideChar; - DT : TDateTime; - VPtr : PByte; {!!.13} -begin - Result := DBIERR_NONE; - for I := 0 to aNumParams - 1 do begin - with aParamInfo^[I] do begin - if piName = '' then { named parameter } - piName := ':' + IntToStr(piNum); { unnamed parameter } - FieldBuffer := PffByteArray(DWord(aDataBuffer) + piOffset); - case piType of - fftBoolean : - Value := Boolean(FieldBuffer^[0]); - fftChar : - Value := Char(FieldBuffer^[0]); - fftWideChar : - begin - WC := PWideChar(FieldBuffer)^; - W := WC; - Value := W; - end; - fftByte : - Value := PByte(FieldBuffer)^; - fftWord16 : - Value := PWord(FieldBuffer)^; - fftWord32 : - begin - D := PDWord(FieldBuffer)^; - Value := D; - end; - fftInt8 : - Value := PShortInt(FieldBuffer)^; - fftInt16 : - Value := PSmallInt(FieldBuffer)^; - fftInt32 : - Value := PInteger(FieldBuffer)^; - fftAutoInc : - Value := PInteger(FieldBuffer)^; - fftSingle : - Value := PSingle(FieldBuffer)^; - fftDouble : - Value := PDouble(FieldBuffer)^; - fftExtended : - Value := PExtended(FieldBuffer)^; - fftComp : - Value := PComp(FieldBuffer)^; - fftCurrency : - Value := PCurrency(FieldBuffer)^; - fftStDate : - Value := StDateToDateTime(PStDate(FieldBuffer)^); - fftStTime : - Value := StTimeToDateTime(PStTime(FieldBuffer)^); - fftDateTime : - begin - DT := PffDateTime(FieldBuffer)^; - VarCast(Value, DT - 693594, varDate); {!!.11} - end; - fftShortString : - Value := PShortString(FieldBuffer)^; - fftShortAnsiStr : - Value := PShortString(FieldBuffer)^; - fftNullString : - Value := StrPas(PChar(FieldBuffer)); - fftNullAnsiStr : - Value := string(PChar(FieldBuffer)); - fftWideString : - Value := WideString(PWideChar(FieldBuffer)); -{Begin !!.13} - fftBLOB..fftBLOBTypedBin : - if piLength = 0 then - Value := '' - else begin - Value := VarArrayCreate([1, piLength], varByte); - VPtr := VarArrayLock(Value); - try - Move(FieldBuffer^, VPtr^, piLength); - finally - VarArrayUnlock(Value); - end; - end; -{End !!.13} - else - raise Exception.Create('Unsupported field type'); - end; - spsParser.RootNode.SetParameter(I, Value); - end; - end; -end; -{====================================================================} - -{===TffSqlEngine=====================================================} -constructor TffSqlEngine.Create(aOwner : TComponent); -begin - inherited Create(aOwner); - - {create list for prepared statements} - sqlPreparedStatementsList := TffSrStmtList.Create; -end; -{--------} -destructor TffSqlEngine.Destroy; -begin - sqlPreparedStatementsList.Free; - inherited Destroy; -end; -{--------} -function TffSqlEngine.Exec(aStmtID: TffSqlStmtID; - aOpenMode: TffOpenMode; - var aCursorID: TffCursorID; - aStream: TStream) : TffResult; -var - L : Integer; - RowsAffected: Integer; {!!.10} - RecordsRead: Integer; {!!.10} - LiveResult: Boolean; {!!.10} - IndexID : Longint; {!!.11} -begin - {$IFNDEF SQLSupported} - Result := DBIERR_NOTSUPPORTED; - {$ELSE} - try - aCursorID := 0; -{Begin !!.01} - with sqlPreparedStatementsList.Stmt[ftFromID, aStmtID] do begin - Activate; - try - FFSetRetry(Timeout); - LiveResult := aOpenMode = omReadWrite; {!!.10} - Result := Execute(LiveResult, aCursorID, RowsAffected, {!!.10} - RecordsRead); {!!.10} - if Result <> 0 then Exit; - if Assigned(aStream) then begin - if (aCursorID <> 0) then begin - {query} - Assert(TObject(ACursorID) is TffSrBaseCursor); - aStream.Write(aCursorID, SizeOf(aCursorID)); - TffSrBaseCursor(ACursorID).Dictionary.WriteToStream(aStream); -{Begin !!.11} - { If this is a pre-2.11 client then write index ID 0 to the - stream. } - if TffSrClient(ClientID).ClientVersion < ffVersion2_10 then begin - IndexID := 0; - aStream.Write(IndexID, SizeOf(IndexID)); - end - else begin - aStream.Write(LiveResult, SizeOf(LiveResult)); - aStream.Write(RecordsRead, SizeOf(RecordsRead)); - end -{End !!.11} - end else begin - {data manipulation} - aStream.Write(aCursorID, SizeOf(aCursorID)); {zero} {!!.10} - aStream.Write(RowsAffected, SizeOf(RowsAffected)); {!!.10} - aStream.Write(RecordsRead, SizeOf(RecordsRead)); {!!.10} - end; - end; - finally - Deactivate; - end; - end; { while } -{End !!.01} - except - on E : Exception do begin - Result := ConvertServerException(E, FEventLog); - L := length(E.Message); - aStream.Write(L, sizeof(L)); - aStream.Write(E.Message[1], L); - end; - end; - {$ENDIF} -end; -{--------} -function TffSqlEngine.ExecDirect(anEngine : TffBaseServerEngine; - aClientID : TffClientID; - aDatabaseID : TffDatabaseID; - aQueryText : PChar; - aOpenMode : TffOpenMode; - aTimeout : Longint; - var aCursorID : TffCursorID; - aStream : TStream): TffResult; -var - Statement: TffSqlPreparedStatement; - L : Integer; - RowsAffected: Integer; {!!.10} - RecordsRead: Integer; {!!.10} - LiveResult: Boolean; {!!.10} -begin - {$IFNDEF SQLSupported} - Result := DBIERR_NOTSUPPORTED; - {$ELSE} - Result := DBIERR_NONE; - Assert(anEngine is TffServerEngine); {!!.01} - Statement := nil; - try - aCursorID := 0; - - Statement := TffSqlPreparedStatement.Create2(TffServerEngine(anEngine), {!!.01} - aClientID, {!!.01} - aDatabaseID, aTimeout); - try - if Statement.Parse(aQueryText) then begin - LiveResult := aOpenMode = omReadWrite; {!!.10} - Result := Statement.Execute(LiveResult, {!!.10} - aCursorID, RowsAffected, RecordsRead); {!!.10} - if Assigned(aStream) then begin - if (aCursorID <> 0) then begin - {query} - aStream.Write(aCursorID, SizeOf(aCursorID)); - TffSrBaseCursor(ACursorID).Dictionary.WriteToStream(aStream); - aStream.Write(LiveResult, SizeOf(LiveResult)); {!!.10} - aStream.Write(RecordsRead, SizeOf(RecordsRead)); {!!.10} - end else begin - {data manipulation} - aStream.Write(aCursorID, SizeOf(aCursorID)); {zero} {!!.10} - aStream.Write(RowsAffected, SizeOf(RowsAffected)); {!!.10} - aStream.Write(RecordsRead, SizeOf(RecordsRead)); {!!.10} - end; - end; - end else - raise Exception.Create('SQL Syntax error'); - finally - Statement.Free; - end; - - except - on E : Exception do begin - Result := ConvertServerException(E, FEventLog); - if Statement <> nil then begin - L := Statement.spsParser.ListStream.Size; - aStream.Write(L, sizeof(L)); - Statement.spsParser.ListStream.Seek(0, 0); - aStream.CopyFrom(Statement.spsParser.ListStream, L); - end else begin - L := 0; - aStream.Write(L, sizeof(L)); - end; - end; - end; - {$ENDIF} -end; -{--------} -function TffSqlEngine.FreeStmt(aStmtID: TffSqlStmtID) : TffResult; -var {!!.10} - parentDB : TffSrDatabase; {!!.10} - Stmt : TffBasePreparedStmt; {!!.13} -begin - {$IFNDEF SQLSupported} - Result := DBIERR_NOTSUPPORTED; - {$ELSE} - Result := DBIERR_NONE; - try -{Begin !!.01} - Stmt := sqlPreparedStatementsList.Stmt[ftFromID, aStmtID]; {!!.13} - if Stmt <> nil then {!!.13} - with Stmt do begin {!!.13} - if CanClose(True) then begin - sqlPreparedStatementsList.DeleteStmt(aStmtID); - parentDB := TffSrDatabase(DatabaseID); {!!.10} - parentDB.StmtList.BeginWrite; {!!.10} - try - parentDB.StmtList.DeleteStmt(aStmtID); {!!.10} - finally - parentDB.StmtList.EndWrite; {!!.10} - end; - end - else - RequestClose; - end; { with } -{End !!.01} - except - on E : Exception do begin - Result := ConvertServerException(E, FEventLog); - end; - end; - {$ENDIF} -end; -{--------} -function TffSqlEngine.Alloc(anEngine : TffBaseServerEngine; - aClientID : TffClientID; - aDatabaseID : TffDatabaseID; - aTimeout : Longint; - var aStmtID : TffSqlStmtID): TffResult; -var - Statement: TffSqlPreparedStatement; -begin - {$IFNDEF SQLSupported} - Result := DBIERR_NOTSUPPORTED; - {$ELSE} - aStmtID := 0; - Result := DBIERR_NONE; - Assert(anEngine is TffServerEngine); {!!.01} - - try - Statement := TffSqlPreparedStatement.Create2(TffServerEngine(anEngine), {!!.01} - aClientID, {!!.01} - aDatabaseID, aTimeout); - try - sqlPreparedStatementsList.AddStmt(Statement); {!!.10} - aStmtID := Statement.Handle; {!!.10} - except - Statement.Free; - raise; - end; - except - on E : Exception do begin - Result := ConvertServerException(E, FEventLog); - end; - end; - {$ENDIF} -end; -{Begin !!.01} -{--------} -procedure TffSqlEngine.CollectGarbage; -begin - sqlPreparedStatementsList.RemoveUnused; -end; -{End !!.01} -{--------} -function TffSqlEngine.Prepare(aStmtID: TffSqlStmtID; - aQueryText: PChar; - aStream : TStream) : TffResult; -var - L : Integer; - Stmt : TffSqlPreparedStatement; -begin - {$IFNDEF SQLSupported} - Result := DBIERR_NOTSUPPORTED; - {$ELSE} - try -{Begin !!.01} - Result := DBIERR_NONE; - with sqlPreparedStatementsList.Stmt[ftFromID, aStmtID] do begin - Activate; - try -{Begin !!.11} - if Parse(aQueryText) then - Bind - else - raise Exception.Create('SQL syntax error'); -{End !!.11} - finally - Deactivate; - end; - end; -{End !!.01} - except - on E : Exception do begin - Result := ConvertServerException(E, FEventLog); - Stmt := TffSqlPreparedStatement(sqlPreparedStatementsList.Stmt[ftFromID, aStmtID]); - L := Stmt.spsParser.ListStream.Size; - aStream.Write(L, sizeof(L)); - Stmt.spsParser.ListStream.Seek(0, 0); - aStream.CopyFrom(Stmt.spsParser.ListStream, L); - end; - end; - {$ENDIF} -end; -{Begin !!.03} -{--------} -procedure TffSqlEngine.RemoveForClient(const aClientID : TffClientID); -begin - sqlPreparedStatementsList.RemoveForClient(aClientID); -end; -{--------} -procedure TffSqlEngine.RequestClose; -begin - { Free up the remaining SQL prepared statements. } - sqlPreparedStatementsList.RequestClose; - sqlPreparedStatementsList.RemoveUnused; -end; -{End !!.03} -{--------} -function TffSqlEngine.SetParams(aStmtID: TffSqlStmtID; - aNumParams: Word; - aParamDescs: PffSqlParamInfoList; - aDataBuffer: PffByteArray; - aStream : TStream): TffResult; -var - Stmt : TffSQLPreparedStatement; -begin - {$IFNDEF SQLSupported} - Result := DBIERR_NOTSUPPORTED; - {$ELSE} - try -{Begin !!.01} - Stmt := TffSqlPreparedStatement(sqlPreparedStatementsList.Stmt[ftFromID, aStmtID]); - Stmt.Activate; - try - Result := Stmt.SetParams(aNumParams, aParamDescs, aDataBuffer); - finally - Stmt.Deactivate; - end; -{End !!.01} - except - on E : Exception do begin - Result := ConvertServerException(E, FEventLog); - end; - end; - {$ENDIF} -end; -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/ffsrIntm.pas b/components/flashfiler/sourcelaz/ffsrIntm.pas deleted file mode 100644 index 7066e5720..000000000 --- a/components/flashfiler/sourcelaz/ffsrIntm.pas +++ /dev/null @@ -1,282 +0,0 @@ -{ Notes: - The purpose of this unit is to allow a server command - handler to register itself with a server engine. - We couldn't embed this functionality into TfFServerEngine - and TffServerCommandHandler because they are declared in separate - units. } - -{*********************************************************} -{* FlashFiler: Server intermediate 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 ffsrintm; - -interface - -uses - Classes, - ffllbase, - ffllcomm, - ffllcomp, - fflleng, - fflllgcy; - -type - - TffIntermediateCommandHandler = class; { forward declaration } - - TffIntermediateServerEngine = class(TffBaseServerEngine) - protected - FCmdHandlers : TffThreadList; - - function iseGetCmdHandler(aInx : Longint) : TffIntermediateCommandHandler; - - function iseGetCmdHandlerCount : Longint; - - procedure scSetState(const aState : TffState); override; - - public - - constructor Create(aOwner : TComponent); override; - - destructor Destroy; override; - - procedure FFAddDependent(ADependent : TffComponent); override; {!!.11} - procedure FFRemoveDependent(ADependent : TffComponent); override; {!!.11} - - property CmdHandler[aInx : Longint] : TffIntermediateCommandHandler - read iseGetCmdHandler; - - property CmdHandlerCount : Longint read iseGetCmdHandlerCount; - - end; - - - TffIntermediateCommandHandler = class(TffBaseCommandHandler) - protected - - FServerEngine : TffIntermediateServerEngine; - - procedure ichLog(const aMsg : string); virtual; - {-Use this method to log a string to the event log. } - - procedure ichLogFmt(const aMsg : string; args : array of const); virtual; - {-Use this method to log a formatted string to the event log. } - - procedure ichLogAll(const Msgs : array of string); virtual; - {-Use this method to log multiple strings to the event log. } - - procedure ichLogBlock(const S : string; Buf : pointer; - BufLen : TffMemSize); virtual; - - procedure ichSetServerEngine(anEngine : TffIntermediateServerEngine); virtual; - {-Sets the server engine to be used by this command handler. } - - public - - constructor Create(aOwner : TComponent); override; - - destructor Destroy; override; - - procedure FFNotificationEx(const AOp : Byte; AFrom : TffComponent; {!!.11} - const AData : TffWord32); override; {!!.11} - - published - - property ServerEngine : TffIntermediateServerEngine read FServerEngine - write ichSetServerEngine; - { The server engine handling requests received by this command handler. } - - end; - -implementation - -uses - SysUtils; - -{===TffIntermediateServerEngine===========================================} -constructor TffIntermediateServerEngine.Create(aOwner : TComponent); -begin - inherited Create(aOwner); - FCmdHandlers := TffThreadList.Create; -end; -{--------} -destructor TffIntermediateServerEngine.Destroy; -{Rewritten !!.11} -begin - FFNotifyDependents(ffn_Destroy); - FCmdHandlers.Free; - inherited Destroy; -end; -{Begin !!.11} -{--------} -procedure TffIntermediateServerEngine.FFAddDependent(ADependent : TffComponent); -var - aListItem : TffIntListItem; -begin - inherited; - if ADependent is TffIntermediateCommandHandler then begin - aListItem := TffIntListItem.Create(LongInt(ADependent)); - with FCmdHandlers.BeginWrite do - try - Insert(aListItem); - finally - EndWrite; - end; - end; -end; -{--------} -procedure TffIntermediateServerEngine.FFRemoveDependent(ADependent : TffComponent); -begin - inherited; - if ADependent is TffIntermediateCommandHandler then - with FCmdHandlers.BeginWrite do - try - Delete(LongInt(ADependent)); - finally - EndWrite; - end; -end; -{End !!.11} -{--------} -function TffIntermediateServerEngine.iseGetCmdHandler(aInx: Integer) : TffIntermediateCommandHandler; -begin - Result := TffIntermediateCommandHandler(TffIntListItem(FCmdHandlers[aInx]).KeyAsInt); -end; -{--------} -function TffIntermediateServerEngine.iseGetCmdHandlerCount: Longint; -begin - Result := FCmdHandlers.Count; -end; -{--------} -procedure TffIntermediateServerEngine.scSetState(const aState : TffState); -var - Idx : longInt; - NextState : TffState; - Handler : TffBaseCommandHandler; -begin - if aState = State then exit; - - if Assigned(FCmdHandlers) then - with FCmdHandlers.BeginRead do - try - while State <> aState do begin - { Based upon our current state & the target state, get the next state. } - NextState := ffStateDiagram[State, aState]; - - { Move all command handlers to the specified state. } - for Idx := Pred(Count) downto 0 do begin - Handler := TffBaseCommandHandler(TffIntListItem(Items[Idx]).KeyAsInt); - Handler.State := NextState; - end; - - {For each step, call the inherited SetState method. The inherited - method is responsible for calling the state methods for the - engine} - inherited scSetState(NextState); - end; - finally - EndRead; - end; -end; - -{=========================================================================} - -{===TffIntermediateCommandHandler=========================================} -constructor TffIntermediateCommandHandler.Create(aOwner : TComponent); -begin - inherited Create(aOwner); - FServerEngine := nil; -end; -{--------} -destructor TffIntermediateCommandHandler.Destroy; -begin - if assigned(FServerEngine) then - FServerEngine.FFRemoveDependent(Self); - - inherited Destroy; -end; -{--------} -procedure TffIntermediateCommandHandler.ichLog(const aMsg : string); -begin - if FLogEnabled and assigned(FEventLog) then - FEventLog.WriteString(aMsg); -end; -{--------} -procedure TffIntermediateCommandHandler.ichLogAll(const Msgs : array of string); -begin - if FLogEnabled and assigned(FEventLog) then - FEventLog.WriteStrings(Msgs); -end; -{--------} -procedure TffIntermediateCommandHandler.ichLogBlock(const S : string; Buf : pointer; - BufLen : TffMemSize); -begin - if FLogEnabled and assigned(FEventLog) then - FEventLog.WriteBlock(S, Buf, BufLen); -end; -{--------} -procedure TffIntermediateCommandHandler.ichLogFmt(const aMsg : string; args : array of const); -begin - if FLogEnabled and assigned(FEventLog) then - FEventLog.WriteString(format(aMsg, args)); -end; -{--------} -procedure TffIntermediateCommandHandler.ichSetServerEngine(anEngine : TffIntermediateServerEngine); -begin - if FServerEngine = anEngine then Exit; - - scCheckInactive; - - if assigned(FServerEngine) then - FServerEngine.FFRemoveDependent(Self); {!!.11} - - if assigned(anEngine) then - anEngine.FFAddDependent(Self); {!!.11} - - FServerEngine := anEngine; - -end; -{--------} -{Rewritten !!.11} -procedure TffIntermediateCommandHandler.FFNotificationEx - (const AOp : Byte; AFrom : TffComponent; - const AData : TffWord32); -begin - inherited; - if (AFrom = FServerEngine) and - (AOp in [ffn_Destroy, ffn_Remove]) then begin - State := ffesStopped; - FServerEngine.FFRemoveDependent(Self); - FServerEngine := nil; - end; -end; -{=========================================================================} -end. diff --git a/components/flashfiler/sourcelaz/ffsrbase.inc b/components/flashfiler/sourcelaz/ffsrbase.inc deleted file mode 100644 index 9d4e1873b..000000000 --- a/components/flashfiler/sourcelaz/ffsrbase.inc +++ /dev/null @@ -1,75 +0,0 @@ -{*********************************************************} -{* FlashFiler: 32-bit file management routines inc 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 management routines=========================================} -procedure FFCopyFile(const FromFileName, ToFileName : TffFullFileName); - var - WinError : TffWord32; - FromZ : TffMaxPathZ; - ToZ : TffMaxPathZ; - begin - if not Windows.CopyFile(FFStrPCopy(FromZ, FromFileName), - FFStrPCopy(ToZ, ToFileName), True) then - begin - WinError := GetLastError; - FFRaiseException(EffServerException, ffStrResServer, fferrCopyFile, - [WinError, SysErrorMessage(WinError)]); - end; - end; -{--------} -procedure FFDeleteFile(const FileName : TffFullFileName); - var - WinError : TffWord32; - FZ : TffMaxPathZ; - begin - if not Windows.DeleteFile(FFStrPCopy(FZ, FileName)) then - begin - WinError := GetLastError; - FFRaiseException(EffServerException, ffStrResGeneral, fferrDeleteFile, {!!.10} - [WinError, SysErrorMessage(WinError)]); - end; - end; -{--------} -procedure FFRenameFile(const OldFileName, NewFileName : TffFullFileName); - var - WinError : TffWord32; - OldZ : TffMaxPathZ; - NewZ : TffMaxPathZ; - begin - if not Windows.MoveFile(FFStrPCopy(OldZ, OldFileName), FFStrPCopy(NewZ, NewFileName)) then - begin - WinError := GetLastError; - FFRaiseException(EffServerException, ffStrResServer, fferrRenameFile, - [WinError, SysErrorMessage(WinError)]); - end; - end; -{====================================================================} - - diff --git a/components/flashfiler/sourcelaz/ffsrbase.pas b/components/flashfiler/sourcelaz/ffsrbase.pas deleted file mode 100644 index 38b9af9a2..000000000 --- a/components/flashfiler/sourcelaz/ffsrbase.pas +++ /dev/null @@ -1,5880 +0,0 @@ -{*********************************************************} -{* FlashFiler: Base unit for FlashFiler 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} - -{ Uncomment the following to enable logging of RAM page actions. } -{.$DEFINE RAMPageCheck} - -{Note: to avoid later confusion, here are what various 'numbers' mean, - including their types: - "block number" - zero-based number of a block in the file, each block being - 4K, 8K, 16K, 32K, or 64k in size; 32-bit signed integer (with - the smallest block size it has a range of 0..1024*1024-1) - "record reference number" - an offset into file, 64-bit unsigned word (TffInt64) - "BLOB number" - an offset into file, 64-bit unsigned word (TffInt64) - "BLOB segment number" - an offset into file, 64-bit unsigned word (TffInt64) - "stream number" - a block number - - it is only the table files that are encrypted, journal files - are not. Hence journal files are always read and written with - the non-encrypt/decrypt versions of the file access routines. - In table files, the header record is never encrypted either: - this means that the buffer manager can work out if a table file - is encrypted or not. All files for a given table have the same - encryption level (ie, they all are, or they all are not). - } - - -unit ffsrbase; - -interface - -uses - Windows, - SysUtils, - Classes, - ffconst, - ffhash, - ffllbase, - {$IFDEF RAMPageCheck} - fflllog, - {$ENDIF} - fflltemp, - ffsrmgr, - ffllexcp, - {$IFDEF SecureServer} - fftbcryp, - {$ENDIF} - ffsrintf; - -{$R ffsrcnst.res} - -var - ffStrResServer : TffStringResource; - {$IFDEF RAMPageCheck} - aLog : TffEventLog; - {$ENDIF} - -{---Handy constants for readability---} -const - ffc_MarkDirty = true; - ffc_ReadOnly = false; - ffcl_PageLife = 5 * 60 * 1000; - { A RAM page whose FRefCount > 0 may not be re-used unless the last access - was 5 or more minutes ago. } - -{---Enumerated types---} -type - TffLockPresent = ( {Whether a lock is present...} - lpNotAtAll, {..no, not at all} - lpYesByUs, {..yes, and by current session} - lpYesByAnother); {..yes, and by another session} - - {:The types of BLOB segments. - @enum bstHeader Segment containing BLOB info and first set of lookup entries. - @enum bstLookup Segment containing additional BLOB lookup entries that - couldn't fit in the header segment. - @enum bstContent Segment containing BLOB content. } - TffBLOBSegment = (bstHeader, bstLookup, bstContent); - - TffTransactionMode = ( {Transaction modes for the buffer manager} - tmOff, {..no transaction active} - tmNormal, {..non-fail safe transaction in progress} - tmFailSafe); {..fail safe transaction in progress} - - TffFindKeyAction = ( {Find key actions if orig key not found} - fkaNone, {..do nothing, return error} - fkaNextKey, {..return next key in index, or error if none} - fkaPrevKey, {..return previous key in index, or error if none} - fkaPartialKey, {..key provided is partial, find full key that matches} - fkaNearestKey); {..return next key, or if none, previous key} - - TffAccessRight = ( {user access rights} - arAdmin, {..administration right} - arRead, {..read right} - arInsert, {..insert right} - arUpdate, {..update right} - arDelete); {..delete right} - TffUserRights = set of TffAccessRight; - - {---The FlashFiler primitive file type and buffer manager class---} - TffBaseBLOBResourceMgr = class; {..forward declaration} - TffBufferManager = class; - - TffbmRAMPage = class; - - PffPageArray = ^TffPageArray; - TffPageArray = array[Byte] of Pointer; - {-This type is used in the TffFileInfo.fiPages structure. - An element of a leaf array will point to a TffbmRAMpage. - An element of a node array will point to a TffPageContainer. } - - PffPageContainer = ^TffPageContainer; - TffPageContainer = record - pcNext: PffPageContainer; - pcPrev: PffPageContainer; - pcPages: TffPageArray; - pcCount: Word; - end; - {-This type is used in the TffFileInfo.fiPages structure. } - - TffBlockNum = packed array [0..3] of Byte; - {-This type is used to transform a block number into an array. The - various parts of the array are then used to index into the - TffFileInfo.fiPages structure. } - - TffFileAttribute = (fffaSeqScan, fffaTemporary, fffaBLOBChainSafe); - { Each file may have zero or more special attributes. Attributes are as - follows: - - fffaSeqScan - The file was created for a sequential scan of its data. - The buffer manager may elect to keep a limited number of the - file's blocks in memory. - - fffaTemporary - This is a temporary file that exists only as long as it - is needed. It is not to be saved to the hard drive. Files of this type - are typically created by a SQL cursor. - - fffaBLOBChainSafe - The in-memory BLOB deleted chain does not need to - respect transactions. Normally, the in-memory BLOB deleted chain is not - updated until the current transaction is committed or rolled back. In - certain situations, such as packing a table or building a SQL result - set, the in-memory BLOB deleted chain can be updated real-time without - becoming out of sync with the BLOB deleted chain on disk. - } - - TffFileAttributes = set of TffFileAttribute; - - PffFileInfo = ^TffFileInfo; - TffFileInfo = packed record {A FlashFiler file..} - fiVerify : TffWord32; {..verification value} - fiHandle : THandle; {..file handle} - fiBlockSize : Longint; {..block size--4K, 8K, 16K, 32K, or 64K} - fiBlockSizeK : Longint; {..block size in kilobytes--4, 8, 16, 32, or 64 } {!!.11} - fiLog2BlockSize: TffWord32; {..log base 2 of fiBlockSize (12, 13, 14, 15 or 16)} - fiUsedBlocks : TffWord32; {..number of blocks in file. We store this - value here in order to reduce number of - locks on block 0. This field is updated - when a new block is added to the file. } - fiRecordLength : Longint; {..record length} - fiRecLenPlusTrailer : Longint; {..record length plus deletion link} - fiBufMgr : TffBufferManager; {..the buffer manager being used} - fiName : PffShStr; {..fully expanded file name} - fiOpenMode : TffOpenMode; {..open mode} - fiShareMode : TffShareMode; {..share mode. Indicates how the file - has been opened by the server. The - server usually opens files in - smExclusive mode.} - fiWriteThru : Boolean; {..file has been opened in writethru mode} - fiForServer : Boolean; {..file is for the server, not the client} - fiEncrypted : Boolean; {..file is encrypted} - fiBLOBrscMgr: TffBaseBLOBResourceMgr;{.the resource manager being used} {!!.11} - fiMaxBlocks : TffWord32; {..max # of blocks for 4 GB file size} - fiMaxSegSize : TffWord32; {..max size of BLOB segment} - fiPageListHead: TffbmRAMPage; {..first RAM page in this file's list of - loaded blocks. } - fiPageListTail: TffbmRAMPage; {..last RAM page in this file's list of - loaded blocks. } - fiPageZero : TffbmRAMPage; {..The TffbmRAMPage for block 0. - We cache it here since it is frequently- - requested. } - fiPageContainerList: PffPageContainer; - {..the list of page containers used to build - the fiPages structure. We maintain - a separate list of these objects so that - we can quickly free them when this file - structure is destroyed. } - fiPages: TffPageArray; {..The blocks stored in memory as RAM pages.} - { Note: fiPages is a tree structure having multiple roots. We use the - structure to quickly determine whether or not a block is - loaded in memory. } - fiRecordLocks : TffThreadHash64;{..The record locks for this file. Used by - the lock manager. } - fiFFVersion : Longint; {..Version of FF used to create file} - fiExclOwner : TffCursorID; {..if <> ffc_W32NoValue then this is the - ID of a cursor that has exclusively - opened this file. } - fiAttributes : TffFileAttributes; - {..special attributes of the file. } - fiTempStore : TffObject; {..temporary storage used by this file. - For regular files, this will start off - as nil and then the buffer manager will - fill it with the buffer manager's - temporary storage object. For merge sort - files, the sorting algorithm will fill - this field with the file's own - temporary storage instance. } - end; - - TffSrTransactionLevel = class; { forward declaration } {!!.10} - TffSrTransaction = class; { forward declaration } - - PFFBlockCommonHeader = ^TFFBlockCommonHeader; - TFFBlockCommonHeader = packed record - bchSignature : Longint; - bchNextBlock : Longint; - bchThisBlock : TFFWord32; - bchLSN : TFFWord32; - end; - - { The following record structure is used to pass transaction-specific - information to low-level routines in FFTBDATA, FFTBINDX, and FFSRBASE. - Note that we have to pass around the transaction because its LSN may - change due to an LSN rollover. We always want the latest LSN. - - Note: It is included in this unit because it is needed both by FFSRBASE - and FFSRLOCK. } - PffTransInfo = ^TffTransInfo; - TffTransInfo = packed record - tirLockMgr : TffObject; { Really an instance of TffLockManager. } - tirTrans : TffSrTransaction; - end; - - { Stored in TffbmRAMPage.rpBlockList. Helps us track the nesting level - of each ram page. } - TffbmModifiedBlock = class(TffObject) - protected {private} - mbBlock : PffBlock; - mbBlockNumTmp : TffWord32; - {-The block in temporary storage to which this block was written. - Set to ffc_W32NoValue if not in temp storage. } - - mbTransLevelPrev: TffbmModifiedBlock; {!!.10} - mbTransLevelNext: TffbmModifiedBlock; {!!.10} - - function mbGetBlock : PffBlock; - protected - procedure AddToTransLevel; {!!.10} - procedure RemoveFromTransLevel; {!!.10} - public - Prev : TffbmModifiedBlock; - TransLevel : TffSrTransactionLevel; - RAMPage : TffbmRAMPage; - - constructor Create(aRAMPage : TffbmRAMPage; - aPrevBlock : TffbmModifiedBlock; - aTransLevel : TffSrTransactionLevel); {!!.10} - destructor Destroy; override; - - procedure Copy(aBlock : PffBlock); - procedure CopyTo(aBlock : PffBlock); - - procedure DecreaseTransLevel; {!!.10} - - procedure FreeBlock; - { Frees the object's block. } - procedure SendToTempStore; - { Sends the block to temporary storage. } - - property Block : PffBlock read mbGetBlock write mbBlock; - - end; - - PffReleaseMethod = ^TffReleaseMethod; - TffReleaseMethod = procedure(var aBlock : PffBlock) of object; - { The type of method to be called once a thread has finished accessing - a RAM page. } - - PffReleaseInfo = ^TffReleaseInfo; - TffReleaseInfo = packed record - BlockPtr : PffBlock; - MethodVar : TffInt64; - end; - { TffReleaseInfo is used in complicated routines to track which RAM pages - should be released. MethodVar is declared as a TffInt64 because - it is an easy way to store a method variable, where the first 4 bytes - are a pointer to the method code and the second 4 bytes are a pointer - to the object instance (i.e., RAM page) to which the method belongs. } - - TffbmPageReuseMode = (ffrmTempStore, ffrmUseAsIs); - { Identifies how a RAM page may be re-used. Values: - ffrmTempStore - The RAM page is to be placed in temporary storage & - another RAM page created to take its place (temporarily). - ffrmUseAsIs - The RAM page may be re-used. } - - {This class represents a file block that has been read from the hard drive - into memory. Since disk I/O is the most time-consuming operation for the - database, the buffer manager uses RAM pages to cache file blocks in memory. - - Any given RAM page may be a member of one or more lists. For example, each - instance of TffSrTransaction maintains a list of TffbmRAMPages that have been - modified by the transaction. A file maintains a list of the RAM pages that - have been read from the file. - - A RAM page supports clean reads and nested transactions. In regards to - clean reads, reading clients always access a read-only copy of the file - block (variable rpBlock). The read-only copy is updated when a transaction - commits its changes. - - When a transaction starts and dirties a RAM page, the RAM page copies the - read-only block and adds it to an internal list. Variable rpBlockListTail - points to the last modified block in the list. - - When a transaction is nested, the RAM page makes a copy of the most recently - modified block in rpBlockList. Commits cause the 2nd to last block to be - removed from the list. When only one block is left, the block is copied to - the read-only block. - - Rollbacks cause the highest block to be removed from the list. - - When a page's block is retrieved by a thread, the page's internal reference - count is incremented. This prevents the buffer manager from re-using the - page while the page is in use by one or more threads. Any thread that - retrieves a page's block must call the TffbmRAMPage.Release method when it - has finished using the block. Doing so decrements the page's ref count. } - TffbmRAMPage = class (TffObject) - protected {private} - FLastAccess : DWORD; {..the time (obtained via GetTickCount) when - this page was last accessed. } - FNew : Boolean; {..if True then this is a new file block. } {!!.07} - FRefCount : integer; {..the number of times this page has been - requested. If zero then no threads are - accessing the page. If greater than zero - then one or more threads are accessing - the page. - The count increments when the page's - block is retrieved and decrements when the - Release method is called. } - rpBlock : PffBlock; {..block data (variably sized)} - rpBlockBits : TffWord32; {..bits identifying which modified blocks - are in temporary storage. } - rpBlockListTail : TffbmModifiedBlock; - {..the last modified block in this page's - list of modified blocks. We only need the - tail because a commit or rollback of the - page affects the tail. } - rpBlockNum : TffWord32; {..zero-based block number in file} - rpBlockSize : Longint; {..sizeof rpBlock} - rpBlockSizeEnum : TffBlockSize; - rpBlockNumTmp : TffWord32; {..if not equal to ffc_W32NoValue then this - block is currently located in temporary - storage & this is the block in which it - resides in temporary storage. } - rpBufMgr : TffBufferManager; - {..the buffer mgr with which this page is - associated } - rpFI : PffFileInfo; {..the file with which this page is associated} - rpFileNext : TffbmRAMPage;{..next ram page in file page list} - rpFilePrev : TffbmRAMPage;{..previous ram page in file page list} - rpHeader : PffBlockCommonHeader; - rpInUseNext : TffbmRAMPage;{..next ram page in InUse or Recycle list} - rpInUsePrev : TffbmRAMPage;{..previous ram page in InUse list} - rpReuseMode : TffbmPageReuseMode; {..indicates how the page may be re-used } - rpTrans : TffSrTransaction; {..server transaction for which the block is dirty} - rpTransNext : TffbmRAMPage;{..next ram page in Transaction list} - rpTransPrev : TffbmRAMPage;{..previous ram page in Transaction list} - protected - procedure AddToFilePageList; - {-Adds the page to its file's list of RAM pages. } - procedure AddToRecycleList; - {-Adds the page to the recycle list. } - procedure AddToTransList(aTrans: TffSrTransaction); - {-Adds the page to a transaction item's page list. } - procedure AddToUseList; - {-Add the RAM page to the buffer manager's InUse list. } - procedure MoveToEndOfTransList; - {-Moves the RAM page to the end of its transaction's list of RAM - pages. } - procedure MoveToEndOfUseList; - {-Moves the RAM page to the end of the InUse list. This is done - so that the Least Recently Used (LRU) pages appear at the beginning - of the list. } - procedure MoveToRecycleList; - {-Moves a page from the buffer manager's InUse list to the Recycle - list. } - procedure RemoveFromFilePageList; - {-Removes the page from its file's list of RAM pages. } - procedure RemoveFromRecycleList; - {-Removes the page from the recycle list. } - procedure RemoveFromTransList(aTrans: TffSrTransaction); - {-Removes the page from a transaction item's page list. } - procedure RemoveFromUseList; - {-Remove the RAM page from the buffer manager's InUse list. } - procedure rpAllocBlock(aBlockSize : Longint); - {-Allocates a new read-only block. } - function rpAllocBlockPrim(aBlockSize : Longint) : PffBlock; - {-Carries out the actual allocation of a block. } - function rpDirty : boolean; - {-If returns True then this block is dirty. } - procedure rpFreeBlock(aBlock : PffBlock; aBlockSize : Longint); - {-Frees a specific block. } - function rpGetInTempStore : boolean; - {-If the block is in temporary storage then returns True otherwise - returns False. } - function rpGetLSN : TffWord32; - {-If no transaction has dirtied the block then returns the LSN of the - read-only block. Otherwise returns the LSN of the most recent - version. } - function rpGetTransLevel : TffSrTransactionLevel; {!!.10} - {-Returns nest level of last transaction to modify this page. } - procedure rpRelease(aBlock : PffBlock); - {-Alternative to Release method that does not nil the input parameter. } - procedure rpReplaceBlock(aNewBlock : PffBlock); - {-Replaces the read-only block with another block. } - procedure rpRetrieveFromTemp; - {-Retrieves the read-only block from temp storage. } - procedure rpSetBlockSize(aBlockSize : Longint); - procedure rpSetFI(FI : PffFileInfo); - procedure rpSetLSN(const aLSN : TffWord32); - {-Sets the LSN of a RAM page that has not been modified by a - transaction. } - public - constructor Create(aBufMgr : TffBufferManager; aFI : PffFileInfo; - const aBlockNumber : TffWord32); - destructor Destroy; override; - - function Block(aTrans : TffSrTransaction; - var aReleaseMethod : TffReleaseMethod) : PffBlock; - { Returns a copy of the file block. If the transaction requesting the - block previously modified the block then this routine returns the - last modified version of the block. If the block has not been - modified by the transaction or the aTrans parameter is nil, the - read-only copy of the block is returned. - - Once the requesting thread has finished with the block, it must call - the procedure specified by aReleaseMethod. } - - function Commit(forceWrite : boolean) : boolean; - { Commits a changed RAM page. If forceWrite is True then changes are - committed to disk regardless of nesting level and this function - returns True. - - If forceWrite is False then the following logic is used: - If the nesting level is greater than zero then this merely - decrements the TransLevel of the RAM page and returns False. - Otherwise, it writes the RAM page to disk and returns True. } - - function DirtiedForTrans(aTrans : TffSrTransaction) : boolean; - { Returns True if this block has been modified by the transaction. - This function returns True only if the following is true: - 1. aTrans is a transaction. - 2. The block is marked as dirty. - 3. The block's LSN matches the transaction's LSN. - 4. The block's nesting level matches the transaction's nesting - level. } - - procedure MakeClean; - - procedure MakeDirty(aTrans : TffSrTransaction); - - function ReadOnlyBlock : PffBlock; - { Returns the page's read-only block. } - - procedure Release(var aBlock: PffBlock); - { Use this method to tell the buffer manager that a thread is - no longer using a ram page. Every retrieval of a page must be - accompanied by a call to this method, otherwise the buffer manager - will not re-use the ram page as soon as it normally would. } - - function Removable(var RemoveMode : TffbmPageReuseMode) : boolean; - { Use this method to determine if a RAM page may be removed from - the buffer manager. - - If returns False then this page may not be removed. - - If returns True then this page may be removed. Look at the - RemoveMode parameter to determine how it may be removed. If it - returns ffrmUseAsIs then you may free the page. If it returns - ffrmTempStore then the page may be moved to temporary storage, - which removes its data block from memory. Do not free a page that - returns a mode of ffrmTempStore. } - - function Reusable(var ReuseMode : TffbmPageReuseMode) : boolean; - { Use this method to determine if the RAM page may be re-used. - - If returns False then this page may not be re-used. - - If returns True then this page may be re-used. Look at the - ReuseMode parameter to determine how it may be reused. If it returns - ffrmUseAsIs then you may use this RAM page instance as is. If it - returns ffrmTempStore then you may send the RAM page to temporary - storage and create a new RAM page to take its place. Do not free - or re-use the instance of a RAM page that returns a mode of - ffrmTempStore. } - - procedure Rollback; - { Rolls back the most recent changes to the RAM page. Assumes that - a transaction has modified the page. } - - procedure SendToTempStore; - { Use this method to send a RAM page to temp storage. } - - property BlockNumber : TffWord32 read rpBlockNum write rpBlockNum; - - property BlockSize : Longint read rpBlockSize write rpSetBlockSize; - - property Dirty : boolean read rpDirty; - { If returns True then the page has been modified by a transaction. - The Block method returns the modified block to the transaction - that dirtied the page. The Block method returns the read-only block - to all other threads. } - - property FileInfo : PffFileInfo read rpFI write rpSetFI; - - property InTempStore : boolean read rpGetInTempStore; - { If returns True then this block is currently in temporary storage. } - - property LastAccess : DWORD read FLastAccess; - { The time, obtained via GetTickCount, when this page was last - accessed by a thread. } - - property LSN : TffWord32 read rpGetLSN write rpSetLSN; - { Log Sequence Number (LSN) of the last transaction to modify the - RAM page. A RAM page already loaded into memory can be re-used - if its LSN is less than the buffer manager's CommitLSN. } - - property TransLevel : TffSrTransactionLevel read rpGetTransLevel;{!!.10} - { The nesting level of the page. If -1 then this block has not been - modified by a transaction. If zero then only one transaction - has started and modified this block. If >= 1 then there are one or - more nested transactions. } - -{Begin !!.07} - property New : Boolean read FNew write FNew; - { Indicates whether this page represents a new file block (i.e., just - added to the file). } -{End !!.07} - - property RefCount : integer read FRefCount; - { The number of times a thread has requested this page. If this - property returns zero then no threads are currently accessing the - page. If this property returns a value greater than zero then - one or more threads are reading the contents of the page. } - - property ReuseMode : TffbmPageReuseMode read rpReuseMode; - { Use this property to determine the page's reuse mode. } - - end; - -{---Transaction types---} - TffSrTransactionLevel = class(TffObject) - protected {private} - tlPrev: TffSrTransactionLevel; - tlLevel: Integer; - tlTransaction: TffSrTransaction; - - tlModifiedBlocksHead: TffbmModifiedBlock; - tlModifiedBlocksTail: TffbmModifiedBlock; - public - constructor Create(aTrans: TffSrTransaction); - destructor Destroy; override; - - property Level: Integer read tlLevel; - end; - - { This class represents an active transaction within a folder (i.e., - directory). - A transaction maintains a list of the RAM pages that have been dirtied - by the transaction. } - TffSrTransaction = class(TffSelfListItem) - protected {private} - FCorrupt : boolean; - FDatabaseID : TffDatabaseID; - FImplicit : boolean; - FJnlFile : PffFileInfo; - FLSN : TffWord32; - FNewSpace : Integer; {!!.11} - FTransLevel : integer; - FReadOnly : boolean; - FSignature : Longint; - FTransMode : TffTransactionMode; - FLockContainer : TffListItem; - - trTransLevelListTail: TffSrTransactionLevel; - - trTransPageListHead : TffbmRAMPage; - {-The first RAM page associated with this transaction. } - trTransPageListTail : TffbmRAMPage; - {-The last RAM page associated with this transaction. } - - protected - function trGetNested : boolean; - function trGetTransactionID : TffTransID; - function trGetTransLevel: TffSrTransactionLevel; {!!.10} - public - constructor Create(const aDatabaseID : TffDatabaseID; - const aImplicit, readOnly : boolean); - destructor Destroy; override; - - function AdjustLSN(const Adjustment : TffWord32) : TffWord32; - { Adjusts the transaction's LSN. The adjusted LSN is then applied to - each RAM page dirtied by the transaction. Returns the new LSN of - the transaction. } - - procedure StartNested; {!!.10} - { Increases the nesting level of the transaction } {!!.10} - procedure EndNested; {!!.10} - { Decreases the nesting level of the transaction } {!!.10} - - property DatabaseID : TffDatabaseID read FDatabaseID; - property IsCorrupt : boolean read FCorrupt write FCorrupt; - property IsImplicit : boolean read FImplicit; - property IsReadOnly : boolean read FReadOnly write FReadOnly; {!!.06} - property JournalFile : PffFileInfo - read FJnlFile write FJnlFile; - { If TransactionMode = tmFailSafe then this property identifies - the journal file. } - - property LSN : TffWord32 read FLSN write FLSN; - { The Log Sequence Number of this transaction. In the future, - this number will reflect the position within the log file of - the transaction's next log record. - For now, this is a static number assigned when the transaction - is created. } - - property Nested : boolean read trGetNested; - { Returns True if the transaction is nested. } - -{Begin !!.11} - property NewSpace : Integer read FNewspace write FNewSpace; - { # of kb in free space required for blocks added by this transaction. } -{End !!.11} - - property TransLevel : TffSrTransactionLevel read trGetTransLevel; {!!.10} - { The nesting level of the transaction. For a non-nested transaction, - this property returns zero. For a transaction that has been nested - 1 level, this property returns one, and so on. } - - property TransactionID : TffTransID read trGetTransactionID; - { The unique ID of the transaction. This will be unique across all - transactions on an FF server. } - - property TransactionMode : TffTransactionMode - read FTransMode write FTransMode; - { Indicates whether this is a normal or failsafe transaction. } - - property TransLockContainer : TffListItem - read FLockContainer write FLockContainer; - - end; - - { The most time-consuming operation performed by the database is disk I/O. - To drastically improve performance, the buffer manager caches file blocks - in memory in the form of RAM pages. It brings in blocks as needed and - writes them back to disk as needed. - - When the database needs a file block, the buffer manager will first see - if the block is already in memory as a RAM page. If the file block is - not in memory then the buffer manager chooses to allocate a new RAM page - or re-use an existing RAM page to hold the file block. - - The buffer manager, the files it accesses (i.e., the tables from - which it reads file blocks), and transactions maintain lists of RAM pages. - There may be only one instance of a file block instantiated as a RAM page. - However, that RAM page will appear in multiple lists. - - The lists maintained by the buffer manager are as follows: - - - The InUse list contains all RAM pages created by the buffer manager. - As a RAM page is accessed, it is moved to the end of this list. The - result is that the least recently used (LRU) RAM pages appear at or - near the head of this list, speeding up the buffer manager's search - for a re-usable RAM page. - - - The RecycleList contains all RAM pages no longer associated with a - file. The RAM pages are re-used for subsequent operations. - - Because multiple transactions may occur concurrently within a given - database, it is important that RAM pages be locked prior to their being - accessed. Lock requests must be managed by the TffLockManager associated - with the database containing the file. Specific locking requirements are - listed in the comments for public functions providing access to RAM pages. - } - TffBufferManager = class(TffObject) - protected {private} -{Deleted !!.10} -// bmCommitLSN : TffWord32; { The starting LSN of the oldest -// uncommitted transaction. Used to -// indicate the LSN after which blocks may -// not be re-used. } - - bmConfigDir : TffPath; - bmInUseListHead : TffbmRAMPage; - bmInUseListTail : TffbmRAMPage; - bmRecycleListHead : TffbmRAMPage; -{Begin !!.02} - bmPortal : TffPadlock; { Provides thread-safe access - to data structures. } -{End !!.02} - bmMaxRAM : Longint; { Max number of megabytes for cache. } - bmMaxRAMDetail : TffInt64; { Max number of bytes for cache. For comparisons. } - bmRAMDetail : TffInt64; { Number of bytes used. For comparisons. } - bmRAMUsed : Longint; { Number of megabytes used. For status. } - bmLRUValue : TffWord32; { The latest LRU value. Indicator for - when the block was last used. } - bmLRULockValue : TffWord32; { The LRU value of the last started - transaction. Used to indicate the point - after which blocks may not be re-used. } - bmTempStore : TffBaseTempStorage; - - protected - function GetRAM : integer; - procedure SetMaxRAM(aNumber : Longint); - - procedure bmClearRecycleList; virtual; {!!.07} - procedure bmCommitPrim(aTrans : TffSrTransaction); - function bmRAMPageCount : Longint; - function bmFileRAMPageCount(aFI : PffFileInfo) : Longint; - procedure bmFailSafeCommit(aTrans : TffSrTransaction); - function bmGetBlock(aFI : PffFileInfo; aBlockNumber : TffWord32) : TffbmRAMPage; - { Find a block in the internal data structure. If the block is not - already in memory then retrieve it. } - - function bmGetNewRAMPage(aFI : PffFileInfo; aBlockNumber : TffWord32) : TffbmRAMPage; - { Obtains a new RAM page. It tries to reuse a recycled page. If none is - available then it checks to see if adding a new page would push it - over the RAM limit. If it would push the buffer manager over the RAM - limit then it looks for a page that may be re-used. If one is found - then the page is re-used. If none is found a new page is created - from scratch. When the next transaction ends, the buffer manager tries - to remove the excess page(s). } - - function bmGetRAMPage(const anIndex : Longint) : TffbmRAMPage; - {-Returns a specific RAM page managed by the buffer manager. } - - function bmGetRecycledCount : Longint; - {-Returns the total # of RAM pages in the recycled list. } - - function bmGetTempStoreSize : integer; - {-Returns the size of temporary storage in megabytes. } - - procedure bmJournalRAMPage(aTrans : TffSrTransaction; - aRAMPage : TffbmRAMPage; aBeforeImage : boolean); - function bmOverRAMLimit(sizeOfNewBlock : Longint) : boolean; - {-Used to determine if adding a new block of the specified size would - push the buffer manager over its RAM limit. } - - procedure bmReadBlock(aFI : PffFileInfo; aBlockNumber : TffWord32; - aRAMPage : TffbmRAMPage); - {-Reads the specified block from the file, placing it into aRAMPage. - If aBlockNumber is set to ffc_W32NoValue then this method reads - block zero of the file, transferring information from the header - block into the aFI structure. } - - procedure bmRemoveCommittedPages(const aTran : TffSrTransaction); - { Called after committing a transaction subset, this procedure removes - the RAM pages associated with the specified transaction. } - - procedure bmRemoveExcessPages; - { Called after a commit or rollback, this method removes RAM pages - from the cache if the amount of memory occupied by the RAM pages - exceeds the MaxRAM property. } - - function bmSearch(aFI : PffFileInfo; aBlockNumber : TffWord32) : TffbmRAMPage; - { Determines if the page specified by aBlockNumber is already in - memory. } - - procedure bmSetTempStoreSize(aSizeInMB : integer); - { Changes the size of temporary storage. Note that this method may - be used only when the temporary storage has not been written to. - That's because this method does not handle transfer of data from - existing temporary storage to the newly-size temporary storage. } - - procedure bmDecreaseRAMDetail(const numberBytes : Longint); - procedure bmIncreaseRAMDetail(const numberBytes : Longint); - procedure bmWriteCompleteJnlHeader(aJnlFile : PffFileInfo); - procedure bmWriteIncompleteJnlHeader(aJnlFile : PffFileInfo); - procedure bmRemovePageFromTransaction(aPage: TffbmRAMPage); - public - constructor Create(const ConfigDir : TffPath; - const TempStoreSizeInMB : integer); - destructor Destroy; override; - - function AddBlock(aFI : PffFileInfo; - aTI : PffTransInfo; - const aBlockNumber : TffWord32; - var aReleaseMethod : TffReleaseMethod) : PffBlock; - { Adds a new block to the specified file (i.e., increases the size - of the file). } - - function AddFile(aFI : PffFileInfo; - aTI : PffTransInfo; - const aMarkHeaderDirty : boolean; - var aReleaseMethod : TffReleaseMethod) : PffBlock; - { Adds a file to the buffer manager's list of managed files. } - - procedure BeginWrite; - { Must be called prior to accessing the buffer manager's internal - data structures. This method is public due to its being used by - TffSrTransaction. } - - procedure DirtyBlock(aFI : PffFileInfo; - const aBlockNumber : TffWord32; - aTI : PffTransInfo; - var aModifiableBlock : PffBlock); - { Marks a block as modified by the specified transaction. The - transaction's LSN (as specified in parameter aTI) is written to - the block. Returns the modifiable copy of the block. Any method - calling this function *MUST* use the returned block instead of - the current block. } - - procedure EndWrite; - { Must be called after finished accessing the buffer manager's internal - data structures. Must be preceded by a call to BeginWrite. - This method is public due to its use by TffSrTransaction. } - - procedure FlushPools(const blockSizes : TffBlockSizes); - { Use this method to have the buffer manager flush any unused blocks - from the memory pools. aBlockSize contains enumerated values - representing the memory pools that are to be flushed. Only those - memory pools having an enumerated value in blockSizes are flushed. } - - function GetBlock(aFI : PffFileInfo; - const aBlockNumber : TffWord32; - aTI : PffTransInfo; - const aMarkDirty : boolean; - var aReleaseMethod : TffReleaseMethod) : PffBlock; - { Retrieves a block from a file. If the block is already in the - RAM cache then it is retrieved from the cache otherwise it is - retrieved from the physical file and stored in the RAM cache. } - - function GetRAMPage(aFI : PffFileInfo; - const aBlockNumber : TffWord32) : TffbmRAMPage; - { Retrieves the RAM page for a specific block in a file. } - -{Begin !!.10} - function GetRAMPageLSN(aRAMPage : TffbmRAMPage) : TffWord32; - { Retrieve the LSN of the specified RAM page. } - - function GetRAMPageLSN2(aFI : PffFileInfo; - const aBlockNumber : TffWord32) : TffWord32; - { Retrieves the RAM page for a specific block in a file. } -{End !!.10} - - procedure HandleLSNRollover; - { Called when the transaction manager rolls over its LSN. For each - RAM page that is not associated with a transaction, the buffer - manager resets the LSN of that RAM page to 1. } - - procedure Lock; {!!.05} - procedure Unlock; {!!.05} - - procedure RemoveFile(aFI : PffFileInfo); - { Moves a file's RAM pages to the buffer manager's Recycle list and - frees the structure used to index the file's RAM pages. } - - procedure UnlockBlock(aFI : PffFileInfo; aBlockNumber : TffWord32); - { This function recycles a page, removing it from the header list - (i.e., page of file header blocks) or file list and from a - transaction list if the block is associated with a transaction. - - Currently, this function is not called from the engine. } - - procedure CommitFileChanges(aFI : PffFileInfo; aTrans : TffSrTransaction); - { Use this method to commit changes to a file that is being closed - in the midst of a transaction. } - - procedure CommitTransaction(aTrans : TffSrTransaction); - procedure CommitTransactionSubset(aTrans : TffSrTransaction); - procedure RollbackTransaction(aTrans : TffSrTransaction); - procedure RollbackTransactionSubset(aTrans : TffSrTransaction); - procedure StartTransaction(aTrans : TffSrTransaction; - const aFailSafe : boolean; - const aFileName : TffFullFileName); - -{Deleted !!.10} -// property CommitLSN : TffWord32 read bmCommitLSN write bmCommitLSN; -// { The starting LSN of the oldest uncommitted transaction. Used to -// indicate the LSN after which blocks may not be re-used. } - - property ConfigDir : TffPath read bmConfigDir write bmConfigDir; - { The server engine's configuration directory. Passed on to temporary - storage. } - - property MaxRAM : integer read bmMaxRAM write SetMaxRAM; - { The maximum amount of RAM the buffer manager may allocate to hold - RAM pages. } - - property RAMPageCount : Longint read bmRAMPageCount; - { Returns the number of RAM pages being managed by the buffer - manager. } - - property RAMPages[const aIndex : Longint] : TffbmRAMPage - read bmGetRAMPage; - { Use this property to access the RAM pages managed by the buffer - manager. This property is base zero. The upper bound is - pred(RAMPageCount). - - Note: This property is for unit testing purposes only. The buffer - manager uses a sequential search to find the specified RAM page - so accessing this property could lead to poor performance. } - - property RAMUsed : integer read GetRAM; - { The total amount of RAM allocated to RAM pages by the buffer - manager. Note that this property is not thread-safe. It returns - whatever value is available at the time and does not worry about - the value being modified while it is being read. } - - property RecycledCount : Longint read bmGetRecycledCount; - { Returns the total number of RAM pages in the recycled list. } - - property TempStoreSize : integer read bmGetTempStoreSize - write bmSetTempStoreSize; - { Gets and sets the size of temporary storage, in MegaBytes (MB). - Note that you should never change the size of temporary storage - after temporary storage has already been written to. This is - because the change routine does not transfer blocks already - written to temp storage from the existing temp storage to the - new temp storage. } - end; - -{---Primitive file access: procedural types, vars---} - TffCloseFilePrim = procedure (aFI : PffFileInfo); - {-to close a file} - TffFlushFilePrim = procedure (aFI : PffFileInfo); - {-to flush a file} - TffGetPositionFilePrim = function (aFI : PffFileInfo) : TffInt64; - {-to return the position of the file cursor} - TffOpenFilePrim = function (aName : PAnsiChar; - aOpenMode : TffOpenMode; - aShareMode : TffShareMode; - aWriteThru : boolean; - aCreateFile : boolean) : THandle; - {-to open/create file} - TffPositionFilePrim = procedure (aFI : PffFileInfo; const aOffset : TffInt64); - {-to position file cursor} - TffPositionFileEOFPrim = function (aFI : PffFileInfo) : TffInt64; - {-to position file cursor at EOF, returning file size} - TffReadFilePrim = function (aFI : PffFileInfo; aToRead : TffWord32; var aBuffer) : TffWord32; - {-to read from file, returning bytes read} - TffSetEOFPrim = procedure (aFI : PffFileInfo; const aOffset : TffInt64); - {-to truncate/extend file} - TffSleepPrim = procedure (MilliSecs : Longint); - {-to sleep/delay a period of time} - TffWriteFilePrim = function (aFI : PffFileInfo; aToWrite : TffWord32; const aBuffer) : TffWord32; - {-to write to file, returning bytes written} - - -{---Type definitions of the different block headers---} -{ Note: all block headers start with a signature, a next block field, - a this block field, and a log sequence number field} - PffBlockHeaderFile = ^TffBlockHeaderFile; - TffBlockHeaderFile = packed record {Block header for file} - bhfSignature : Longint; {'FFFH'} - bhfNextBlock : TffWord32; {should always be -1} - bhfThisBlock : TffWord32; {should be equal to this block number} - bhfLSN : TffWord32; {highest LSN of any block in the table; - updated each time a non-readonly - transaction is committed} - bhfBlockSize : Longint; {size of blocks in bytes (4K, 8K, 16K, 32K, 64K)} - bhfEncrypted : Longint; {0-not encrypted, 1-encrypted} - bhfLog2BlockSize: TffWord32; {log base 2 of bhfBlockSize (12, 13, 14, 15 or 16)} - bhfUsedBlocks : TffWord32; {number of blocks in file} - bhfAvailBlocks : Longint; {number of free blocks} - bhf1stFreeBlock : TffWord32; {number of first free block, or -1} - bhfRecordCount : Longint; {number of records in file} - bhfDelRecCount : Longint; {number of deleted records in file} - bhf1stDelRec : TffInt64; {offset of 1st deleted record, or -1} - bhfRecordLength : Longint; {record length} - bhfRecLenPlusTrailer : Longint; {record length plus deletion link} - bhfRecsPerBlock : Longint; {number of records per block} - bhf1stDataBlock : TffWord32; {first data block, or -1} - bhfLastDataBlock: TffWord32; {last data block, or -1} - bhfBLOBCount : TffWord32; {number of BLOBs in file} - bhfDelBLOBHead : TffInt64; {file-relative offset of deleted BLOB chain head} - bhfDelBLOBTail : TffInt64; {file-relative offset of deleted BLOB chain tail} - bhfAutoIncValue : TffWord32; {Last used autoinc value} - bhfIndexCount : Longint; {number of indexes} - bhfHasSeqIndex : Longint; {0-no seq access index; 1-has seq access index} - bhfIndexHeader : TffWord32; {block number of index header} - bhfFieldCount : Longint; {number of fields} - bhfDataDict : TffWord32; {data dictionary stream, or 0} - bhfFFVersion : Longint; {FF Version this file was created with} - bhfReserved : array [1..5] of Longint; - {reserved for expansion of Longint values} - bhfReserved2 : array [1..892] of byte; - {reserved for expansion up to 1036 bytes} - end; - - PffBlockHeaderData = ^TffBlockHeaderData; - TffBlockHeaderData = packed record {Block header for data} - bhdSignature : Longint; {'FFDH'} - bhdNextBlock : TffWord32; {number of next block in chain, or -1} - bhdThisBlock : TffWord32; {should be equal to this block number} - bhdLSN : TffWord32; {log sequence number} - bhdRecCount : Longint; {number of records in block, =bhfRecsPerBlock} - bhdRecLength : Longint; {record length, =bhfRecordLength} - bhdNextDataBlock: TffWord32; {number of next data block} - bhdPrevDataBlock: TffWord32; {number of previous data block} - end; - - PffBlockHeaderIndex = ^TffBlockHeaderIndex; - TffBlockHeaderIndex = packed record {Block header for index} - bhiSignature : Longint; {'FFIH'} - bhiNextBlock : TffWord32; {number of next block in chain, or -1} - bhiThisBlock : TffWord32; {should be equal to this block number} - bhiLSN : TffWord32; {log sequence number} - bhiBlockType : byte; {0=header, 1=btree page} - bhiIsLeafPage : boolean; {0=internal btree page, 1=leaf btree page} - bhiNodeLevel : byte; {node level (leaves are 1, increments)} - bhiKeysAreRefs : boolean; {true if keys are reference numbers} - bhiIndexNum : word; {index number to which page belongs} - bhiKeyLength : word; {length of each key} - bhiKeyCount : Longint; {current number of keys in page} - bhiMaxKeyCount : Longint; {maximum number of keys in page} - bhiPrevPageRef : TffWord32; {previous page reference !!MUST BE HERE!!} - end; - - PffBlockHeaderBLOB = ^TffBlockHeaderBLOB; - TffBlockHeaderBLOB = packed record {Block header for BLOB} - bhbSignature : Longint; {'FFBH'} - bhbNextBlock : TffWord32; {number of next block in chain, or -1} - bhbThisBlock : TffWord32; {should be equal to this block number} - bhbLSN : TffWord32; {log sequence number} - bhbAssignedSegCount : TffWord32; {number of segments in a BLOB block; this - field is not maintained as of v2.13 } - bhbReserved : array [0..1] of Longint; - end; - - PffBlockHeaderStream = ^TffBlockHeaderStream; - TffBlockHeaderStream = packed record {Block header for stream} - bhsSignature : Longint; {'FFSH'} - bhsNextBlock : TffWord32; {number of next block in chain, or -1} - bhsThisBlock : TffWord32; {should be equal to this block number} - bhsLSN : TffWord32; {log sequence number} - bhsNextStrmBlock: TffWord32; {next stream block in chain, or -1} - bhsStreamType : Longint; {user-defined type of stream} - bhsStreamLength : Longint; {length of stream (only in first block)} - bhsOwningStream : Longint; {number of stream that owns block} - end; - - PffBLOBHeader = ^TffBLOBHeader; - TffBLOBHeader = packed record {Header for BLOBs} - bbhSignature : Byte; {..'H' for header segment, 'D' for deleted !!.01 - BLOB} {!!.01} - bhbFiller : Byte; {..used to align bytes in memory} - bbhSegmentLen : Word; {..length of this segment} - bbhBLOBLength : TffWord32; {..length of BLOB in bytes} {!!.06} - bbhSegCount : Longint; {..number of segments, - -1 for file BLOBs, -2 for BLOB links } - bbh1stLookupSeg : TffInt64; {..file-relative offset of 1st lookup segment, - -1 for file BLOBs} - end; - - PffIndexHeader = ^TffIndexHeader; - TffIndexHeader = packed record {Header for index data} - bihIndexKeyLen : array [0..pred(ffcl_MaxIndexes)] of word; - {..key lengths for each index} - bihIndexFlags : array [0..pred(ffcl_MaxIndexes)] of byte; - {..flags for each index} - bihIndexKeyCount : array [0..pred(ffcl_MaxIndexes)] of Longint; - {..number of keys for each index} - bihIndexRoot : array [0..pred(ffcl_MaxIndexes)] of TffWord32; - {..root page for each index} - bihIndexPageCount: array [0..pred(ffcl_MaxIndexes)] of Longint; - {..number of pages for each index} - end; - - PffBLOBLookupEntry = ^TffBLOBLookupEntry; - TffBLOBLookupEntry = packed record {Lookup entry for BLOB} - bleSegmentOffset : TffInt64; {File-relative offset of segment} - bleContentLength : TffWord32; {Length of the content, may be < length} {!!.11} - {of segment} - end; - - PffBLOBSegmentHeader = ^TffBLOBSegmentHeader; - TffBLOBSegmentHeader = packed record {Segment header for active BLOB} - bshSignature : byte; {'C' for content, 'D' for deleted, - 'L' for lookup segments} - bshFiller : byte; {aligns bytes in memory} - bshSegmentLen : word; {Length of this segment} - bshParentBLOB : TffInt64; {File-relative offset of header - segment, or -1} - bshNextSegment : TffInt64; {File-relative offset of next segment, - or -1} - end; - - PffBLOBSegmentHeaderDel = ^TffBLOBSegmentHeaderDel; - TffBLOBSegmentHeaderDel = packed record{Segment header for deleted BLOB} - bshSignature : byte; {'D' for deleted} - bshFiller : byte; {aligns bytes in memory} - bshSegmentLen : word; {Length of this segment} - bshNextSegment : TffInt64; {File-relative offset of next segment, - or -1} - bshPrevSegment : TffInt64; {File-relative offset of prev segment, - or -1} - end; - -{Begin !!.03} - TffBLOBSegAction = (bsaNone, bsaAddToList, bsaDeleteFromList); -{End !!.03} - - TffBLOBSegListItem = class(TffListItem) - protected - FSize : Longint; - FOffset : TffInt64; -{Begin !!.03} - FPendingAction : TffBLOBSegAction; - { Identifies the action to be taken upon the list item pending the - commit or rollback of the current transaction. } - FTranNextItem : TffBLOBSegListItem; - { The next BLOB segment list item modified by the current transaction. - Allows for quick iteration through modified segments. } -{End !!.03} - public - constructor Create; - 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} - - property Size : Longint read fSize write fSize; - { The total size of the segment including header information. } - - property Offset : TffInt64 read fOffset write fOffset; - { The offset of the segment within the file. } - end; - -{Begin !!.11} - TffBaseBLOBSegmentMgr = class(TffObject) - { Base class representing a BLOB segment manager. The segment manager - carries out the dirty work of managing an internal free segment list for - instances of TffBaseBLOBResourceMgr. } - protected - bsmUseTranList : Boolean; - bsmDelChain : TffList; - bsmDelChainSize : integer; { defaults to ciDelChainSize } - bsmTranListHead : TffBLOBSegListItem; - procedure bsmAddToDeletedSegChain(aFI : PffFileInfo; - aTI : PffTransInfo; - aFileHeader : PffBlockHeaderFile; - aDelSeg : TffBLOBSegListItem; - aSegment : PffBLOBSegmentHeaderDel); - {-Inserts the deleted segment into the deleted chain within the - physical file. } - - procedure bsmAddToTranList(aSegItem : TffBLOBSegListItem; - anAction : TffBLOBSegAction); - { Adds a segment list item to the list of items modified by the current - transaction. } - - procedure bsmRemoveFromTranList(aSegItem : TffBlobSegListItem); - procedure bsmSliceSegment(aFI : PffFileInfo; - aTI : PffTransInfo; - aSegOfs : TffInt64; - aSegSize : TffWord32; - const aNewSize : TffWord32; - aInDelChain : Boolean); - {makes two smaller deleted segments from a larger one} - procedure bsmRemoveFromDeletedChain(aFI : PffFileInfo; - aTI : PffTransInfo; - aSegOfs : TffInt64); - {removes segment from deleted chain and updates file header} - public - constructor Create(aFI : PffFileInfo; aTI : PffTransInfo); - destructor Destroy; override; - - procedure Commit; virtual; - procedure DeleteSegment(aFI : PffFileInfo; - aTI : PffTransInfo; - const aSegOffset : TffInt64); virtual; - function GetNewSeg(aFI : PffFileInfo; - aTI : PffTransInfo; - const aSize : TffWord32) : TffInt64; virtual; - function GetRecycledSeg(aFI : PffFileInfo; - aTI : PffTransInfo; - var aSizeNeeded : Longint; - const aMinSizeAllowed : Longint) - : TffInt64; virtual; abstract; - procedure ListFreeSpace(aFI : PffFileInfo; aTI : PffTransInfo; - const aInMemory : Boolean; - aStream : TStream); virtual; - procedure Rollback; virtual; - end; - - TffBLOBSegmentMgr = class(TffBaseBLOBSegmentMgr) - { This version of the BLOB segment manager supports the improved nesting - algorithm that makes use of available segments even if they are smaller - than the requested size. } - public - function GetRecycledSeg(aFI : PffFileInfo; - aTI : PffTransInfo; - var aSizeNeeded : Longint; - const aMinSizeAllowed : Longint) - : TffInt64; override; - end; - - Tff210BLOBSegmentMgr = class(TffBaseBLOBSegmentMgr) - { This version of the BLOB segment manager supports tables created prior - to version 2.1.0.1. } - public - function GetRecycledSeg(aFI : PffFileInfo; - aTI : PffTransInfo; - var aSizeNeeded : Longint; - const aMinSizeAllowed : Longint) - : TffInt64; override; - end; - - TffBLOBSegmentMgrClass = class of TffBaseBLOBSegmentMgr; - TffBLOBResourceMgrClass = class of TffBaseBLOBResourceMgr; - - TffBaseBLOBResourceMgr = class(TffObject) - { Base class is used by a table to manage the creation and - deletion of BLOB segments. One instance of a concrete subclass - should be created per table. } - private - brmPadlock : TffPadlock; - { Used to ensure only one thread actually tries to create a BLOB - segment manager. } - protected - brmDelChainSize : integer; { defaults to ciDelChainSize } - brmSegmentMgr : TffBaseBLOBSegmentMgr; - brmSegMgrLoaded : boolean; - - function brmGetSegMgrClass : TffBLOBSegmentMgrClass; virtual; abstract; - procedure brmLoadSegMgr(aFI : PffFileInfo; aTI : PffTransInfo); virtual; - public - constructor Create; virtual; - destructor Destroy; override; - - class function GetMgr(aFI : PffFileInfo) : TffBaseBLOBResourceMgr; - { Determines which BLOB resource manager implementation should be used - for the specified file. } - - procedure Commit; virtual; - procedure DeleteSegment(aFI : PffFileInfo; - aTI : PffTransInfo; - const aSegOffset : TffInt64); virtual; - { Use this method to delete an existing segment once it is no longer needed. - This class will zero out the segment and place it in the recycle list. - @param aFI The file containing the segment. - @param segOffset The offset of the existing segment within the file. } - - function NewSegment(aFI : PffFileInfo; - aTI : PffTransInfo; - var aSizeNeeded : TffWord32; - const aMinSizeAllowed : TffWord32) : TffInt64; virtual; abstract; - { Use this method to obtain a new segment of the specified size. - You may ask for any size segment. However, this class will not allocate - a segment larger than the specified file's block size. Parameters: - aFI - The file that is to contain the segment. - aTI - The transaction in which the action is being taken. - aSizeNeeded - The number of bytes to store in the segment. - aMinSizeAllowed - For those segment mgr implementations that support - it, the minimum size of the segment. - This function returns the file-relative offset of the segment or -1 if - a new segment could not be obtained. } - - procedure ListFreeSpace(aFI : PffFileInfo; aTI : PffTransInfo; - const aInMemory : Boolean; - aStream : TStream); virtual; - procedure Rollback; virtual; - end; - - TffBLOBResourceMgr = class(TffBaseBLOBResourceMgr) - { This version of the BLOB resource manager supports the improved nesting - algorithm that makes use of available segments even if they are smaller - than the requested size. } - protected - function brmGetSegMgrClass : TffBLOBSegmentMgrClass; override; - public - function NewSegment(aFI : PffFileInfo; - aTI : PffTransInfo; - var aSizeNeeded : TffWord32; - const aMinSizeAllowed : TffWord32) - : TffInt64; override; - end; - - Tff210BLOBResourceMgr = class(TffBaseBLOBResourceMgr) - { This version of the BLOB resource manager supports tables created prior - to version 2.1.0.1. } - protected - function brmGetSegMgrClass : TffBLOBSegmentMgrClass; override; - public - function NewSegment(aFI : PffFileInfo; - aTI : PffTransInfo; - var aSizeNeeded : TffWord32; - const aMinSizeAllowed : TffWord32) - : TffInt64; override; - end; -{End !!.11} - -var - FFCloseFilePrim : TffCloseFilePrim; - {-Primitive routine to close a file} - FFFlushFilePrim : TffFlushFilePrim; - {-Primitive routine to flush a file} - FFGetPositionFilePrim : TffGetPositionFilePrim; - {-Primitive routine to get position of file cursor} - FFOpenFilePrim : TffOpenFilePrim; - {-Primitive routine to open/create a file} - FFPositionFilePrim : TffPositionFilePrim; - {-Primitive routine to position file cursor} - FFPositionFileEOFPrim : TffPositionFileEOFPrim; - {-Primitive routine to position file cursor at EOF, returning file size} - FFReadFilePrim : TffReadFilePrim; - {-Primitive routine to read from file, returning bytes read} - FFSetEOFPrim : TffSetEOFPrim; - {-Primitive routine to truncate/extend file} - FFSleepPrim : TffSleepPrim; - {-Primitive routine to sleep/delay a period of time} - FFWriteFilePrim : TffWriteFilePrim; - {-Primitive routine to write to file, returning bytes written} - -const - ffc_AdminRights : TffUserRights = - [arAdmin, arRead, arInsert, arUpdate, arDelete]; - ffc_AllUserRights : TffUserRights = - [arRead, arInsert, arUpdate, arDelete]; - -{---constants for the file data---} -const - {signatures} - ffc_SigHeaderBlock = $48024646; {'FF2H'} - ffc_SigHeaderBlockv1 = $48464646; {'FFFH'} - ffc_SigDataBlock = $48444646; {'FFDH'} - ffc_SigIndexBlock = $48494646; {'FFIH'} - ffc_SigBLOBBlock = $48424646; {'FFBH'} - ffc_SigStreamBlock = $48534646; {'FFSH'} - ffc_SigFreeBlock = $44414544; {'DEAD'} - ffc_SigJnlHeader = $4846464A; {'JFFH'} - ffc_SigJnlRecHeader = $4852464A; {'JFRH'} - ffc_SigDictStream = $54434944; {'DICT'} - - {block header sizes} - ffc_BlockHeaderSizeHeader = sizeof(TffBlockHeaderFile); -(*ffc_BlockHeaderSizeData = sizeof(TffBlockHeaderData); moved to FFLLBASE *) - ffc_BlockHeaderSizeIndex = sizeof(TffBlockHeaderIndex); - ffc_BlockHeaderSizeBLOB = sizeof(TffBlockHeaderBLOB); - ffc_BlockHeaderSizeStream = sizeof(TffBlockHeaderStream); - - {BLOB-specific constants} - ffc_BLOBHeaderSize = sizeof(TffBLOBHeader); - ffc_BLOBBlockTypeHeader = 0; - ffc_BLOBBlockTypeSeg = 1; - ffc_BLOBSegmentHeaderSize = sizeof(TffBLOBSegmentHeader); - ffc_BLOBLookupEntrySize = sizeof(TffBLOBLookupEntry); - ffc_BLOBSegmentIncrement = 64; - - {Index-specific constants} - ffc_InxBlockTypeHeader = 0; - ffc_InxBlockTypeBtreePage = 1; - ffc_InxFlagAllowDups = 1; - ffc_InxFlagKeysAreRefs = 2; - - {BLOB segment signatures} - ffc_SigBLOBSegHeader = $48; {'H'} - ffc_SigBLOBSegContent = $43; {'C'} - ffc_SigBLOBSegDeleted = $44; {'D'} - ffc_SigBLOBSegLookup = $4C; {'L'} - - ciDelChainSize = 20; { Default # of entries in deleted chain linked list. } - ciSegmentMultiple = 64; { Size increment for segments. } - -{---Journal file header types---} -type - TffJournalFileHeader = packed record {journal file header} - jfhSignature : Longint; {..signature: 'TFFH'} - jfhState : Longint; {..0=incomplete transaction, 1=complete} - end; - - TffJournalFileRecordHeader = packed record {journal file record header} - jfrhSignature : Longint; {..signature: 'TFRH'} - jfrhBlockNumber : TffWord32; {..block number in file} - jfrhBlockSize : Longint; {..size of block} - jfrhBeforeImg : Longint; {..0=after image, 1=before image} - jfrhFileName : TffMaxPathZ; {..file name} - end; - - - -{---Verification routines---} -function FFVerifyBLOBNr(const aBLOBNr : TffInt64; - aLog2BlockSize: Longint) : boolean; - {-Verify a BLOB number to be valid} -function FFVerifyIndexCount(IndexCount : Longint) : boolean; - {-Verify number of indexes to be between 0 and 255} -function FFVerifyRefNr(const aRefNr : TffInt64; - aLog2BlockSize : Longint; - aRecLenPlusTrailer : TffWord32) : boolean; - {-Verify a record's RefNr to be valid} - - -{---Internal File Info routines---} -function FFAllocFileInfo(const aName : TffFullFileName; - const aExt : TffExtension; - aBufMgr : TffBufferManager) : PffFileInfo; - {-Allocate a file information record for file with name aName} -procedure FFChangeFileInfo(aFI : PffFileInfo; - const aNewName : TffFullFileName; - const aExt : TffExtension); - {-Change a file information record for a new name aName - Note: file must be closed} -procedure FFFreeFileInfo(var aFI : PffFileInfo); - {-Free a file information record} -procedure FFVerifyFileHeaderSignature(aFI : PffFileInfo; const signature : Longint); - {-Verify a file has a valid file header} -procedure FFVerifyFileInfo(aFI : PffFileInfo; IsOpen : boolean); - {-Verify a file information record to be valid and open/closed} - - -{---File Access Routines---} -procedure FFCloseFile(aFI : PffFileInfo); - {-Close file aFI} - { Exception raised if close call fails} -function FFFileIsOpen(aFI : PffFileInfo) : boolean; - {-Return true if the file aFI is open} - { All exceptions are trapped and generate a result of False} -procedure FFFlushFile(aFI : PffFileInfo); - {-Flushes file aFI} - { Exception raised if flush call fails} -procedure FFForceFlushFile(aFI : PffFileInfo); - {-Flushes file aFI by closing and reopening it} - { Exception raised if anything fails} -function FFGetPositionFile(aFI : PffFileInfo) : TffInt64; - {-Get position (offset from start) of file pointer of file aFI} - { Exception raised if seek call fails} -function FFGetFileSize(aFI : PffFileInfo) : TffInt64; - {-Get size of file aFI} - { Exception raised if seek call fails} -procedure FFOpenFile(aFI : PffFileInfo; - aOpenMode : TffOpenMode; - aShareMode : TffShareMode; - aWriteThru : boolean; - aCreateFile : boolean); - {-Allocate new file aFI, open it} - { Exception raised if open call fails, if out of memory} -procedure FFPositionFile( aFI : PffFileInfo; - const aOffset : TffInt64); - {-Position file pointer of file aFI at aOffset} - { Exception raised if seek call fails} -function FFPositionFileEOF(aFI : PffFileInfo) : TffInt64; - {-Position file pointer of file aFI at EOF, return file length} - { Exception raised if seek call fails} -function FFReadFile(aFI : PffFileInfo; - aToRead : TffWord32; - var aBuffer) : TffWord32; - {-Read aToRead bytes from file aFI into aBuffer, return bytes read} - { Exception raised if read call fails} -procedure FFReadFileExact(aFI : PffFileInfo; - const aToRead : TffWord32; - var aBuffer); - {-Read exactly aToRead bytes from file aFI into aBuffer} - { Exception raised if not exactly aToRead bytes read} -procedure FFReadFileExactAt(aFI : PffFileInfo; - const aOffset : TffInt64; - aToRead : TffWord32; - var aBuffer); - {-Read exactly aToRead bytes from file aFI at position aOffset into aBuffer} -procedure FFSetEOF(aFI : PffFileInfo; - const aOffset : TffInt64); - {-Truncates/extends file aFI to position aOffset} -function FFWriteFile(aFI : PffFileInfo; - aToWrite : TffWord32; - const aBuffer) : TffWord32; - {-Write aToWrite bytes to file aFI from aBuffer, return bytes written} - { Exception raised if write call fails} -procedure FFWriteFileExact(aFI : PffFileInfo; - aToWrite : TffWord32; - const aBuffer); - {-Write exactly aToWrite bytes to file aFI from aBuffer} - { Exception raised if not exactly aToWrite bytes written} -procedure FFWriteFileExactAt(aFI : PffFileInfo; - const aOffset : TffInt64; - aToWrite : TffWord32; - const aBuffer); - {-Write exactly aToWrite bytes to file aFI at position aOffset from aBuffer} -function FFCalcMaxFileSize(aFI : PffFileInfo) : TffInt64; - {-Calculate maximum file size for a table} -function FFCalcMaxBLOBSegSize(aFI : PffFileInfo) : TffWord32; - {-Calculate maximum BLOB segment size} - -{---Encrypted File Access Routines---} -procedure FFReadDecryptFileExact(aFI : PffFileInfo; - aToRead : TffWord32; - var aBuffer); - {-Read/decrypt exactly aToRead bytes from file aFI into aBuffer} - { Exception raised if not exactly aToRead bytes read} -procedure FFReadDecryptFileExactAt(aFI : PffFileInfo; - const aOffset : TffInt64; - aToRead : TffWord32; - var aBuffer); - {-Read/decrypt exactly aToRead bytes from file aFI at position - aOffset into aBuffer} -procedure FFWriteEncryptFileExact(aFI : PffFileInfo; - aToWrite : TffWord32; - var aBuffer); - {-Write/encrypt exactly aToWrite bytes to file aFI from aBuffer} - { Exception raised if not exactly aToWrite bytes written} -procedure FFWriteEncryptFileExactAt(aFI : PffFileInfo; - const aOffset : TffInt64; - aToWrite : TffWord32; - var aBuffer); - {-Write/encrypt exactly aToWrite bytes to file aFI at position - aOffset from aBuffer} - - -{---File Management Routines---} -procedure FFDeleteFile(const FileName : TffFullFileName); - {-Delete file FileName} -procedure FFCopyFile(const FromFileName, ToFileName : TffFullFileName); - {-Copy file FromFileName to file ToFileName, overwrite if exists} -procedure FFRenameFile(const OldFileName, NewFileName : TffFullFileName); - {-Rename file OldFileName to NewFileName} - -{---Retry Management---} -procedure FFCheckRemainingTime; {!!.02} - { Determines if the operation has timed out. } {!!.02} -function FFGetRetry : DWORD; - { Returns the end time of the operation. } -function FFGetRemainingTime : Longint; {!!.01} - { Returns the # of milliseconds until the operation times out. } -procedure FFSetRetry(const aTimeout : DWORD); - { Sets the end time of the operation. aTimeout is the number of milliseconds - the current operation has to complete. } - -{---Utility Routines---} -function FFCalcLog2BlockSize(const BlockSize : Longint) : TffWord32; -function FFCalcMaxLookupEntries(LookupSegPtr : PffBLOBSegmentHeader) : TffWord32; {!!.11} -function FFGetBlockNum(aFI : PffFileInfo; - const anOffset : TffInt64) : TffWord32; -function FFAllocReleaseInfo(aBlock : PffBlock; - aMethod : TffInt64) : PffReleaseInfo; -procedure FFDeallocReleaseInfo(aReleaseInfo : PffReleaseInfo); - -implementation - -uses - ffsrblob, - ffsrlock, - fftbbase; - -const - VerificationValue = $FF15FABB; - ciReopenSleep : DWORD = 25; {!!.06} - { # of milliseconds to sleep before attempting to reopen a file. - Used in FFForceFlushFile. On W2K machines, it is possible for the OS - to consider the file open even though it was just previously closed. - Not sure why this happens. This behavior has been seen by at least one - other person outside TurboPower and waiting for the OS to flush the - closed file seems to be the only answer. } - - { Signatures } - ffc_SigTransaction = $51544646; {'FFTR'} - - -var - Pool4K : TffMemoryPool; {Block pool - 4K} - Pool8K : TffMemoryPool; {Block pool - 8K} - Pool16K: TffMemoryPool; {Block pool - 16K} - Pool32K: TffMemoryPool; {Block pool - 32K} - Pool64K: TffMemoryPool; {Block pool - 64K} - EncryptBuffer : PffByteArray; {for encryption} - -type - PFIBlockKey = ^TFIBlockKey; - TFIBlockKey = record - FI : PffFileInfo; - BN : TffWord32; - end; - -{$IFDEF RAMPageCheck} -procedure Log(aMsg : string; args : array of const); -begin - if aLog <> nil then - aLog.WriteStringFmt(aMsg, args); -end; -{$ENDIF} - -{===File Management Routines=========================================} -{$I FFSRBASE.INC} -{====================================================================} - -{===Retry Management=================================================} - -threadvar - fftv_RetryUntil : DWORD; - { This variable is set on a per thread basis in the TffServerEngine - for each database operation. It indicates the tickcount at which an - operation is considered to be timed out. This variable is used to - determine the timeout for lock requests in the lower parts of the - engine. - - NOTE: SPW - 9/13/2000 - Moved this to the implementation section because - D3.02 was failing with an L1086 error when the variable was in the - interface section. - } -{Begin !!.02} -{--------} -procedure FFCheckRemainingTime; -var - RetryUntil : DWORD; - TickCount : DWORD; -begin - RetryUntil := FFGetRetry; - TickCount := GetTickCount; - - { Do we have any time left? } - if (RetryUntil < TickCount) or - ((RetryUntil - TickCount) < 10) then - { No. } - FFRaiseExceptionNoData(EffServerException, ffStrResServer, - fferrGeneralTimeout); -end; -{End !!.02} -{--------} -function FFGetRemainingTime : Longint; {!!.01} -begin - if (fftv_RetryUntil = ffcl_INFINITE) or {!!.01}{!!.06} - (fftv_RetryUntil = 0) then {!!.01} - Result := 0 {!!.01} - else if fftv_RetryUntil < GetTickCount then {!!.02} - Result := 1 {!!.02} - else {!!.01} - Result := fftv_RetryUntil - GetTickCount; -end; -{--------} -function FFGetRetry : DWORD; -begin - Result := fftv_RetryUntil; -end; -{--------} -procedure FFSetRetry(const aTimeout : DWORD); - {-Sets the retry limit for the current thread. Assumes that - aTimeout is specified in milliseconds. The retry limit is - stored in variable fftv_RetryUntil (unit FFSRBASE). The retry - limit is used when acquiring table & record locks. - - This routine should be called in the public methods of - TffServerEngine. If a public method is sending a notification - to extenders, the calling of this routine should occur before - the extender notification as the extender may be doing something - that involves table & record locking. } -begin - if aTimeout <= 0 then - fftv_RetryUntil := ffcl_INFINITE {!!.06} - else - fftv_RetryUntil := GetTickCount + aTimeout; -end; -{====================================================================} - -{===Utility routines=================================================} -function FFCalcLog2BlockSize(const BlockSize : Longint) : TffWord32; -begin - case BlockSize of - 4*1024 : Result := 12; - 8*1024 : Result := 13; - 16*1024 : Result := 14; - 32*1024 : Result := 15; - else - Result := 16; - end;{case} -end; -{--------} -function FFCalcMaxLookupEntries(LookupSegPtr : PffBLOBSegmentHeader) : TffWord32; {!!.11} -begin - Result := ((LookupSegPtr^.bshSegmentLen - sizeof(TffBLOBSegmentHeader)) - div sizeof(TffBLOBLookupEntry)); -end; -{--------} -function FFGetBlockNum(aFI : PffFileInfo; - const anOffset : TffInt64) : TffWord32; - { Returns the block number for the specified file offset. } -var - TempI64 : TffInt64; -begin - ffShiftI64R(anOffset, aFI^.fiLog2BlockSize, TempI64); - Result := TempI64.iLow; -end; -{--------} -function FFAllocReleaseInfo(aBlock : PffBlock; - aMethod : TffInt64) : PffReleaseInfo; -begin - FFGetMem(Result, SizeOf(TffReleaseInfo)); - Result^.BlockPtr := aBlock; - Result^.MethodVar := aMethod; -end; -{--------} -procedure FFDeallocReleaseInfo(aReleaseInfo : PffReleaseInfo); -begin - TffReleaseMethod(aReleaseInfo^.MethodVar)(aReleaseInfo^.BlockPtr); - FFFreeMem(aReleaseInfo, SizeOf(TffReleaseInfo)); -end; -{====================================================================} - -{===Verification routines for BLOB segments==========================} -function FFVerifyBLOBNr(const aBLOBNr : TffInt64; - aLog2BlockSize: Longint) : boolean; -{Note: a BLOB number is a file-offset to a BLOB header} -var - Offset : TffInt64; - TempI64 : TffInt64; -begin - Result := false; - TempI64.iLow := 0; - TempI64.iHigh := 0; - {BLOB Number can't be = 0} - if (ffCmpI64(aBLOBNr, TempI64) <> 0) then begin - ffShiftI64R(aBLOBNr, aLog2BlockSize, Offset); - ffShiftI64L(Offset, aLog2BlockSize, Offset); - ffI64AddInt(Offset, ffc_BlockHeaderSizeBLOB, Offset); - ffI64MinusI64(aBLOBNr, Offset, Offset); - if (ffCmpI64(Offset, TempI64) = 0) then - Result := true - else if (ffCmpI64(Offset, TempI64) > 0) then begin - ffI64DivInt(Offset, ffc_BLOBSegmentIncrement, TempI64); - ffI64MultInt(TempI64, ffc_BLOBSegmentIncrement, TempI64); - if ffCmpI64(Offset, TempI64) = 0 then - Result := true; - end; {if..else} - end; -end; -{--------} -function FFVerifyIndexCount(IndexCount : Longint) : boolean; -begin - Result := (IndexCount and $FFFFFF00) = 0; -end; -{--------} -function FFVerifyRefNr(const aRefNr : TffInt64; - aLog2BlockSize : Longint; - aRecLenPlusTrailer : TffWord32) : boolean; -var - Offset : TffInt64; - TempI64 : TffInt64; -begin - Result := false; - TempI64.iLow := 0; - TempI64.iHigh := 0; - if (ffCmpI64(aRefNr, TempI64) <> 0) then begin - ffShiftI64R(aRefNr, aLog2BlockSize, TempI64); - ffShiftI64L(TempI64, aLog2BlockSize, Offset); - ffI64MinusInt(aRefNr, Offset.iLow, TempI64); - ffI64MinusInt(TempI64, ffc_BlockHeaderSizeData, Offset); - if (Offset.iLow = 0) then - Result := true - else if (Offset.iLow > 0) then - if (((Offset.iLow div aRecLenPlusTrailer) * aRecLenPlusTrailer) = Offset.iLow) then - Result := true; - end; -end; -{====================================================================} - -{===Fileblock info routines==========================================} -procedure FFFreeFileInfo(var aFI : PffFileInfo); -begin - if Assigned(aFI) then begin - with aFI^ do begin - FFShStrFree(fiName); - end; - FFFreeMem(aFI, sizeof(TffFileInfo)); - end; -end; -{--------} -procedure FFChangeFileInfo(aFI : PffFileInfo; - const aNewName : TffFullFileName; - const aExt : TffExtension); -var - S : TffFullFileName; -begin - FFVerifyFileInfo(aFI, false); - with aFI^ do begin - FFShStrFree(fiName); - S := FFForceExtension(FFExpandFileName(aNewName), aExt); - fiName := FFShStrAlloc(S); - end; -end; -{--------} -function FFAllocFileInfo(const aName : TffFullFileName; - const aExt : TffExtension; - aBufMgr : TffBufferManager) : PffFileInfo; -var - S : string; -begin - FFGetMem(Result, sizeof(TffFileInfo)); - try - FillChar(Result^, sizeof(TffFileInfo), 0); - with Result^ do begin - fiVerify := VerificationValue; - fiHandle := INVALID_HANDLE_VALUE; - S := FFForceExtension(FFExpandFileName(aName), aExt); - fiName := FFShStrAlloc(S); - fiBufMgr := aBufMgr; - fiMaxBlocks := 0; - fiRecordLocks := nil; - fiExclOwner := ffc_W32NoValue; - fiAttributes := []; - fiTempStore := nil; - end; - except - FFFreeFileInfo(Result); - raise; - end;{try..except} -end; -{--------} -procedure FFVerifyFileHeaderSignature(aFI : PffFileInfo; const signature : Longint); -begin - if signature <> ffc_SigHeaderBlock then - if signature = ffc_SigHeaderBlockv1 then - {FF v1.x tables must be converted before FF2 can read them} - FFRaiseException(EffServerException, ffStrResServer, fferrFFV1File, - [aFI^.fiName^, signature]) - else - {Not a FF File header} - FFRaiseExceptionNoData(EffServerException, ffStrResServer, fferrNotAnFFFile); -end; -{--------} -procedure FFVerifyFileInfo(aFI : PffFileInfo; IsOpen : boolean); -begin - if IsOpen then {should be open} begin - if Assigned(aFI) and - (aFI^.fiVerify = VerificationValue) and - Assigned(aFI^.fiName) and - (aFI^.fiHandle <> INVALID_HANDLE_VALUE) then Exit; - FFRaiseExceptionNoData(EffServerException, ffStrResServer, fferrBadStruct); - end - else {should be closed} begin - if Assigned(aFI) and - (aFI^.fiVerify = VerificationValue) and - Assigned(aFI^.fiName) and - (aFI^.fiHandle = INVALID_HANDLE_VALUE) then Exit; - FFRaiseExceptionNoData(EffServerException, ffStrResServer, fferrBadStruct); - end -end; -{====================================================================} - - -{===File access routines=============================================} -procedure FFCloseFile(aFI : PffFileInfo); -begin - FFVerifyFileInfo(aFI, true); - if not (fffaTemporary in aFI^.fiAttributes) then - FFCloseFilePrim(aFI); - with aFI^ do begin - fiHandle := INVALID_HANDLE_VALUE; - fiBLOBrscMgr.Free; - fiBLOBrscMgr := nil; - fiRecordLocks.Free; - fiRecordLocks := nil; - end; -end; -{--------} -function FFFileIsOpen(aFI : PffFileInfo) : boolean; -begin - try - FFVerifyFileInfo(aFI, true); - Result := aFI^.fiHandle <> INVALID_HANDLE_VALUE; - except - Result := false; - end;{try..except} -end; -{--------} -procedure FFFlushFile(aFI : PffFileInfo); -begin - FFVerifyFileInfo(aFI, true); - if not (fffaTemporary in aFI^.fiAttributes) then - FFFlushFilePrim(aFI); -end; -{--------} -procedure FFForceFlushFile(aFI : PffFileInfo); -begin - FFVerifyFileInfo(aFI, true); - if not (fffaTemporary in aFI^.fiAttributes) then begin - FFCloseFilePrim(aFI); - with aFI^ do -{Begin !!.05} - try - fiHandle := FFOpenFilePrim(@fiName^[1], fiOpenMode, fiShareMode, - false, false); - except - { Re-attempt in event of failure. The failure could have occurred - due to a timing issue (i.e., OS still thinks file is open). } - Sleep(ciReopenSleep); {!!.06} - fiHandle := FFOpenFilePrim(@fiName^[1], fiOpenMode, fiShareMode, - false, false); - end; -{End !!.05} - end; -end; -{--------} -function FFGetPositionFile(aFI : PffFileInfo) : TffInt64; -begin - FFVerifyFileInfo(aFI, true); - Result := FFGetPositionFilePrim(aFI); -end; -{--------} -function FFGetFileSize(aFI : PffFileInfo) : TffInt64; -var - CurPos : TffInt64; -begin - FFVerifyFileInfo(aFI, true); - CurPos := FFGetPositionFilePrim(aFI); - Result := FFPositionFileEOFPrim(aFI); - FFPositionFilePrim(aFI, CurPos); -end; -{--------} -procedure FFOpenFile(aFI : PffFileInfo; - aOpenMode : TffOpenMode; - aShareMode : TffShareMode; - aWriteThru : boolean; - aCreateFile : boolean); -var - Attr : integer; -begin - FFVerifyFileInfo(aFI, false); - with aFI^ do begin - { Is this a temporary file? } - if fffaTemporary in fiAttributes then - { Yes. Obtain a fake file handle. } - fiHandle := THandle(aFI) - else begin - { No. Are we creating the file? } - if not aCreateFile then begin - { No. Is the existing file marked read-only? } - {$IFDEF DCC6OrLater} - {$WARN SYMBOL_PLATFORM OFF} - {$ENDIF} - Attr := FileGetAttr(fiName^); - if ((Attr and faReadOnly) <> 0) then begin - { Yes. Force the file to be opened in read-only shared mode. } - aOpenMode := omReadOnly; - aShareMode := smShared; {!!.10} - end; - end; - {$IFDEF DCC6OrLater} - {$WARN SYMBOL_PLATFORM ON} - {$ENDIF} - fiHandle := FFOpenFilePrim(@fiName^[1], aOpenMode, aShareMode, aWriteThru, aCreateFile); - end; - fiOpenMode := aOpenMode; - fiShareMode := aShareMode; - fiWriteThru := aWriteThru; - end; -end; -{--------} -procedure FFPositionFile(aFI : PffFileInfo; - const aOffset : TffInt64); - begin - FFVerifyFileInfo(aFI, true); - FFPositionFilePrim(aFI, aOffset); - end; -{--------} -function FFPositionFileEOF(aFI : PffFileInfo) : TffInt64; - begin - FFVerifyFileInfo(aFI, true); - Result := FFPositionFileEOFPrim(aFI); - end; -{--------} -function FFReadFile(aFI : PffFileInfo; - aToRead : TffWord32; - var aBuffer) : TffWord32; -begin - FFVerifyFileInfo(aFI, true); - Result := FFReadFilePrim(aFI, aToRead, aBuffer); -end; -{--------} -procedure FFReadFileExact(aFI : PffFileInfo; - const aToRead : TffWord32; - var aBuffer); -begin - FFVerifyFileInfo(aFI, true); - if FFReadFilePrim(aFI, aToRead, aBuffer) <> aToRead then begin - FFRaiseException(EffServerException, ffStrResServer, fferrReadExact, [aFI^.fiName^, aToRead]); - end; -end; -{--------} -procedure FFReadFileExactAt(aFI : PffFileInfo; - const aOffset : TffInt64; - aToRead : TffWord32; - var aBuffer); -begin - {note: this routine is not thread safe: the file handle is - available to many threads, and the file pointer is handle- - relative not thread-relative} - FFVerifyFileInfo(aFI, true); - FFPositionFilePrim(aFI, aOffset); - if FFReadFilePrim(aFI, aToRead, aBuffer) <> aToRead then begin - FFRaiseException(EffServerException, ffStrResServer, fferrReadExact, [aFI^.fiName^, aToRead]); - end; -end; -{--------} -procedure FFSetEOF(aFI : PffFileInfo; - const aOffset : TffInt64); -begin - FFVerifyFileInfo(aFI, true); - FFSetEOFPrim(aFI, aOffset); -end; -{--------} -function FFWriteFile(aFI : PffFileInfo; - aToWrite : TffWord32; - const aBuffer) : TffWord32; -begin - FFVerifyFileInfo(aFI, true); - Result := FFWriteFilePrim(aFI, aToWrite, aBuffer); -end; -{--------} -procedure FFWriteFileExact(aFI : PffFileInfo; - aToWrite : TffWord32; - const aBuffer); -begin - FFVerifyFileInfo(aFI, true); - if (FFWriteFilePrim(aFI, aToWrite, aBuffer) <> aToWrite) then begin - FFRaiseException(EffServerException, ffStrResServer, fferrWriteExact, [aFI^.fiName^, aToWrite]); - end; -end; -{--------} -procedure FFWriteFileExactAt(aFI : PffFileInfo; - const aOffset : TffInt64; - aToWrite : TffWord32; - const aBuffer); -begin - {note: this routine is not thread safe: the file handle is - available to many threads, and the file pointer is handle- - relative not thread-relative} - FFVerifyFileInfo(aFI, true); - FFPositionFilePrim(aFI, aOffset); - if (FFWriteFilePrim(aFI, aToWrite, aBuffer) <> aToWrite) then begin - FFRaiseException(EffServerException, ffStrResServer, fferrWriteExact, [aFI^.fiName^, aToWrite]); - end; -end; -{--------} -function FFCalcMaxFileSize(aFI : PffFileInfo) : TffInt64; -var - MaxFileNameLen : DWord; - FileSysFlags : Dword; - FileSysName : array[0..MAX_PATH - 1] of AnsiChar; - VolumeName : array[0..MAX_PATH - 1] of AnsiChar; - OSVersion : TOSVersionInfo; - OSNumber : Byte; - FileDrive : string; -begin - OSVersion.dwOSVersionInfoSize := SizeOf(OSVersion); - GetVersionEx(OSVersion); - if OSVersion.dwPlatformId = 1 then begin - if OSVersion.dwMinorVersion = 0 then - OSNumber := 1 {Win95} - else - OSNumber := 2; {Win98} - end else {OSVersion.dwPlatformID = 2} begin - if OSVersion.dwMajorVersion = 3 then - OSNumber := 3 {WinNT 3.51} - else if OSVersion.dwMajorVersion = 4 then - OSNumber := 4 {WinNT 4} - else - OSNumber := 5; {Win2K} - end; - FileDrive := PChar(ExtractFileDrive(aFI^.fiName^)); - FileDrive := FileDrive + '\'; - if GetVolumeInformation(PChar(FileDrive), VolumeName, Length(VolumeName), NIL, Maxfilenamelen, FileSysFlags, FileSysName, SizeOf(FileSysName)) then begin - {!! check on other possibilites for types of filesystems} - if FileSysName = 'FAT32' then begin - if OSNumber = 5 then begin - {Win2K max FAT32 partition = 8TB, but only 4GB files} - Result.iLow := ffcl_FourGigabytes; - Result.iHigh := 0; - end else begin - {Win95/98 max FAT32 partition size = (4GB - 2 bytes)} - Result.iLow := ffcl_FourGigabytes; - Result.iHigh := 0; - end; - end else if FileSysName = 'NTFS' then begin - {NTFS max file size is 2^64} - Result.iLow := ffc_W32NoValue; - Result.iHigh := ffc_W32NoValue; - end else if FileSysName = 'FAT16' then begin - if OSNumber >= 4 then begin - {NT max FAT16 partition = 4GB; Max File Size = 2GB } - Result.iLow := ffcl_TwoGigabytes; - Result.iHigh := 0; - end else begin - {Win95/98 max FAT16 partition = 2GB} - Result.iLow := ffcl_TwoGigabytes; - Result.iHigh := 0; - end; - end else if FileSysName = 'CDFS' then begin - {Can't write to a CD-ROM drive} - Result.iLow := 0; - Result.iHigh := 0; - end else if FileSysName = 'FAT' then begin - if FileDrive = 'A:\' then begin - {1.44 floppy} - Result.iLow := ffcl_MaxHDFloppy; - Result.iHigh := 0; - end else begin - {Any other FAT drive} - Result.iLow := ffcl_TwoGigabytes; - Result.iHigh := 0; - end; - end; - end else begin - Result.iLow := 0; - Result.iHigh := 0; - end; -end; -{--------} -function FFCalcMaxBLOBSegSize(aFI : PffFileInfo) : TffWord32; -begin - {calc max segment size: excluding the segment header} - Result := (((aFI^.fiBlockSize - ffc_BlockHeaderSizeBLOB - ffc_BLOBSegmentHeaderSize) - div ffc_BLOBSegmentIncrement) * ffc_BLOBSegmentIncrement); -end; -{====================================================================} - - -{===Encrypted file routines==========================================} -procedure FFReadDecryptFileExact(aFI : PffFileInfo; - aToRead : TffWord32; - var aBuffer); -begin - FFReadFileExact(aFI, aToRead, aBuffer); - {$IFDEF SecureServer} - if aFI^.fiEncrypted then - if aFI^.fiForServer then - FFDecodeBlockServer(@aBuffer, aToRead, 0) - else - FFDecodeBlock(@aBuffer, aToRead, 0); - {$ENDIF} -end; -{--------} -procedure FFReadDecryptFileExactAt(aFI : PffFileInfo; - const aOffset : TffInt64; - aToRead : TffWord32; - var aBuffer); -{$IFDEF SecureServer} {!!.01} -var - tmpOffset : TffWord32; -{$ENDIF} {!!.01} -begin - FFReadFileExactAt(aFI, aOffset, aToRead, aBuffer); - {$IFDEF SecureServer} - tmpOffset := aOffset.iLow; - if ((aOffset.iHigh <> 0) or (tmpOffset <> 0)) and aFI^.fiEncrypted then - if aFI^.fiForServer then - FFDecodeBlockServer(@aBuffer, aToRead, tmpOffset) - else - FFDecodeBlock(@aBuffer, aToRead, tmpOffset); - {$ENDIF} -end; -{--------} -procedure FFWriteEncryptFileExact(aFI : PffFileInfo; - aToWrite : TffWord32; - var aBuffer); -begin - FFVerifyFileInfo(aFI, true); - {$IFDEF SecureServer} - if (EncryptBuffer = nil) then - GetMem(EncryptBuffer, 64*1024); - Move(aBuffer, EncryptBuffer^, aToWrite); - if aFI^.fiEncrypted then - if aFI^.fiForServer then - FFCodeBlockServer(EncryptBuffer, aToWrite, 0) - else - FFCodeBlock(EncryptBuffer, aToWrite, 0); - if (FFWriteFilePrim(aFI, aToWrite, EncryptBuffer^) <> aToWrite) then begin - FFRaiseException(EffServerException, ffStrResServer, fferrWriteExact, [aFI^.fiName^, aToWrite]); - end; - {$ELSE} - if (FFWriteFilePrim(aFI, aToWrite, aBuffer) <> aToWrite) then begin - FFRaiseException(EffServerException, ffStrResServer, fferrWriteExact, [aFI^.fiName^, aToWrite]); - end; - {$ENDIF} -end; -{--------} -procedure FFWriteEncryptFileExactAt(aFI : PffFileInfo; - const aOffset : TffInt64; - aToWrite : TffWord32; - var aBuffer); -{$IFDEF SecureServer} -var - tmpOffset : TffWord32; -{$ENDIF} -begin - FFVerifyFileInfo(aFI, true); - {$IFDEF SecureServer} - tmpOffset := aOffset.iLow; - if (EncryptBuffer = nil) then - GetMem(EncryptBuffer, 64*1024); - Move(aBuffer, EncryptBuffer^, aToWrite); - if ((aOffset.iHigh <> 0) or (tmpOffset <> 0))and aFI^.fiEncrypted then - if aFI^.fiForServer then - FFCodeBlockServer(EncryptBuffer, aToWrite, tmpOffset) - else - FFCodeBlock(EncryptBuffer, aToWrite, tmpOffset); - FFPositionFilePrim(aFI, aOffset); - if (FFWriteFilePrim(aFI, aToWrite, EncryptBuffer^) <> aToWrite) then begin - FFRaiseException(EffServerException, ffStrResServer, fferrWriteExact, [aFI^.fiName^, aToWrite]); - end; - {$ELSE} - FFPositionFilePrim(aFI, aOffset); - if (FFWriteFilePrim(aFI, aToWrite, aBuffer) <> aToWrite) then begin - FFRaiseException(EffServerException, ffStrResServer, fferrWriteExact, [aFI^.fiName^, aToWrite]); - end; - {$ENDIF} -end; -{====================================================================} - - -{===Manager for list of files to flush===============================} -type - TffFlushList = class(TffObject) - protected - FList : TffVCLList; - function GetCount : integer; - public - constructor Create; - destructor Destroy; override; - function Add(FI : PffFileInfo) : boolean; - procedure Flush(aTrans : TffSrTransaction); - property Count : integer read GetCount; - end; -{--------} -constructor TffFlushList.Create; -begin - inherited Create; - FList := TffVCLList.Create; -end; -{--------} -destructor TffFlushList.Destroy; -begin - FList.Free; - inherited Destroy; -end; -{--------} -function TffFlushList.Add(FI : PffFileInfo) : boolean; -var - i : integer; -begin - { SPW - 11/7/2000 - Note that this routine is as optimized as possible. - Turns out that accessing List[i] is about 4 times faster than accessing - Items[i]. I tried replacing the use of TList with other list classes - declared in FFLLBASE but it turns out they run slower than TList, even - though the same kind of code is being executed. - Interestingly, using TList.Items is much faster than TffVCLList.Items even - though the TList.Get method is being called in either case. We haven't - been able to figure out why. Regardless, using TList.List or - TffVCLList.List gives us the fastest performance in this situation. } - Result := false; - for i := 0 to pred(Count) do - if FList.List[i] = pointer(FI) then - Exit; - FList.Add(pointer(FI)); - Result := true; -end; -{--------} -procedure TffFlushList.Flush(aTrans : TffSrTransaction); -var - CurrFile : PffFileInfo; - Inx : Integer; -begin - for Inx := 0 to Pred(FList.Count) do begin - CurrFile := PffFileInfo(FList[Inx]); - {if block 0's LSN is less than the LSN of the current transaction, - we need to change block 0's LSN to the current transaction's LSN} - with CurrFile^ do begin - if fiPageZero.LSN < aTrans.LSN then begin - fiPageZero.MakeDirty(aTrans); - fiPageZero.LSN := aTrans.LSN; - fiPageZero.Commit(False); - end; - end; - if aTrans.TransactionMode = tmFailSafe then {!!.12} - FFFlushFile(CurrFile); {!!.12} - FFForceFlushFile(CurrFile); - end; -end; -{--------} -function TffFlushList.GetCount : integer; -begin - Result := FList.Count; -end; -{====================================================================} - -{===TffbmModifiedBlock=================================================} -constructor TffbmModifiedBlock.Create(aRAMPage : TffbmRAMPage; - aPrevBlock : TffbmModifiedBlock; - aTransLevel : TffSrTransactionLevel);{!!.10} -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Assert(assigned(aRAMPage)); - inherited Create; - RAMPage := aRAMPage; - TransLevel := aTransLevel; - mbBlock := RAMPage.rpAllocBlockPrim(RAMPage.BlockSize); - mbBlockNumTmp := ffc_W32NoValue; - Prev := aPrevBlock; - AddToTransLevel; {!!.10} - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -destructor TffbmModifiedBlock.Destroy; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { The modified block may have been used to replace another block. If the - block is still available to us, free it. } - if assigned(Block) then - RAMPage.rpFreeBlock(Block, RAMPage.BlockSize); - inherited Destroy; - RemoveFromTransLevel; {!!.10} - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmModifiedBlock.Copy(aBlock : PffBlock); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Move(aBlock^, Block^, RAMPage.BlockSize); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmModifiedBlock.CopyTo(aBlock : PffBlock); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Move(Block^, aBlock^, RAMPage.BlockSize); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{Begin !!.10} -{--------} -procedure TffbmModifiedBlock.DecreaseTransLevel; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - RemoveFromTransLevel; - TransLevel := TransLevel.tlPrev; - Assert(Assigned(TransLevel)); - AddToTransLevel; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{End !!.10} -{--------} -procedure TffbmModifiedBlock.FreeBlock; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - RAMPage.rpFreeBlock(Block, RAMPage.BlockSize); - Block := nil; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffbmModifiedBlock.mbGetBlock : PffBlock; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if mbBlockNumTmp <> ffc_W32NoValue then begin - Assert(mbBlock = nil, 'Modified block still in memory'); - Assert(assigned(RAMPage.FileInfo^.fiTempStore), 'Temp storage not assigned'); - mbBlock := RAMPage.rpAllocBlockPrim(RAMPage.BlockSize); - TffBaseTempStorage(RAMPage.FileInfo^.fiTempStore).ReadBlock(mbBlockNumTmp, mbBlock); - if TransLevel.Level < SizeOf(TffWord32) * 8 then {!!.10} - FFClearBit(@RAMPage.rpBlockBits, TransLevel.Level); {!!.10} - mbBlockNumTmp := ffc_W32NoValue; - end; - Result := mbBlock; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{Begin !!.10} -{--------} -procedure TffbmModifiedBlock.AddToTransLevel; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - mbTransLevelPrev := TransLevel.tlModifiedBlocksTail; - TransLevel.tlModifiedBlocksTail := Self; - - { If there was a tail, make sure the old tail points to this page. } - if Assigned(mbTransLevelPrev) then - mbTransLevelPrev.mbTransLevelNext:=Self; - - { If this is the first page in the list, put self in the - head position. } - if not Assigned(TransLevel.tlModifiedBlocksHead) then - TransLevel.tlModifiedBlocksHead := Self; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -procedure TffbmModifiedBlock.RemoveFromTransLevel; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - { If this page is not at the tail then make sure the following page - points back to the page before this page. } - if Assigned(mbTransLevelNext) then begin - mbTransLevelNext.mbTransLevelPrev := mbTransLevelPrev; - end else begin - { This page is at the tail. The tail should now be the page before - this page. } - if TransLevel.tlModifiedBlocksTail = Self then - TransLevel.tlModifiedBlocksTail := mbTransLevelPrev; - end; - - { The page before this page should point to the page following this page. } - if Assigned(mbTransLevelPrev) then begin - mbTransLevelPrev.mbTransLevelNext := mbTransLevelNext; - end else begin - { Otherwise we are at the head of the list so make sure the head points - to the page following this page. } - if TransLevel.tlModifiedBlocksHead = Self then - TransLevel.tlModifiedBlocksHead := mbTransLevelNext; - end; - mbTransLevelNext := nil; - mbTransLevelPrev := nil; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{End !!.10} -{--------} -procedure TffbmModifiedBlock.SendToTempStore; -var - aTmpStore : TffBaseTempStorage; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Assert(mbBlockNumTmp = ffc_W32NoValue, 'Modified block already in temp store'); - aTmpStore := TffBaseTempStorage(RAMPage.FileInfo^.fiTempStore); - if not aTmpStore.Full then begin - mbBlockNumTmp := aTmpStore.WriteBlock(mbBlock); - RAMPage.rpFreeBlock(mbBlock, RAMPage.BlockSize); - mbBlock := nil; - if TransLevel.Level < SizeOf(TffWord32) * 8 then {!!.10} - FFSetBit(@RAMPage.rpBlockBits, TransLevel.Level); {!!.10} - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{====================================================================} - -{===TffbmRAMPage=====================================================} -constructor TffbmRAMPage.Create(aBufMgr : TffBufferManager; aFI : PffFileInfo; - const aBlockNumber : TffWord32); -begin - {$IFDEF RAMPageCheck} - Log('Create RAMPage %d',[aBlockNumber]); - {$ENDIF} - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - inherited Create; - FNew := True; {!!.11} - rpBlockBits := 0; - rpBlockListTail := nil; - rpBufMgr := aBufMgr; - rpFI := aFI; - rpBlockNum := aBlockNumber; - rpBlockNumTmp := ffc_W32NoValue; - BlockSize := aFI^.fiBlockSize; - rpBlockSizeEnum := FFMapBlockSize(aFI^.fiBlockSize); - FLastAccess := ffcl_INFINITE; {!!.06} - FRefCount := 0; - if fffaTemporary in aFI^.fiAttributes then - rpReuseMode := ffrmTempStore - else - rpReuseMode := ffrmUseAsIs; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -destructor TffbmRAMPage.Destroy; -var - aBlock : TffbmModifiedBlock; -begin - {$IFDEF RAMPageCheck} - Log('Free RAMPage %d',[rpBlockNum]); - {$ENDIF} - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Is the read-only block in temporary storage? } - if rpBlockNumTmp <> ffc_W32NoValue then begin - { Yes. Retrieve. } - rpAllocBlock(rpBlockSize); - TffBaseTempStorage(rpFI^.fiTempStore).ReadBlock(rpBlockNumTmp, rpBlock); - end; - - { Free the block. } - BlockSize := 0; - while assigned(rpBlockListTail) do begin - aBlock := rpBlockListTail; - rpBlockListTail := rpBlockListTail.Prev; - aBlock.Free; - end; - inherited Destroy; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.AddToFilePageList; -var - pc1: PffPageContainer; - pc2: PffPageContainer; - pc3: PffPageContainer; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Insert self into the list of RAM pages maintained by the - RAM pages themselves. Add the page to the tail of the list of RAM - pages maintained by the file structure. } - rpFilePrev := rpFI^.fiPageListTail; - rpFI^.fiPageListTail := Self; - if Assigned(rpFilePrev) then - rpFilePrev.rpFileNext:=Self; - { If this page is the first in the list then update - the file's head pointer. } - if not Assigned(rpFI^.fiPageListHead) then - rpFI^.fiPageListHead := Self; - - { If this is the header page store it in a special field for quick access } - if BlockNumber = 0 then begin - Assert(not Assigned(rpFI^.fiPageZero)); - rpFI^.fiPageZero := Self; - Exit; - end; - - { Walk through the tree to the spot where this page should be located. } - pc1 := rpFI^.fiPages[TffBlockNum(rpBlockNum)[3]]; - if not Assigned(pc1) then begin - FFGetMem(pc1, sizeOf(TffPageContainer)); - FillChar(pc1^,SizeOf(pc1^),0); - pc1.pcNext := rpFI^.fiPageContainerList; - if Assigned(pc1.pcNext) then begin - Assert(not Assigned(pc1.pcNext.pcPrev)); - pc1.pcNext.pcPrev := pc1; - end; - rpFI^.fiPageContainerList := pc1; - rpFI^.fiPages[TffBlockNum(rpBlockNum)[3]] := pc1; - end; - - pc2 := pc1.pcPages[TffBlockNum(rpBlockNum)[2]]; - if not Assigned(pc2) then begin - FFGetMem(pc2, sizeOf(TffPageContainer)); - FillChar(pc2^,SizeOf(pc2^),0); - pc2.pcNext := rpFI^.fiPageContainerList; - if Assigned(pc2.pcNext) then begin - Assert(not Assigned(pc2.pcNext.pcPrev)); - pc2.pcNext.pcPrev := pc2; - end; - rpFI^.fiPageContainerList := pc2; - pc1.pcPages[TffBlockNum(rpBlockNum)[2]] := pc2; - Inc(pc1.pcCount); - end; - - pc3 := pc2.pcPages[TffBlockNum(rpBlockNum)[1]]; - if not Assigned(pc3) then begin - FFGetMem(pc3, sizeOf(TffPageContainer)); - FillChar(pc3^,SizeOf(pc3^),0); - pc3.pcNext := rpFI^.fiPageContainerList; - if Assigned(pc3.pcNext) then begin - Assert(not Assigned(pc3.pcNext.pcPrev)); - pc3.pcNext.pcPrev := pc3; - end; - rpFI^.fiPageContainerList := pc3; - pc2.pcPages[TffBlockNum(rpBlockNum)[1]] := pc3; - Inc(pc2.pcCount); - end; - - { Add self to the leaf node. } - Assert(not Assigned(pc3.pcPages[TffBlockNum(rpBlockNum)[0]])); - pc3.pcPages[TffBlockNum(rpBlockNum)[0]] := Self; - Inc(pc3.pcCount); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.AddToRecycleList; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Assumption: rpInUsePrev already set to nil. } - rpInUseNext := rpBufMgr.bmRecycleListHead; - rpBufMgr.bmRecycleListHead := Self; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.AddToTransList(aTrans : TffSrTransaction); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Assert(assigned(aTrans)); - rpTransPrev := aTrans.trTransPageListTail; - aTrans.trTransPageListTail := Self; - if Assigned(rpTransPrev) then - rpTransPrev.rpTransNext := Self; - if not Assigned(aTrans.trTransPageListHead) then - aTrans.trTransPageListHead := Self; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.AddToUseList; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - rpInUsePrev := rpBufMgr.bmInUseListTail; - rpBufMgr.bmInUseListTail := Self; - - { If there was a tail, make sure the old tail points to this page. } - if Assigned(rpInUsePrev) then - rpInUsePrev.rpInUseNext:=Self; - - { If this is the first page in the list, put self in the - head position. } - if not Assigned(rpBufMgr.bmInUseListHead) then - rpBufMgr.bmInUseListHead := Self; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffbmRAMPage.Block(aTrans : TffSrTransaction; - var aReleaseMethod : TffReleaseMethod) : PffBlock; -{$IFDEF RAMPageCheck} -var - PStr : array[0..8] of char; -{$ENDIF} -begin -{$IFDEF RAMPageCheck} - Log('Page %d: TffbmRAMPage.Block', [rpBlockNum]); -{$ENDIF} - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { No transaction specified or this is a transaction other than the one - that has modified this block? } - if (not assigned(aTrans)) or (rpTrans <> aTrans) then begin - { Yes. Is the read-only block currently in temporary storage? } - if rpBlockNumTmp <> ffc_W32NoValue then - { Yes. Retrieve from temp storage. } - rpRetrieveFromTemp; - { Return the read-only block. } - Result := rpBlock; - {$IFDEF RAMPageCheck} - FFPointerAsHex(PStr, Result); - Log('Page %d: Acq read-only block, ref Count %d, address %s', - [rpBlockNum, FRefCount + 1, PStr]); - {$ENDIF} - end - else begin - { No. Return the most-recent modification. } - Result := rpBlockListTail.Block; - {$IFDEF RAMPageCheck} - FFPointerAsHex(PStr, Result); - Log('Page %d: Acq modified block, ref count %d, address %s', - [rpBlockNum, FRefCount + 1, PStr]); - {$ENDIF} - end; - - { Ensure the ram page is looking at the header of the retrieved block.} - rpHeader := PffBlockCommonHeader(Result); - - { Increment the reference count. } - InterlockedIncrement(FRefCount); - aReleaseMethod := Self.Release; - FLastAccess := GetTickCount; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffbmRAMPage.Commit(forceWrite : boolean) : boolean; -var - anItem : TffbmModifiedBlock; - aPrevItem : TffbmModifiedBlock; - TempI64 : TffInt64; - {$IFDEF RAMPageCheck} - PStr, PStr2 : array[0..8] of char; - {$ENDIF} -begin - {$IFDEF RAMPageCheck} - Log('Commit page %d', [rpBlockNum]); - {$ENDIF} - - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Assumption: If transaction is being committed to disk then the transaction - has obtained write access to the table content. } - - { Requirement: Must have been modified. } - Assert(rpDirty); - - { Was the read-only block written to temporary storage? } - if rpBlockNumTmp <> ffc_W32NoValue then - { Yes. Restore the read-only block so that things work out properly. } - rpRetrieveFromTemp; - - { Assume we are not committing to disk. } - Result := False; - - { Are we forcing commit to disk? } - if forceWrite then begin - { Yes. Copy the most recently modified block to the read-only block. } - rpReplaceBlock(rpBlockListTail.Block); - rpHeader^.bchLSN := rpTrans.LSN; - rpBlockListTail.Block := nil; - - { If this is not a temporary file then write to disk. } - if not (fffaTemporary in rpFI^.fiAttributes) then begin - TempI64.iLow := BlockNumber; - TempI64.iHigh := 0; - FFI64MultInt(TempI64, BlockSize, TempI64); - FFWriteEncryptFileExactAt(FileInfo, TempI64, rpBlockSize, rpBlock^); - end; - - { Get rid of all modified block versions. } - while assigned(rpBlockListTail) do begin - anItem := rpBlockListTail; - rpBlockListTail := rpBlockListTail.Prev; - anItem.Free; - end; - RemoveFromTransList(rpTrans); - MakeClean; - FNew := False; {!!.07} - Result := True; - end - else - { No. Does this block's nest level match that of the transaction's? } - if rpGetTransLevel = rpTrans.TransLevel then - { Yes. Do we have more than one modified block? } - if assigned(rpBlockListTail.Prev) then begin - { Yes. Is the previous block one nest level behind the most recent - block? } - aPrevItem := rpBlockListTail.Prev; - if aPrevItem.TransLevel = (rpBlockListTail.TransLevel.tlPrev ) then begin - { Yes. Replace the previous block with the most recent block. } - aPrevItem.FreeBlock; - aPrevItem.Block := rpBlockListTail.Block; - rpBlockListTail.Block := nil; - { Delete the most recent block. } - rpBlockListTail.Free; - rpBlockListTail := aPrevItem; - end - else - { No. The previous block is two or more levels below us. Decrement the - nest level of the most recent block. } - rpBlockListTail.DecreaseTransLevel; {!!.10} - end - else begin - { No. We have only 1 modified block. Is this block ready to be written - to disk? } - if rpBlockListTail.TransLevel.Level = 0 then begin {!!.10} - {$IFDEF RAMPageCheck} - FFPointerAsHex(PStr, rpBlock); - FFPointerAsHex(PStr2, rpBlockListTail.Block); - Log('Page %d: Commit, read-only block %s, new block %s', - [rpBlockNum, PStr, PStr2]); - {$ENDIF} - - { Yes. Replace the read-only copy with the modified copy. Note that - decrease of RAM detail occurs when rpBlock is freed in - rpReplaceBlock. } - rpReplaceBlock(rpBlockListTail.Block); - rpBlockListTail.Block := nil; - rpHeader^.bchLSN := rpTrans.LSN; - - { If this is not a temporary file then write to disk. } - if not (fffaTemporary in rpFI^.fiAttributes) then begin - TempI64.iLow := BlockNumber; - TempI64.iHigh := 0; - FFI64MultInt(TempI64, BlockSize, TempI64); - FFWriteEncryptFileExactAt(FileInfo, TempI64, rpBlockSize, rpBlock^); - end; - - { Get rid of the modified block since it is no longer needed. } - rpBlockListTail.Free; - rpBlockListTail := nil; - RemoveFromTransList(rpTrans); - MakeClean; - FNew := False; {!!.07} - Result := True; - end - else - rpBlockListTail.DecreaseTransLevel; {!!.10} - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffbmRAMPage.DirtiedForTrans(aTrans : TffSrTransaction) : Boolean; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := assigned(aTrans) and - assigned(rpBlockListTail) and - (rpTrans = aTrans) and - (rpGetTransLevel = aTrans.TransLevel); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.MakeClean; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - rpBlockListTail := nil; - rpTrans := nil; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.MakeDirty(aTrans : TffSrTransaction); -var - anItem : TffbmModifiedBlock; -begin - {$IFDEF RAMPageCheck} - Log('Page %d: MakeDirty',[rpBlockNum]); - {$ENDIF} - - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Assumption: If already marked dirty then never marked dirty by a different - transaction. } - - Assert((rpTrans = nil) or (aTrans = rpTrans)); - - { Is this block already dirty? } - if assigned(rpBlockListTail) then begin - { Yes. Does the transaction have a higher nesting level? } - if rpGetTransLevel.Level < aTrans.TransLevel.Level then begin {!!.10} - { Yes. Make a copy of the last modified block and add it to the list - of modified blocks. Assumption: There is at least one modified block - in the modified block list. } - anItem := TffbmModifiedBlock.Create(Self, rpBlockListTail, aTrans.TransLevel); - - { Copy the last modified block. } - anItem.Copy(rpBlockListTail.Block); - - { Add the block to the list. } - rpBlockListTail := anItem; - end; - end - else begin - { No. Record the transaction. } - rpTrans := aTrans; - - { Make a copy of the read-only block and add it to the modified block - list. } - rpBlockListTail := TffbmModifiedBlock.Create(Self, nil, aTrans.TransLevel); - { Is the read-only block currently in temporary storage? } - if rpBlockNumTmp <> ffc_W32NoValue then - { Yes. Retrieve from temp storage. } - rpRetrieveFromTemp; - rpBlockListTail.Copy(rpBlock); - AddToTransList(aTrans); - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.MoveToEndOfTransList; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { If this page is followed by another page, the following page - should point back to the page before this page. } - if Assigned(rpTransNext) then begin - rpTransNext.rpTransPrev := rpTransPrev; - end else - { Otherwise this page is already at the end of the list so do nothing. } - Exit; - - { If a page precedes this page then it should point to the page following - this page. } - if Assigned(rpTransPrev) then begin - rpTransPrev.rpTransNext := rpTransNext; - end else begin - { Otherwise we are at the head of the list so the head should point to - the page following this page. } - if rpTrans.trTransPageListHead = Self then - rpTrans.trTransPageListHead := rpTransNext; - end; - - { The page at the end of the list should now point to this page. } - rpTransPrev := rpTrans.trTransPageListTail; - rpTrans.trTransPageListTail := Self; - rpTransNext := nil; - if Assigned(rpTransPrev) then - rpTransPrev.rpTransNext := Self; - if not Assigned(rpTrans.trTransPageListHead) then - rpTrans.trTransPageListHead := Self; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.MoveToEndOfUseList; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} -{Begin !!.01} - { Already at end of list? } - if rpInUseNext = nil then - { Yes. Exit. } - Exit; - - { Point the following page to the page before this page. } - rpInUseNext.rpInUsePrev := rpInUsePrev; - - { If a page precedes this page then it should point to the page following - this page. } - if Assigned(rpInUsePrev) then begin - rpInUsePrev.rpInUseNext := rpInUseNext; - end else begin - { Otherwise we are at the head of the list so the head should point to - the page following this page. } - if rpBufMgr.bmInUseListHead = Self then - rpBufMgr.bmInUseListHead := rpInUseNext; - end; - - { The page at the end of the list should now point to this page. } - rpInUsePrev := rpBufMgr.bmInUseListTail; - rpBufMgr.bmInUseListTail := Self; - rpInUseNext := nil; - if Assigned(rpInUsePrev) then - rpInUsePrev.rpInUseNext := Self; - if rpBufMgr.bmInUseListHead = nil then - rpBufMgr.bmInUseListHead := Self; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.MoveToRecycleList; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - RemoveFromUseList; - AddToRecycleList; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.Release(var aBlock: PffBlock); -{$IFDEF RAMPageCheck} -var - Pstr : array[0..8] of char; -{$ENDIF} -begin -{ Assumption: This method may be accessed by multiple threads at the same time. - This is allowed hence no checks for ThreadEnter and ThreadExist when - the FF_DEBUG_THREADS define is enabled. The routine is threadsafe since - it uses the InterlockedDecrement function. } - - {$IFDEF RAMPageCheck} - FFPointerAsHex(PStr, aBlock); - Log('Page %d: Release, refCount %d, address %s', - [rpBlockNum, FRefCount - 1, PStr]); - {$ENDIF} -// {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - - { The first check in this assertion should be fairly obvious -- - something is outta whack if we're releasing a block that isn't - referenced by anything. The remaining checks ensure that we have - not lost the proper association between a block and its assigned - release method. The first of these is a check for read-only blocks - and the second is for modified blocks. - - NOTE: In some situations, a block may be marked dirty after it was - previously marked dirty. The check against rpBlockListTail.Prev is to - catch the case where a block that is being released is no longer the - tail block of the modified list. } - Assert((FRefCount > 0) and - ((aBlock = rpBlock) or - (assigned(rpBlockListTail) and {!!.10} - ((aBlock = rpBlockListTail.Block) or {!!.10} - (assigned(rpBlockListTail.Prev) and {!!.10} - (aBlock = rpBlockListTail.Prev.Block)))))); {!!.10} - aBlock := nil; - InterlockedDecrement(FRefCount); -// {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffbmRAMPage.Removable(var RemoveMode : TffbmPageReuseMode) : boolean; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - RemoveMode := rpReuseMode; - Result := False; - - { Can't be removed if this block is dirty, it is block zero, or it is - actively used by one or more threads. } - if assigned(rpBlockListTail) or - (rpBlockNum = 0) or - ((FRefCount > 0) and ((GetTickCount - FLastAccess) < ffcl_PageLife)) then - Exit; - - { The page may be re-used if it cannot be sent to temporary storage. } - Result := (rpReuseMode <> ffrmTempStore); - - if Result then - Exit - else begin - { Otherwise, it can be sent to temp storage. It can be re-used if the page - is not already in temp storage and temp storage contains room for - the page. } - Result := (not rpGetInTempStore); - if Result then - if assigned(rpBlockListTail) then - Result := Result and - (TffBaseTempStorage(rpFI^.fiTempStore).HasSpaceFor - (2 + rpBlockListTail.TransLevel.Level)) {!!.10} - else - Result := Result and (not TffBaseTempStorage(rpFI^.fiTempStore).Full); - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.RemoveFromFilePageList; -var - pc1: PffPageContainer; - pc2: PffPageContainer; - pc3: PffPageContainer; -begin - {$IFDEF RAMPageCheck} - Log('Page %d: RemoveFromFilePageList',[rpBlockNum]); - {$ENDIF} - - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - - { Remove self from the list of RAM pages maintained by the RAM pages. - Remove self from the list of RAM pages maintained by the file - structure. } - if Assigned(rpFileNext) then begin - rpFileNext.rpFilePrev := rpFilePrev; - end else begin - if rpFI^.fiPageListTail = Self then - rpFI^.fiPageListTail := rpFilePrev; - end; - if Assigned(rpFilePrev) then begin - rpFilePrev.rpFileNext := rpFileNext; - end else begin - if rpFI^.fiPageListHead = Self then - rpFI^.fiPageListHead := rpFileNext; - end; - rpFileNext := nil; - rpFilePrev := nil; - - { If this is the header page it was stored it in a special field for quick access } - if BlockNumber = 0 then begin - Assert(rpFI^.fiPageZero = Self); - rpFI^.fiPageZero := nil; - Exit; - end; - - { Remove ourselves from the file's RAM pages structure. } - pc1 := rpFI^.fiPages[TffBlockNum(rpBlockNum)[3]]; - Assert(Assigned(pc1)); - if not Assigned(pc1) then - Exit; - - pc2 := pc1.pcPages[TffBlockNum(rpBlockNum)[2]]; - Assert(Assigned(pc2)); - if not Assigned(pc2) then - Exit; - - pc3 := pc2.pcPages[TffBlockNum(rpBlockNum)[1]]; - Assert(Assigned(pc3)); - if not Assigned(pc3) then - Exit; - - Assert(pc3.pcPages[TffBlockNum(rpBlockNum)[0]] = Self); - pc3.pcPages[TffBlockNum(rpBlockNum)[0]] := nil; - Dec(pc3.pcCount); - - { remove the the page container if no longer used } - if pc3.pcCount = 0 then begin - { is this the first page container in the list? } - if not Assigned(pc3.pcPrev) then begin - { yes... this page container must be the head of the list} - Assert(rpFI^.fiPageContainerList = pc3); - rpFI^.fiPageContainerList := pc3.pcNext; - end else begin - { no... the previous page container must reference this page container} - Assert(pc3.pcPrev.pcNext = pc3); - pc3.pcPrev.pcNext := pc3.pcNext; - end; - { is there a page container after this one? } - if Assigned(pc3.pcNext) then begin - { yes... the next page container must reference this page container} - Assert(pc3.pcNext.pcPrev = pc3); - pc3.pcNext.pcPrev := pc3.pcPrev; - end; - - { free the page container } - FFFreeMem(pc3, sizeOf(TffPageContainer)); - - { remove this page container from its parent } - pc2.pcPages[TffBlockNum(rpBlockNum)[1]] := nil; - Dec(pc2.pcCount); - - { remove the the page container if no longer used } - if pc2.pcCount = 0 then begin - { is this the first page container in the list? } - if not Assigned(pc2.pcPrev) then begin - { yes... this page container must be the head of the list} - Assert(rpFI^.fiPageContainerList = pc2); - rpFI^.fiPageContainerList := pc2.pcNext; - end else begin - { no... the previous page container must reference this page container} - Assert(pc2.pcPrev.pcNext = pc2); - pc2.pcPrev.pcNext := pc2.pcNext; - end; - { is there a page container after this one? } - if Assigned(pc2.pcNext) then begin - { yes... the next page container must reference this page container} - Assert(pc2.pcNext.pcPrev = pc2); - pc2.pcNext.pcPrev := pc2.pcPrev; - end; - - { free the page container } - FFFreeMem(pc2, sizeOf(TffPageContainer)); - - { remove this page container from its parent } - pc1.pcPages[TffBlockNum(rpBlockNum)[2]] := nil; - Dec(pc1.pcCount); - - { remove the the page container if no longer used } - if pc1.pcCount = 0 then begin - { is this the first page container in the list? } - if not Assigned(pc1.pcPrev) then begin - { yes... this page container must be the head of the list} - Assert(rpFI^.fiPageContainerList = pc1); - rpFI^.fiPageContainerList := pc1.pcNext; - end else begin - { no... the previous page container must reference this page container} - Assert(pc1.pcPrev.pcNext = pc1); - pc1.pcPrev.pcNext := pc1.pcNext; - end; - { is there a page container after this one? } - if Assigned(pc1.pcNext) then begin - { yes... the next page container must reference this page container} - Assert(pc1.pcNext.pcPrev = pc1); - pc1.pcNext.pcPrev := pc1.pcPrev; - end; - - { free the page container } - FFFreeMem(pc1, sizeOf(TffPageContainer)); - - { remove this page container from its parent } - rpFI^.fiPages[TffBlockNum(rpBlockNum)[3]] := nil; - end; - end; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.RemoveFromRecycleList; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - rpBufMgr.bmRecycleListHead := rpInUseNext; - rpInUseNext := nil; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.RemoveFromTransList(aTrans : TffSrTransaction); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if Assigned(rpTransNext) then begin - rpTransNext.rpTransPrev := rpTransPrev; - end else begin - if aTrans.trTransPageListTail = Self then - aTrans.trTransPageListTail := rpTransPrev; - end; - if Assigned(rpTransPrev) then begin - rpTransPrev.rpTransNext := rpTransNext; - end else begin - if aTrans.trTransPageListHead = Self then - aTrans.trTransPageListHead := rpTransNext; - end; - rpTransNext := nil; - rpTransPrev := nil; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.RemoveFromUseList; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { If this page is not at the tail then make sure the following page - points back to the page before this page. } - if Assigned(rpInUseNext) then begin - rpInUseNext.rpInUsePrev := rpInUsePrev; - end else begin - { This page is at the tail. The tail should now be the page before - this page. } - if rpBufMgr.bmInUseListTail = Self then - rpBufMgr.bmInUseListTail := rpInUsePrev; - end; - - { The page before this page should point to the page following this page. } - if Assigned(rpInUsePrev) then begin - rpInUsePrev.rpInUseNext := rpInUseNext; - end else begin - { Otherwise we are at the head of the list so make sure the head points - to the page following this page. } - if rpBufMgr.bmInUseListHead = Self then - rpBufMgr.bmInUseListHead := rpInUseNext; - end; - rpInUseNext := nil; - rpInUsePrev := nil; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffbmRAMPage.ReadOnlyBlock : PffBlock; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := rpBlock; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffbmRAMPage.Reusable(var ReuseMode : TffbmPageReuseMode) : boolean; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - ReuseMode := rpReuseMode; - Result := False; - - { Can't be removed if this is block zero or it is actively used by one or - more threads. } - if (rpBlockNum = 0) or - ((FRefCount > 0) and ((GetTickCount - FLastAccess) < ffcl_PageLife)) then - Exit; - - { Can this page be sent to temporary storage? } - if (rpReuseMode = ffrmTempStore) then begin - { Yes. We can re-use the page if it is not already in temporary storage - & temporary storage contains room for the page & its blocks. } - Result := (not rpGetInTempStore); - if Result then - if assigned(rpBlockListTail) then - Result := Result and - (TffBaseTempStorage(rpFI^.fiTempStore).HasSpaceFor - (2 + rpBlockListTail.TransLevel.Level)) {!!.10} - else - Result := Result and (not TffBaseTempStorage(rpFI^.fiTempStore).Full); - end - else - { No. Page may be re-used if it is clean. } - Result := (rpBlockListTail = nil); - - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.Rollback; -var - aBlock : TffbmModifiedBlock; -begin - {$IFDEF RAMPageCheck} - Log('Page %d: Rollback',[rpBlockNum]); - {$ENDIF} - - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Requirement: Must have been dirtied. } - Assert(assigned(rpBlockListTail)); - - { Does this block's nest level match that of the transaction's? } - if rpGetTransLevel = rpTrans.TransLevel then begin - { Yes. Is this nest level zero? } - if rpTrans.TransLevel.Level = 0 then begin {!!.10} - { Yes. Assume this is the only block in the modified block list. - Get rid of the modified block. } - rpBlockListTail.Free; - rpBlockListTail := nil; -{Begin !!.07} - if FNew then begin - RemoveFromFilePageList; - RemoveFromTransList(rpTrans); - RemoveFromUseList; - AddToRecycleList; - FileInfo := nil; - end - else - RemoveFromTransList(rpTrans); - rpTrans := nil; -{End !!.07} - end - else begin - { No. Get rid of the last modified block. } - aBlock := rpBlockListTail.Prev; - rpBlockListTail.Free; - rpBlockListTail := aBlock; - if not assigned(rpBlockListTail) then - RemoveFromTransList(rpTrans); - end; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.rpAllocBlock(aBlockSize : Longint); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - rpBlockSize := aBlockSize; - if (rpBlockSize <> 0) then begin - rpBlock := rpAllocBlockPrim(rpBlockSize); - rpHeader := PffBlockCommonHeader(rpBlock); - end - else begin - rpBlock := nil; - rpHeader := nil; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffbmRAMPage.rpAllocBlockPrim(aBlockSize : Longint) : PffBlock; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := nil; - if (aBlockSize <> 0) then begin - case aBlockSize of - 4 * 1024 : begin - if (Pool4K = nil) then - Pool4K := TffMemoryPool.Create(4*1024, 1); - Result := Pool4K.Alloc; - end; - 8 * 1024 : begin - if (Pool8K = nil) then - Pool8K := TffMemoryPool.Create(8*1024, 1); - Result := Pool8K.Alloc; - end; - 16* 1024 : begin - if (Pool16K = nil) then - Pool16K := TffMemoryPool.Create(16*1024, 1); - Result := Pool16K.Alloc; - end; - 32* 1024 : begin - if (Pool32K = nil) then - Pool32K := TffMemoryPool.Create(32*1024, 1); - Result := Pool32K.Alloc; - end; - 64* 1024 : begin - if (Pool64K = nil) then - Pool64K := TffMemoryPool.Create(64*1024, 1); - Result := Pool64K.Alloc; - end; - else - GetMem(Result, aBlockSize); - end;{case} - rpBufMgr.bmIncreaseRAMDetail(aBlockSize); - FillChar(Result^, aBlockSize, 'F'); - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffbmRAMPage.rpDirty : boolean; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := assigned(rpBlockListTail); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.rpFreeBlock(aBlock : PffBlock; aBlockSize : Longint); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if (rpBlockSize <> 0) and assigned(aBlock) then begin - case aBlockSize of - 4 * 1024 : Pool4K.Dispose(aBlock); - 8 * 1024 : Pool8K.Dispose(aBlock); - 16* 1024 : Pool16K.Dispose(aBlock); - 32* 1024 : Pool32K.Dispose(aBlock); - 64* 1024 : Pool64K.Dispose(aBlock); - else - FreeMem(aBlock, aBlockSize); - end;{case} - rpBufMgr.bmDecreaseRAMDetail(aBlockSize); - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffbmRAMPage.rpGetInTempStore : boolean; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := (rpBlockNumTmp <> ffc_W32NoValue) or - (rpBlockBits > 0); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffbmRAMPage.rpGetLSN : TffWord32; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Has this page been dirtied by a transaction? } - if assigned(rpTrans) then - { Yes. Return the transaction's LSN. } - Result := rpTrans.LSN - else - { No. Return the LSN of the read-only block. } - Result := rpHeader^.bchLSN; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffbmRAMPage.rpGetTransLevel : TffSrTransactionLevel; {!!.10} -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if assigned(rpBlockListTail) then - Result := rpBlockListTail.TransLevel - else - Result := nil; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.rpRelease(aBlock: PffBlock); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Assert((FRefCount > 0) and - ((aBlock = rpBlock) or (aBlock = rpBlockListTail.Block))); - InterlockedDecrement(FRefCount); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.rpReplaceBlock(aNewBlock : PffBlock); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - rpFreeBlock(rpBlock, rpBlockSize); - rpBlock := aNewBlock; - rpHeader := PffBlockCommonHeader(rpBlock); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.rpRetrieveFromTemp; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - rpAllocBlock(rpBlockSize); - TffBaseTempStorage(rpFI^.fiTempStore).ReadBlock(rpBlockNumTmp, rpBlock); - rpBlockNumTmp := ffc_W32NoValue; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.rpSetBlockSize(aBlockSize : Longint); -var - aBlock : TffbmModifiedBlock; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Is the read-only page in temporary storage? } - if rpBlockNumTmp <> ffc_W32NoValue then begin - TffBaseTempStorage(rpFI^.fiTempStore).ReleaseBlock(rpBlockNumTmp); {!!.01} - rpBlockNumTmp := ffc_W32NoValue; - end; - - { Are there any modified blocks? If so, free them. This ensures they - are removed from temporary storage. } - while assigned(rpBlockListTail) do begin - aBlock := rpBlockListTail; - rpBlockListTail := rpBlockListTail.Prev; - aBlock.Free; - end; - - if aBlockSize <> rpBlockSize then begin - rpFreeBlock(rpBlock, rpBlockSize); - rpAllocBlock(aBlockSize); - end - else - FillChar(rpBlock^, rpBlockSize, 'F'); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.rpSetLSN(const aLSN : TffWord32); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - rpHeader^.bchLSN := aLSN; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.SendToTempStore; -var - aBlock : TffbmModifiedBlock; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Requirement: Must be clean & must not already be in temporary - storage. } - Assert(assigned(rpBlock)); - - { Send the read-only block to temp storage. } - rpBlockNumTmp := TffBaseTempStorage(rpFI^.fiTempStore).WriteBlock(rpBlock); - rpFreeBlock(rpBlock, rpBlockSize); - rpBlock := nil; - - { Send all modified blocks to temp storage. } - aBlock := rpBlockListTail; - while assigned(aBlock) do begin - aBlock.SendToTempStore; - aBlock := rpBlockListTail.Prev; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffbmRAMPage.rpSetFI(FI : PffFileInfo); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - FNew := False; {!!.07} - if (FI <> rpFI) then begin - { If the file is being set to nil, we need to clear it: it's - about to be recycled. } - if (FI = nil) then begin - BlockSize := 0; - rpFI := nil; - rpBlockNum := ffc_W32NoValue; - rpTrans := nil; - end - { If the file is being set to a real fileinfo record, set as - much data as we can. } - else begin - BlockSize := FI^.fiBlockSize; - rpFI := FI; - rpBlockNum := ffc_W32NoValue; - rpTrans := nil; - if fffaTemporary in FI^.fiAttributes then - rpReuseMode := ffrmTempStore - else - rpReuseMode := ffrmUseAsIs; - end; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{====================================================================} - - -{===TffSrTransactionLevel============================================} -constructor TffSrTransactionLevel.Create(aTrans: TffSrTransaction); -begin - inherited Create; - tlTransaction := aTrans; - tlPrev := tlTransaction.trTransLevelListTail; - tlTransaction.trTransLevelListTail := Self; - if Assigned(tlPrev) then - tlLevel := tlPrev.tlLevel + 1 - else - tlLevel := 0; -end; -{--------} -destructor TffSrTransactionLevel.Destroy; -begin - tlTransaction.trTransLevelListTail := tlPrev; - Assert(not Assigned(tlModifiedBlocksHead)); - inherited; -end; -{====================================================================} - - -{===TffSrTransaction===============================================} -constructor TffSrTransaction.Create(const aDatabaseID : TffDatabaseID; - const aImplicit, readOnly : boolean); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - inherited Create; - FDatabaseID := aDatabaseID; - FImplicit := aImplicit; - FJnlFile := nil; - FNewSpace := 0; {!!.11} - FTransLevel := 0; - FReadOnly := readOnly; - FSignature := ffc_SigTransaction; - FTransMode := tmNormal; - FLockContainer := nil; - StartNested; {!!.10} - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -destructor TffSrTransaction.Destroy; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if assigned(FLockContainer) then - FLockContainer.Free; - EndNested; - inherited Destroy; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffSrTransaction.AdjustLSN(const Adjustment : TffWord32) : TffWord32; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Assumption: Transaction list & buffer manager data structures have - been write-locked. } - FLSN := FLSN - Adjustment; - Result := FLSN; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{Begin !!.10} -{--------} -procedure TffSrTransaction.StartNested; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - TffSrTransactionLevel.Create(Self); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -procedure TffSrTransaction.EndNested; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - Assert(Assigned(trTransLevelListTail)); - trTransLevelListTail.Free; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{End !!.10} -{--------} -function TffSrTransaction.trGetNested : boolean; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := (TransLevel.Level > 0); {!!.10} - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{Begin !!.10} -{--------} -function TffSrTransaction.trGetTransLevel : TffSrTransactionLevel; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - Assert(Assigned(trTransLevelListTail)); - Result := trTransLevelListTail; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{End !!.10} -{--------} -function TffSrTransaction.trGetTransactionID : TffTransID; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - result := TffTransID(Self); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{====================================================================} - - - -{===TffBufferManager=================================================} -constructor TffBufferManager.Create(const ConfigDir : TffPath; - const TempStoreSizeInMB : integer); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - inherited Create; -// bmCommitLSN := High(TffWord32); {Deleted !!.10} - bmConfigDir := ConfigDir; - bmInUseListHead := nil; - bmInUseListTail := nil; - bmPortal := TffPadlock.Create; {!!.02} - bmMaxRAM := 10; - bmMaxRAMDetail.iLow := bmMaxRAM; - bmMaxRAMDetail.iHigh := 0; - ffI64MultInt(bmMaxRAMDetail, ffcl_1MB, bmMaxRAMDetail); - ffInitI64(bmRAMDetail); - bmRAMUsed := 0; - bmTempStore := ffcTempStorageClass.Create(bmConfigDir, - TempStoreSizeInMB * ffcl_1MB, - ffcl_64k); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{Begin !!.07} -{--------} -procedure TffBufferManager.bmClearRecycleList; -var - Temp : TffbmRAMPage; -begin - while Assigned(bmRecycleListHead) do begin - Temp := bmRecycleListHead; - Temp.RemoveFromRecycleList; - Temp.Free; - end; -end; -{End !!.07} -{--------} -destructor TffBufferManager.Destroy; -//var {Deleted !!.07} -// Temp : TffbmRAMPage; {Deleted !!.07} -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - bmPortal.Lock; {!!.02} - try - { Free the pages from the recycle list. } - bmClearRecycleList; {!!.07} - - { All files must be closed before freeing the buffer manager. - If bmInUseListHead is assigned, files are still open. } - Assert(not Assigned(bmInUseListHead)); - finally - bmPortal.Unlock; {!!.02} - bmPortal.Free; {!!.02} - end; - bmTempStore.Free; - inherited Destroy; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffBufferManager.AddBlock(aFI : PffFileInfo; - aTI : PffTransInfo; - const aBlockNumber : TffWord32; - var aReleaseMethod : TffReleaseMethod) : PffBlock; -var - Temp : TffbmRAMPage; -begin - bmPortal.Lock; {!!.02} - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Is the block already in memory? } - Temp := bmSearch(aFI, aBlockNumber); - - { If not in memory then bring it into memory. } - if not Assigned(Temp) then begin - Temp := bmGetNewRAMPage(aFI, aBlockNumber); - { If we are in a transaction then make this block part of the - transaction. } - if assigned(aTI^.tirTrans) then begin - Temp.MakeDirty(aTI^.tirTrans); - end; - end - else - { The block is in memory. Move it to the end of the InUse list. } - Temp.MoveToEndOfUseList; - - { Does this file need a reference to temporary storage? } - if (fffaTemporary in aFI^.fiAttributes) and - (aFI^.fiTempStore = nil) then - aFI^.fiTempStore := bmTempStore; - - { Return a modifiable copy of the block. } - Result := Temp.Block(aTI^.tirTrans, aReleaseMethod); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} - finally - bmPortal.Unlock; {!!.02} - end;{try..finally} -end; -{--------} -function TffBufferManager.AddFile(aFI : PffFileInfo; - aTI : PffTransInfo; - const aMarkHeaderDirty : boolean; - var aReleaseMethod : TffReleaseMethod) : PffBlock; -var - Temp : TffbmRAMPage; - Trans : TffSrTransaction; -begin - Result := nil; {!!.13} - bmPortal.Lock; {!!.02} - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Temp := bmSearch(aFI, 0); - if not Assigned(Temp) then begin - Temp := bmGetNewRAMPage(aFI, 0); - if not (fffaTemporary in aFI^.fiAttributes) then -{Begin !!.13} - try - bmReadBlock(aFI, ffc_W32NoValue, Temp); - except - Temp.RemoveFromUseList; - Temp.RemoveFromFilePageList; - Temp.Free; - raise; - end; -{End !!.13} - end - else begin - if (aFI^.fiBlockSize = 0) then begin - aFI^.fiBlockSize := Temp.BlockSize; - aFI^.fiBlockSizeK := Temp.BlockSize div 1024; {!!.11} - aFI^.fiLog2BlockSize := FFCalcLog2BlockSize(Temp.BlockSize); - end; - end; - if aMarkHeaderDirty and (not Temp.DirtiedForTrans(aTI^.tirTrans)) then begin - Trans := aTI^.tirTrans; - Temp.MakeDirty(Trans); - end; - - { Does this file need a reference to temporary storage? } - if (fffaTemporary in aFI^.fiAttributes) and - (aFI^.fiTempStore = nil) then - aFI^.fiTempStore := bmTempStore; - - { Return a modifiable copy of the block. } - Result := Temp.Block(aTI^.tirTrans, aReleaseMethod); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} - finally - bmPortal.Unlock; {!!.02} - end;{try..finally} -end; -{--------} -procedure TffBufferManager.BeginWrite; -begin - bmPortal.Lock; {!!.02} -end; -{--------} -procedure TffBufferManager.bmCommitPrim(aTrans : TffSrTransaction); -var - aPage, NextPage : TffbmRAMPage; - CanShove : boolean; - FirstShove : TffbmRAMPage; - FlushList : TffFlushList; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Is the transaction nested? } {!!.10} - if aTrans.TransLevel.Level = 0 then begin {!!.10} - { No. Commit to disk } {!!.10} - CanShove := true; - FirstShove := nil; - - { Create list of files that will be needed to be flushed. } - FlushList := TffFlushList.Create; - -{Begin !!.11} - { Verify there is enough free disk space for the new blocks. } - aPage := aTrans.trTransPageListHead; - if (aPage <> nil) and - (aTrans.FNewSpace > 0) and - (aTrans.FNewSpace > - FFGetDiskFreeSpace(ExtractFileDir(aPage.rpFI^.fiName^))) then - FFRaiseExceptionNoData(EffServerException, - ffStrResServer, - fferrDiskFull); -{End !!.11} - - { Loop through the pages. } - while assigned(aPage) do begin - NextPage := aPage.rpTransNext; - { If we have a next page and this is page 0, 1, or 2, shove it to the - end of the transaction page list. We do this to reduce chances of - corruption if disk is full. Any new data blocks are written before - the header block. If a new data block cannot be written then - we avoid putting a bad record count in block 0. } - if assigned(NextPage) and - CanShove and - (aPage.BlockNumber < 3) then begin - if aPage = FirstShove then begin - CanShove := false; - NextPage := aPage; - end - else begin - aPage.MoveToEndOfTransList; - if FirstShove = nil then - FirstShove := aPage; - end; - end - else if aPage.Commit(false) and - (not (fffaTemporary in aPage.FileInfo^.fiAttributes)) then - FlushList.Add(aPage.FileInfo); - aPage := NextPage; - end; - - { Now flush the files to which we have written. } - FlushList.Flush(aTrans); - FlushList.Free; -{Begin !!.10} - end else begin - {Yes. Only commit the blocks belonging to the current transaction level } - while Assigned(aTrans.TransLevel.tlModifiedBlocksHead) do - aTrans.TransLevel.tlModifiedBlocksHead.RAMPage.Commit(False); - end; -{End !!.10} - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffBufferManager.bmFailSafeCommit(aTrans : TffSrTransaction); -var - aPage : TffbmRAMPage; - FileName : TffFullFileName; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Get the journal file name for the final deletion. } - FileName := aTrans.JournalFile^.fiName^; - - { Is this the commit of a nested transaction? } - if aTrans.TransLevel.Level = 0 then begin {!!.10} - { No. Write out all before- and after-images to journal file. - We need before-images so that the fail-safe transaction can - be completely rolled back in the event of power failure. We - need after-images so that the fail-safe transaction can be - re-applied. } - aPage := aTrans.trTransPageListHead; - while assigned(aPage) do begin - if (not (fffaTemporary in aPage.FileInfo^.fiAttributes)) then begin - bmJournalRAMPage(aTrans, aPage, true); - bmJournalRAMPage(aTrans, aPage, false); - end; - aPage := aPage.rpTransNext; - end; - { Mark the journal file as complete and close it. } - bmWriteCompleteJnlHeader(aTrans.JournalFile); - end; - - { Commit the pages. } - bmCommitPrim(aTrans); - - { If we get this far all dirty data was force-flushed to disk, so - delete the journal file (it's no longer needed)} - if aTrans.TransLevel.Level = 0 then {!!.10} - try - FFDeleteFile(FileName); - except - {do nothing} - end;{try..except} - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffBufferManager.bmFileRAMPageCount(aFI : PffFileInfo) : Longint; -var - RAMPage : TffbmRAMPage; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := 0; - RAMPage := aFI^.fiPageListHead; - while assigned(RAMPage) do begin - inc(Result); - RAMPage := RAMPage.rpFileNext; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffBufferManager.bmGetNewRAMPage(aFI : PffFileInfo; - aBlockNumber : TffWord32) : TffbmRAMPage; -var - ReuseMode : TffbmPageReuseMode; - Temp : TffbmRAMPage; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - {$IFDEF RAMPageCheck} - Log('Entering TffBuffMan.bmGetNewRamPage', []); - {$ENDIF} - Result := nil; - - { Check the Recycle list for an available RAM page. } - if Assigned(bmRecycleListHead) then begin - Result := bmRecycleListHead; - Result.RemoveFromRecycleList; - Result.FileInfo := aFI; - Result.BlockNumber := aBlockNumber; - end; - - { If we don't have a recycled page and if adding the new block would push - us over our maximum RAM limit then try to find a page in the UseList that is - relatively old and not locked. } - if (not Assigned(Result)) and bmOverRAMLimit(aFI^.fiBlockSize) then begin - {$IFDEF RAMPageCheck} - Log('Looking for reusable RAMPage', []); - {$ENDIF} - Temp := bmInUseListHead; - while Assigned(Temp) do begin - if Temp.Reusable(ReuseMode) then begin - Result := Temp; - Break; - end; - Temp := Temp.rpInUseNext; - end; - { Did we find a reusable page? } - if Assigned(Result) then - { Yes. Can we use it as is? } - if ReuseMode = ffrmUseAsIs then begin - { Yes. Update its properties. } - Result.RemoveFromFilePageList; - Result.FileInfo := aFI; - Result.BlockNumber := aBlockNumber; - Result.RemoveFromUseList; - end else begin - {$IFDEF RAMPageCheck} - Log('Sending reusable page to temp storage.', []); - {$ENDIF} - { No. Send it to temporary storage. } - Result.SendToTempStore; - Result := nil; - end; - end; - - { If didn't have a page to recycle, haven't reached the maximum number of RAM - pages, or didn't have a re-usable page then create a new RAM page. } - if (not Assigned(Result)) then begin - Result := TffbmRAMPage.Create(Self, aFI, aBlockNumber); - {$IFDEF RAMPageCheck} - Log('Creating a new RAMPage. RAM used: %d', [bmRAMDetail.ilow]); - {$ENDIF} - end; - { Add it to the buffer manager's InUse list and the file's - page list. } - Result.AddToUseList; - Result.AddToFilePageList; - {$IFDEF RAMPageCheck} - Log('Leaving TffBuffMan.bmGetNewRamPage', []); - {$ENDIF} - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffBufferManager.bmGetRAMPage(const anIndex : Longint) : TffbmRAMPage; -var - Count : Longint; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Count := 0; - Result := bmInUseListHead; - while assigned(Result) and (Count < anIndex) do begin - inc(Count); - Result := Result.rpInUseNext; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffBufferManager.bmGetRecycledCount : Longint; -var - RAMPage : TffbmRAMPage; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := 0; - RAMPage := bmRecycleListHead; - while assigned(RAMPage) do begin - inc(Result); - RAMPage := RAMPage.rpInUseNext; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffBufferManager.bmGetTempStoreSize : integer; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := bmTempStore.Size div ffcl_1MB; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffBufferManager.bmRAMPageCount : Longint; -var - RAMPage : TffbmRAMPage; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := 0; - RAMPage := bmInUseListHead; - while assigned(RAMPage) do begin - inc(Result); - RAMPage := RAMPage.rpInUseNext; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffBufferManager.bmSearch(aFI : PffFileInfo; aBlockNumber : TffWord32) : TffbmRAMPage; -var - pc1 : PffPageContainer; - pc2 : PffPageContainer; - pc3 : PffPageContainer; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { is this the header page? } - if aBlockNumber = 0 then begin - { yes... it was stored in a special field for faster access } - Result := aFI^.fiPageZero; - Exit; - end; - - pc1 := aFI^.fiPages[TffBlockNum(aBlockNumber)[3]]; - if not Assigned(pc1) then begin - Result := nil; - Exit; - end; - pc2 := pc1.pcPages[TffBlockNum(aBlockNumber)[2]]; - if not Assigned(pc2) then begin - Result := nil; - Exit; - end; - pc3 := pc2.pcPages[TffBlockNum(aBlockNumber)[1]]; - if not Assigned(pc3) then begin - Result := nil; - Exit; - end; - Result := pc3.pcPages[TffBlockNum(aBlockNumber)[0]]; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffBufferManager.bmSetTempStoreSize(aSizeInMB : integer); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - bmTempStore.Free; - bmTempStore := ffcTempStorageClass.Create(bmConfigDir, - aSizeInMB * ffcl_1MB, ffcl_64k); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffBufferManager.CommitFileChanges(aFI : PffFileInfo; - aTrans : TffSrTransaction); -var - aPage : TffbmRAMPage; - NextPage : TffbmRAMPage; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if assigned(aTrans) then begin - aPage := aTrans.trTransPageListHead; - while assigned(aPage) do begin - if aPage.FileInfo = aFI then begin - NextPage := aPage.rpTransNext; - aPage.Commit(True); - aPage := NextPage; - end else - aPage := aPage.rpTransNext; - end; { while } - if not (fffaTemporary in aFI^.fiAttributes) then - FFForceFlushFile(aFI); - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffBufferManager.CommitTransaction(aTrans : TffSrTransaction); -begin - bmPortal.Lock; {!!.02} - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if (aTrans <> nil) then begin - if (aTrans.TransactionMode = tmNormal) then - bmCommitPrim(aTrans) - else {TransactionMode = tmFailSafe} - bmFailSafeCommit(aTrans); - bmRemoveExcessPages; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} - finally - bmPortal.Unlock; {!!.02} - end; -end; -{--------} -procedure TffBufferManager.CommitTransactionSubset(aTrans : TffSrTransaction); -begin - bmPortal.Lock; {!!.02} - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if (aTrans <> nil) then - bmCommitPrim(aTrans); - { We typically commit a subset during a long-running operation such as - pack, reindex, or restructure. Remove the pages associated with this - transaction. The advantage to this is that we don't squeeze other cursors - out of the RAM cache. The disadvantage is that we may free up pages that - we need as we continue the operation. } - bmRemoveCommittedPages(aTrans); - bmRemoveExcessPages; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} - finally - bmPortal.Unlock; {!!.02} - end; -end; -{--------} -procedure TffBufferManager.DirtyBlock(aFI : PffFileInfo; - const aBlockNumber : TffWord32; - aTI : PffTransInfo; - var aModifiableBlock : PffBlock); -var - aModBlockClone : PffBlock; - aRelMethod : TffReleaseMethod; - Temp : TffbmRAMPage; - Trans : TffSrTransaction; -begin - bmPortal.Lock; {!!.02} - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Is the block in memory? } - Temp := bmSearch(aFI, aBlockNumber); - { If it is in memory then make it part of the file's transaction. } - if Assigned(Temp) then begin - if not Temp.DirtiedForTrans(aTI^.tirTrans) then begin - Trans := aTI^.tirTrans; - Temp.MakeDirty(Trans); - end; - aModifiableBlock := Temp.Block(aTI^.tirTrans, aRelMethod); - aModBlockClone := aModifiableBlock; - aRelMethod(aModBlockClone); - { Move the page to the end of the InUse list. } - Temp.MoveToEndOfUseList; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} - finally - bmPortal.Unlock; {!!.02} - end;{try..finally} -end; -{--------} -procedure TffBufferManager.EndWrite; -begin - bmPortal.Unlock; {!!.02} -end; -{--------} -procedure TffBufferManager.FlushPools(const blockSizes : TffBlockSizes); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - - { Time to do a general flush? } {!!.07} - if blockSizes = [] then begin {!!.01}{!!.07} - { Free up the recycled list. } {!!.07} - bmClearRecycleList; {!!.07} - FFFlushMemPools; {!!.01} - end; {!!.07} - - if (ffbs4k in blockSizes) and assigned(Pool4k) then - Pool4k.RemoveUnusedBlocks; - - if (ffbs8k in blockSizes) and assigned(Pool8k) then - Pool8k.RemoveUnusedBlocks; - - if (ffbs16k in blockSizes) and assigned(Pool16k) then - Pool16k.RemoveUnusedBlocks; - - if (ffbs32k in blockSizes) and assigned(Pool32k) then - Pool32k.RemoveUnusedBlocks; - - if (ffbs64k in blockSizes) and assigned(Pool64k) then - Pool64k.RemoveUnusedBlocks; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffBufferManager.GetBlock(aFI : PffFileInfo; - const aBlockNumber : TffWord32; - aTI : PffTransInfo; - const aMarkDirty : boolean; - var aReleaseMethod : TffReleaseMethod) : PffBlock; -var - Temp : TffbmRAMPage; -begin -{Begin!!.02} -// if aMarkDirty then - bmPortal.Lock; -// else -// bmPortal.BeginRead; -{End !!.02} - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Get the RAM page. } - Temp := bmGetBlock(aFI, aBlockNumber); - - { If we are to mark it dirty and it has not been marked as part of the - file's transaction then make it part of the transaction. } - if aMarkDirty and (not Temp.DirtiedForTrans(aTI^.tirTrans)) then - Temp.MakeDirty(aTI^.tirTrans); - - Result := Temp.Block(aTI^.tirTrans, aReleaseMethod); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} - finally -{Begin !!.02} -// if aMarkDirty then - bmPortal.Unlock; -// else -// bmPortal.EndRead; -{End !!.02} - end;{try..finally} -end; -{--------} -function TffBufferManager.GetRAMPage(aFI : PffFileInfo; - const aBlockNumber : TffWord32) : TffbmRAMPage; -begin -{Begin !!.05} - bmPortal.Lock; - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Get the RAM page. } - Result := bmGetBlock(aFI, aBlockNumber); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} - finally - bmPortal.Unlock; - end; -{End !!.05} -end; -{Begin !!.06} -{--------} -function TffBufferManager.GetRAMPageLSN(aRAMPage : TffbmRAMPage) : TffWord32; -begin - bmPortal.Lock; - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - Result := aRAMPage.LSN; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} - finally - bmPortal.Unlock; - end; -end; -{--------} -function TffBufferManager.GetRAMPageLSN2(aFI : PffFileInfo; - const aBlockNumber : TffWord32) : TffWord32; -begin - bmPortal.Lock; - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - { Get the RAM page. } - Result := bmGetBlock(aFI, aBlockNumber).LSN; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} - finally - bmPortal.Unlock; - end; -end; -{End !!.06} -{--------} -function TffBufferManager.bmGetBlock(aFI : PffFileInfo; - aBlockNumber : TffWord32) : TffbmRAMPage; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - - if (fffaTemporary in aFI^.fiAttributes) and (aFI^.fiTempStore = nil) then - aFI^.fiTempStore := bmTempStore; - - { Is the block already in memory? } - Result := bmSearch(aFI, aBlockNumber); - { If it is not in memory then bring it into memory. } - if Result = nil then begin -// if not Assigned(Result) then begin - Result := bmGetNewRAMPage(aFI, aBlockNumber); - if not (fffaTemporary in aFI^.fiAttributes) then -{Begin !!.13} - try - bmReadBlock(aFI, aBlockNumber, Result); - except - Result.RemoveFromUseList; - Result.RemoveFromFilePageList; - Result.Free; - raise; - end; -{End !!.13} - end else - { It is in memory. Move it to the end of the InUse list. } - Result.MoveToEndOfUseList; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffBufferManager.GetRAM : integer; -begin - Result := bmRAMUsed; -end; -{--------} -procedure TffBufferManager.HandleLSNrollover; -var - RAMPage : TffbmRAMPage; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - RAMPage := bmInUseListHead; - while assigned(RAMPage) do begin - if not RAMPage.Dirty then - RAMPage.LSN := 1; - RAMPage := RAMPage.rpInUseNext; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffBufferManager.bmDecreaseRAMDetail(const numberBytes : Longint); -var - tmpI64 : TffInt64; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - ffI64MinusInt(bmRAMDetail, numberBytes, bmRAMDetail); - ffI64DivInt(bmRAMDetail, ffcl_1MB, tmpI64); - bmRAMUsed := ffI64ToInt(tmpI64); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffBufferManager.bmIncreaseRAMDetail(const numberBytes : Longint); -var - tmpI64 : TffInt64; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - ffI64AddInt(bmRAMDetail, numberBytes, bmRAMDetail); - ffI64DivInt(bmRAMDetail, ffcl_1MB, tmpI64); - bmRAMUsed := ffI64ToInt(tmpI64); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffBufferManager.bmJournalRAMPage(aTrans : TffSrTransaction; - aRAMPage : TffbmRAMPage; - aBeforeImage : boolean); -var - aBlock : PffBlock; - aReleaseMethod : TffReleaseMethod; - RecHdr : TffJournalFileRecordHeader; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - FillChar(RecHdr, sizeof(RecHdr), 0); - with RecHdr, aRAMPage do begin - jfrhSignature := ffc_SigJnlRecHeader; - jfrhBlockNumber := BlockNumber; - jfrhBlockSize := BlockSize; - jfrhBeforeImg := Longint(ord(aBeforeImage)); - StrCopy(jfrhFileName, @FileInfo^.fiName^[1]); - FFPositionFileEOF(aTrans.JournalFile); - FFWriteFileExact(aTrans.JournalFile, sizeof(RecHdr), RecHdr); - if aBeforeImage then - FFWriteFileExact(aTrans.JournalFile, BlockSize, ReadOnlyBlock^) - else begin - aBlock := Block(aTrans, aReleaseMethod); - try - FFWriteFileExact(aTrans.JournalFile, BlockSize, aBlock^); - finally - aReleaseMethod(aBlock); - end; - end; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{Begin !!.05} -{--------} -procedure TffBufferManager.Lock; -begin - bmPortal.Lock; -end; -{End !!.05} -{--------} -function TffBufferManager.bmOverRAMLimit(sizeOfNewBlock : Longint) : boolean; -var - tmpI64 : TffInt64; -begin - {$IFDEF RAMPageCheck} - Log('OverRamLimit?',[]); - Log(' NewBlockSize : %d',[SizeOfNewBlock]); - Log(' MaxRam : %d',[bmMaxRAMDetail.ilow]); - Log(' Current RAM : %d',[bmRAMDetail.ilow]); - {$ENDIF} - - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Are we already at the limit? } - Result := (FFCmpI64(bmRAMDetail, bmMaxRAMDetail) = 0); - { If not then see if this would push us over the limit? } - if not Result then begin - ffI64AddInt(bmRamDetail, sizeOfNewBlock, tmpI64); - Result := (FFCmpI64(tmpI64, bmMaxRAMDetail) > 0); - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffBufferManager.bmReadBlock(aFI : PffFileInfo; - aBlockNumber : TffWord32; - aRAMPage : TffbmRAMPage); -var - aBlock : PffBlock; - aReleaseMethod : TffReleaseMethod; - Header : TffBlockHeaderFile; - MaxBlocks : TffInt64; - TempI64 : TffInt64; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Note: aBlockNumber = ffc_W32NoValue forces verification of the header, and - for a header record, we need to calculate the block size first; header - records are never encrypted. } - if (aBlockNumber = ffc_W32NoValue) then begin - TempI64.iLow := 0; - TempI64.iHigh := 0; - FFReadFileExactAt(aFI, TempI64, sizeof(Header), Header); - ffVerifyFileHeaderSignature(aFI, Header.bhfSignature); - with Header do - if (bhfSignature <> ffc_SigHeaderBlock) or - (bhfNextBlock <> ffc_W32NoValue) or - (bhfThisBlock <> 0) or - (not FFVerifyBlockSize(bhfBlockSize)) then - FFRaiseException(EffServerException, ffStrResServer, fferrNotAnFFFile, - [aFI^.fiName^]); - {$IFNDEF SecureServer} - if (Header.bhfEncrypted = 1) then - FFRaiseException(EffServerException, ffStrResServer, fferrEncrypted, - [aFI^.fiName^]); - {$ENDIF} - aFI^.fiBlockSize := Header.bhfBlockSize; - aFI^.fiBlockSizeK := Header.bhfBlockSize div 1024; {!!.11} - aFI^.fiLog2BlockSize := Header.bhfLog2BlockSize; - aFI^.fiUsedBlocks := Header.bhfUsedBlocks; - aFI^.fiEncrypted := (Header.bhfEncrypted = 1); - aFI^.fiRecordLength := Header.bhfRecordLength; - aFI^.fiRecLenPlusTrailer := Header.bhfRecLenPlusTrailer; - aFI^.fiFFVersion := Header.bhfFFVersion; -{Begin !!.11} - { Verify the table was not created with a newer version of FF. For example, - it is okay for a 2_11 server to read a 2_06 table but it is *not* okay - for a 2_10 server to read a 2_11 table. } - if aFI^.fiFFVersion > ffVersionNumber then - FFRaiseException(EffServerException, ffStrResServer, fferrTableVersion, - [aFI^.fiName^, aFI^.fiFFVersion / 10000.0, - FFVersionNumber / 10000.0]); -{End !!.11} - - { Calculate the maximum number of blocks the file may contain. - D3 max num blocks is 2^31; 2^32 for D4 and 5. } - ffI64DivInt(FFCalcMaxFileSize(aFI), TffWord32(aFI^.fiBlockSize), MaxBlocks); - if (ffCmpDW(MaxBlocks.iLow,ffcl_MaxBlocks)) > 0 then - aFI^.fiMaxBlocks := ffcl_MaxBlocks - else - aFI^.fiMaxBlocks := MaxBlocks.iLow; - - aFI^.fiMaxSegSize := FFCalcMaxBLOBSegSize(aFI); - aRAMPage.BlockSize := Header.bhfBlockSize; - aBlockNumber := 0; - end; - { Read the requested block in its entirety. } - with aRAMPage do begin - TempI64.iLow := aBlockNumber; - TempI64.iHigh := 0; - ffI64MultInt(TempI64, BlockSize, TempI64); - { Read the file into the read-only slot. } - aBlock := Block(nil, aReleaseMethod); - try - FFReadDecryptFileExactAt(aFI, TempI64, BlockSize, aBlock^); - finally - aReleaseMethod(aBlock); - end; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffBufferManager.bmRemoveCommittedPages(const aTran : TffSrTransaction); -var - BlockSizes : TffBlockSizes; - LSN : TffWord32; - NextPage : TffbmRAMPage; - RAMPage : TffbmRAMPage; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - - { Remove pages marked by the transaction. } - BlockSizes := []; - LSN := aTran.LSN; - RAMPage := aTran.trTransPageListHead; - while assigned(RAMPage) do begin - NextPage := RAMPage.rpTransNext; - { Is this page part of the specified transaction? } - if (RAMPage.LSN = LSN) and (not RAMPage.Dirty) then begin - { Yes. Get rid of the page. } - Include(BlockSizes, RAMPage.rpBlockSizeEnum); - RAMPage.RemoveFromTransList(aTran); - RAMPage.RemoveFromFilePageList; - RAMPage.RemoveFromUseList; - RAMPage.Free; - end; - { Move to the next page. } - RAMPage := NextPage; - end; - - { Tell the memory pools to free up their excess blocks. } - FlushPools(blockSizes); - - { Flush the semaphore & mutex pools. } -// FFMutexPool.Flush; - FFSemPool.Flush; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffBufferManager.bmRemoveExcessPages; -var - BlockSizes : TffBlockSizes; - ExcessRAM : integer; - NextPage : TffbmRAMPage; - RAMPage : TffbmRAMPage; - RemoveMode : TffbmPageReuseMode; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - - { Goal: Make sure the RAM allocated to pages is at or below the MaxRAM - property. } - BlockSizes := []; - - { Are we using more RAM than allowed? } - ExcessRAM := bmRAMUsed - bmMaxRAM; - if (ExcessRAM > 0) then begin - { Yes. See if we can remove any from the recycle list. } - while assigned(bmRecycleListHead) and (ExcessRAM > 0) do begin - RAMPage := bmRecycleListHead; - RAMPage.RemoveFromRecycleList; - RAMPage.Free; - ExcessRAM := bmRAMUsed - bmMaxRAM; - end; - - { Are we still over the limit? } - if (ExcessRAM > 0) then begin - { Yes. See if some InUse pages can be removed. } - RAMPage := bmInUseListHead; - while assigned(RAMPage) and (ExcessRAM > 0) do begin - NextPage := RAMPage.rpInUseNext; - { Can this page be removed? } - if RAMPage.Removable(RemoveMode) then begin - { Yes. Is it to be sent to temporary storage? } - if RemoveMode = ffrmTempStore then - { Yes. Do so. } - RAMPage.SendToTempStore - else begin - { No. We can just free it. } - Include(BlockSizes, RAMPage.rpBlockSizeEnum); - RAMPage.RemoveFromFilePageList; - RAMPage.RemoveFromUseList; - RAMPage.Free; - end; - ExcessRAM := bmRAMUsed - bmMaxRAM; - end; - - { Move to the next page. } - RAMPage := NextPage; - end; - end; - - { We have eliminated some RAM pages. Tell the memory pools to free up - their excess blocks. } - FlushPools(BlockSizes); - - { Flush the semaphore & mutex pools. } -// FFMutexPool.Flush; - FFSemPool.Flush; - - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffBufferManager.RemoveFile(aFI : PffFileInfo); -var - BlockSizes : TffBlockSizes; - Temp : TffbmRAMPage; - Temp2 : TffbmRAMPage; - t1, t2 : PffPageContainer; -begin - BlockSizes := []; - bmPortal.Lock; {!!.02} - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Move all RAM pages from the file's page list to the buffer manager's - Recycle list. } - Temp := aFI^.fiPageListHead; - while Assigned(Temp) do - begin - Temp2 := Temp.rpFileNext; - Temp.rpFilePrev := nil; - Temp.rpFileNext := nil; - bmRemovePageFromTransaction(Temp); - Temp.FileInfo := nil; - Temp.MoveToRecycleList; - Temp := Temp2; - end; - aFI^.fiPageListHead := nil; - aFI^.fiPageListTail:= nil; - - { Free all of the file's page containers. } - t1 := aFI^.fiPageContainerList; - while Assigned(t1) do - begin - t2 := t1^.pcNext; - FFFreeMem(t1, sizeOf(TffPageContainer)); - t1 := t2; - end; - - FillChar(aFI^.fiPages, SizeOf(aFI^.fiPages), 0); - - Include(BlockSizes, FFMapBlockSize(aFI^.fiBlockSize)); - FlushPools(BlockSizes); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} - finally - bmPortal.Unlock; {!!.02} - end;{try..finally} -end; -{--------} -procedure TffBufferManager.RollbackTransaction(aTrans : TffSrTransaction); -var - aPage, NextPage : TffbmRAMPage; - FileName : TffFullFileName; -begin - bmPortal.Lock; {!!.02} - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if (aTrans = nil) then {Moved !!.11} - Exit; {Moved !!.11} - { Is the transaction nested? } {!!.10} - if aTrans.TransLevel.Level = 0 then begin {!!.10} - { No. Rollback all pages in the transaction. } {!!.10} - - { For fail safe mode, close and delete the journal file. } - if //(not aTrans.Nested) and {Deleted !!.10} - (aTrans.TransactionMode = tmFailSafe) then begin - try - FileName := aTrans.JournalFile^.fiName^; - FFCloseFile(aTrans.JournalFile); - except - {do nothing} - end;{try..except} - try - FFDeleteFile(FileName); - except - {do nothing} - end;{try..except} - end; - - { Rollback all pages involved in the transaction. } - aPage := aTrans.trTransPageListHead; - while Assigned(aPage) do begin - NextPage := aPage.rpTransNext; - aPage.Rollback; - aPage := NextPage; - end; - bmRemoveExcessPages; -{Begin !!.10} - end else begin - {Yes. Only commit the blocks belonging to the current transaction level } - while Assigned(aTrans.TransLevel.tlModifiedBlocksHead) do - aTrans.TransLevel.tlModifiedBlocksHead.RAMPage.Rollback; - end; -{End !!.10} - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} - finally - bmPortal.Unlock; {!!.02} - end;{try..finally} -end; -{--------} -procedure TffBufferManager.RollbackTransactionSubset(aTrans : TffSrTransaction); -var - aPage, NextPage : TffbmRAMPage; -begin - bmPortal.Lock; {!!.02} - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if (aTrans <> nil) then begin - aPage := aTrans.trTransPageListHead; - while assigned(aPage) do begin - NextPage := aPage.rpTransNext; - aPage.Rollback; - aPage := NextPage; - end; - bmRemoveExcessPages; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} - finally - bmPortal.Unlock; {!!.02} - end; -end; -{--------} -procedure TffBufferManager.SetMaxRAM(aNumber : Longint); -begin - bmPortal.Lock; {!!.02} - try - if (aNumber <> MaxRAM) then begin - bmMaxRAM := aNumber; - ffIntToI64(aNumber, bmMaxRAMDetail); - ffI64MultInt(bmMaxRAMDetail, ffcl_1MB, bmMaxRAMDetail); - end; - finally - bmPortal.Unlock; {!!.02} - end; -end; -{--------} -procedure TffBufferManager.StartTransaction(aTrans : TffSrTransaction; - const aFailSafe : Boolean; - const aFileName : TffFullFileName); -var - JnlFile : PffFileInfo; -begin - bmPortal.Lock; {!!.02} - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - try - if aFailSafe then begin - aTrans.JournalFile := FFAllocFileInfo(aFileName, ffc_ExtForTrans, nil); - FFOpenFile(aTrans.JournalFile, omReadWrite, smExclusive, True, True); - bmWriteIncompleteJnlHeader(aTrans.JournalFile); - aTrans.TransactionMode := tmFailSafe; - end - else - aTrans.TransactionMode := tmNormal; - except - if (aTrans.JournalFile <> nil) then begin - JnlFile := aTrans.JournalFile; - if FFFileIsOpen(JnlFile) then - FFCloseFile(JnlFile); - FFFreeFileInfo(JnlFile); - end; - raise; - end;{try..except} - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} - finally - bmPortal.Unlock; {!!.02} - end;{try..finally} -end; -{Begin !!.05} -{--------} -procedure TffBufferManager.Unlock; -begin - bmPortal.Unlock; -end; -{End !!.05} -{--------} -procedure TffBufferManager.UnlockBlock(aFI : PffFileInfo; - aBlockNumber : TffWord32); -var - Temp : TffbmRAMPage; -begin - bmPortal.Lock; {!!.02} - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Temp := bmSearch(aFI, aBlockNumber); - if Assigned(Temp) then begin - Temp.RemoveFromFilePageList; - bmRemovePageFromTransaction(Temp); - Temp.FileInfo := nil; - Temp.MoveToRecycleList; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} - finally - bmPortal.Unlock; {!!.02} - end;{try..finally} -end; -{--------} -procedure TffBufferManager.bmWriteCompleteJnlHeader(aJnlFile : PffFileInfo); -var - Hdr : TffJournalFileHeader; - TempI64 : TffInt64; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Hdr.jfhSignature := ffc_SigJnlHeader; - Hdr.jfhState := 1; - TempI64.iLow := 0; - TempI64.iHigh := 0; - FFWriteFileExactAt(aJnlFile, TempI64, sizeof(Hdr), Hdr); - FFCloseFile(aJnlFile); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffBufferManager.bmWriteIncompleteJnlHeader(aJnlFile : PffFileInfo); -var - Hdr : TffJournalFileHeader; - TempI64 : TffInt64; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Hdr.jfhSignature := ffc_SigJnlHeader; - Hdr.jfhState := 0; - TempI64.iLow := 0; - TempI64.iHigh := 0; - FFWriteFileExactAt(aJnlFile, TempI64, sizeof(Hdr), Hdr); - FFFlushFile(aJnlFile); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffBufferManager.bmRemovePageFromTransaction(aPage: TffbmRAMPage); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - with aPage do begin - if not rpDirty then - Exit; - if not Assigned(rpTrans) then - Exit; - aPage.RemoveFromTransList(rpTrans); - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{=====================================================================} - -{Begin !!.11} -{===TffBaseBLOBResourceMgr============================================} -class function TffBaseBLOBResourceMgr.GetMgr(aFI : PffFileInfo) : TffBaseBLOBResourceMgr; -begin - if aFI.fiFFVersion <= ffVersion2_10 then - Result := Tff210BLOBResourceMgr.Create - else - Result := TffBLOBResourceMgr.Create; -end; -{--------} -constructor TffBaseBLOBResourceMgr.Create; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - inherited Create; - brmPadlock := TffPadlock.Create; - brmSegMgrLoaded := false; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -destructor TffBaseBLOBResourceMgr.Destroy; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - brmPadLock.Free; - brmSegmentMgr.Free; - inherited Destroy; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -procedure TffBaseBLOBResourceMgr.Commit; -begin - if brmSegmentMgr <> nil then - brmSegmentMgr.Commit; -end; -{--------} -procedure TffBaseBLOBResourceMgr.DeleteSegment(aFI : PffFileInfo; - aTI : PffTransInfo; - const aSegOffset : TffInt64); -begin - {segment manager must be loaded before deleting a segment} - if not brmSegMgrLoaded then - brmLoadSegMgr(aFI, aTI); - brmPadLock.Lock; - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - brmSegmentMgr.DeleteSegment(aFI, aTI, aSegOffset); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} - finally - brmPadLock.Unlock; - end; -end; -{--------} -procedure TffBaseBLOBResourceMgr.brmLoadSegMgr(aFI : PffFileInfo; - aTI : PffTransInfo); -begin - brmPadlock.Lock; - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - if not brmSegMgrLoaded then begin - brmSegmentMgr := brmGetSegMgrClass.Create(aFI, aTI); - brmSegMgrLoaded := True; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} - finally - brmPadlock.Unlock; - end; -end; -{--------} -procedure TffBaseBLOBResourceMgr.ListFreeSpace(aFI : PffFileInfo; - aTI : PffTransInfo; - const aInMemory : Boolean; - aStream : TStream); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - if not brmSegMgrLoaded then - brmLoadSegMgr(aFI, aTI); - brmSegmentMgr.ListFreeSpace(aFI, aTI, aInMemory, aStream); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -procedure TffBaseBLOBResourceMgr.Rollback; -begin - if brmSegmentMgr <> nil then - brmSegmentMgr.Rollback; -end; -{=====================================================================} - -{===TffBLOBResourceMgr================================================} -function TffBLOBResourceMgr.brmGetSegMgrClass : TffBLOBSegmentMgrClass; -begin - Result := TffBLOBSegmentMgr; -end; -{--------} -function TffBLOBResourceMgr.NewSegment(aFI : PffFileInfo; - aTI : PffTransInfo; - var aSizeNeeded : TffWord32; - const aMinSizeAllowed : TffWord32) - : TffInt64; -var - NewSize, - NewMinSize : Longint; -begin - { Segment manager must be loaded before getting a new segment. } - if not brmSegMgrLoaded then - brmLoadSegMgr(aFI, aTI); - brmPadLock.Lock; - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - {calculate new size based on size of BLOB increment} - Assert(aSizeNeeded <= aFI^.fiMaxSegSize, - 'Requesting too large segment.'); - NewSize := (((aSizeNeeded + pred(ffc_BLOBSegmentIncrement)) div - ffc_BLOBSegmentIncrement) * ffc_BLOBSegmentIncrement); - NewMinSize := (((aMinSizeAllowed + pred(ffc_BLOBSegmentIncrement)) div - ffc_BLOBSegmentIncrement) * ffc_BLOBSegmentIncrement); - if NewMinSize > NewSize then - NewMinSize := NewSize; - {look for segment in deleted chain 1st} - Result := brmSegmentMgr.GetRecycledSeg(aFI, aTI, NewSize, NewMinSize); - {if aSize segment not available, create a new segment} - if Result.iLow = ffc_W32NoValue then - Result := brmSegmentMgr.GetNewSeg(aFI, aTI, NewSize); - { Set the final size allocated in the aSizeNeeded parameter. } - aSizeNeeded := NewSize; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} - finally - brmPadLock.Unlock; - end; -end; -{=====================================================================} - -{===Tff210BLOBResourceMgr=============================================} -function Tff210BLOBResourceMgr.brmGetSegMgrClass : TffBLOBSegmentMgrClass; -begin - Result := Tff210BLOBSegmentMgr; -end; -{--------} -function Tff210BLOBResourceMgr.NewSegment(aFI : PffFileInfo; - aTI : PffTransInfo; - var aSizeNeeded : TffWord32; - const aMinSizeAllowed : TffWord32) - : TffInt64; -var - NewSize, - MinSize : Longint; -begin - { Segment manager must be loaded before getting a new segment. } - if not brmSegMgrLoaded then - brmLoadSegMgr(aFI, aTI); - brmPadLock.Lock; - try - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - { Calculate new size based on size of BLOB increment. } - NewSize := (((aSizeNeeded + pred(ffc_BLOBSegmentIncrement)) div - ffc_BLOBSegmentIncrement) * ffc_BLOBSegmentIncrement); - MinSize := NewSize; - { First, look for segment in deleted chain . } - Result := brmSegmentMgr.GetRecycledSeg(aFI, aTI, NewSize, MinSize); - { If aSize segment not available, create a new segment. } - if Result.iLow = ffc_W32NoValue then - Result := brmSegmentMgr.GetNewSeg(aFI, aTI, NewSize); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} - finally - brmPadLock.Unlock; - end; -end; -{=====================================================================} - -{===TffBaseBLOBSegmentMgr=============================================} -constructor TffBaseBLOBSegmentMgr.Create(aFI : PffFileInfo; - aTI : PffTransInfo); -var - aFHRelMethod : TffReleaseMethod; - aSegRelMethod : TffReleaseMethod; - FileHeader : PffBlockHeaderFile; - SegmentOfs : TffInt64; - SegmentBlk : PffBlock; - SegmentPtr : PffBLOBSegmentHeaderDel; - OffsetInBlock : TffWord32; - ListItem : TffBLOBSegListItem; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - inherited Create; - { Fill bsmDelChain with segments. } - bsmDelChain := TffList.Create; - bsmTranListHead := nil; - bsmUseTranList := not (fffaBLOBChainSafe in aFI.fiAttributes); - { We need the file header to get the deleted segment head. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, - aTI, - 0, - ffc_ReadOnly, - aFHRelMethod)); - try - if (FileHeader^.bhfDelBLOBHead.iLow <> ffc_W32NoValue) then begin - SegmentOfs := FileHeader^.bhfDelBLOBHead; - bsmDelChain.Sorted := True; - - while (SegmentOfs.iLow <> ffc_W32NoValue) do begin - SegmentBlk := ReadVfyBlobBlock(aFI, - aTI, - ffc_ReadOnly, - SegmentOfs, - OffsetInBlock, - aSegRelMethod); - try - SegmentPtr := @SegmentBlk^[OffsetInBlock]; - - { Create a list item for the segment and insert it to the list. } - ListItem := TffBLOBSegListItem.Create; - ListItem.Offset := SegmentOfs; - ListItem.Size := SegmentPtr^.bshSegmentLen; - bsmDelChain.Insert(ListItem); - { Get the next segment. } - SegmentOfs := SegmentPtr^.bshNextSegment; - finally - aSegRelMethod(SegmentBlk); - end; - end; - end; {if} - finally - aFHRelMethod(PffBlock(FileHeader)); - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -destructor TffBaseBLOBSegmentMgr.Destroy; -var - aSegItem, aTmpSegItem : TffBLOBSegListItem; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - bsmDelChain.Free; - { Clear out any remaining items from the transaction list. As of this writing, - SQL cursors will build up a bunch of stuff within this list & not commit - it. } - aSegItem := bsmTranListHead; - while aSegItem <> nil do begin - aTmpSegItem := aSegItem.FTranNextItem; - aSegItem.Free; - aSegItem := aTmpSegItem; - end; - inherited Destroy; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -procedure TffBaseBLOBSegmentMgr.bsmAddToTranList(aSegItem : TffBLOBSegListItem; - anAction : TffBLOBSegAction); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - { Items are always added at the head of the list. } - aSegItem.FTranNextItem := bsmTranListHead; - bsmTranListHead := aSegItem; - aSegItem.FPendingAction := anAction; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -procedure TffBaseBLOBSegmentMgr.bsmRemoveFromTranList(aSegItem : TffBlobSegListItem); -var - PrevItem : TffBLOBSegListItem; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - - PrevItem := bsmTranListHead; - - if (PrevItem = aSegItem) then - bsmTranListHead := aSegItem.FTranNextItem - else begin - { Find the previous segment. } - while (PrevItem.FTranNextItem <> aSegItem) do - PrevItem := PrevItem.FTranNextItem; - - { Remove the item from the list. } - PrevItem.FTranNextItem := aSegItem.FTranNextItem; - end; - - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -procedure TffBaseBLOBSegmentMgr.Commit; -var - CurItem, TmpItem : TffBLOBSegListItem; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - CurItem := bsmTranListHead; - while CurItem <> nil do begin - TmpItem := CurItem; - CurItem := TmpItem.FTranNextItem; - case TmpItem.FPendingAction of - bsaAddToList : - begin - { Reset item's transaction info & add it to the in-memory - deleted chain. } - TmpItem.FPendingAction := bsaNone; - TmpItem.FTranNextItem := nil; - bsmDelChain.Insert(TmpItem); - end; - bsaDeleteFromList : - { Item is already removed from list so free the item. } - TmpItem.Free; - end; { case } - end; - bsmTranListHead := nil; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -procedure TffBaseBLOBSegmentMgr.DeleteSegment(aFI : PffFileInfo; - aTI : PffTransInfo; - const aSegOffset : TffInt64); -var - aBLOBRelMethod : TffReleaseMethod; - aFHRelMethod : TffReleaseMethod; - FileHeader : PffBlockHeaderFile; - OffsetInBlock : TffWord32; - BLOBBlock : PffBlock; -// BLOBHeader : PffBlockHeaderBLOB; {Deleted !!.13} - DelSegPtr : PffBLOBSegmentHeader; - BufferItem : TffBLOBSegListItem; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - - { Get the file header. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, - aTI, - 0, - ffc_MarkDirty, - aFHRelMethod)); - - try - - { Grab the segment to be deleted. } - BlOBBlock := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - aSegOffset, - OffsetInBlock, - aBLOBRelMethod); - DelSegPtr := @BLOBBlock^[OffsetInBlock]; - - { Zero out the segment & mark it as deleted. } - FillChar(BLOBBlock^[OffsetInBlock + sizeof(TffBLOBSegmentHeaderDel)], - DelSegPtr^.bshSegmentLen - sizeof(TffBLOBSegmentHeaderDel), - 0); {!!.13} - PffBLOBSegmentHeaderDel(DelSegPtr)^.bshSignature := ffc_SigBLOBSegDeleted; - - { Create our list item representing the deleted segment. } - BufferItem := TffBLOBSegListItem.Create; - BufferItem.Offset := aSegOffset; - BufferItem.Size := DelSegPtr^.bshSegmentLen; - - { Assumption: Deleted list is already in memory and contains the entire - list of deleted BLOB segments. } - { Is there anything in the deleted list? } - if (FileHeader^.bhfDelBLOBTail.iLow <> ffc_W32NoValue) then begin - - { Update the segments in the file. } - bsmAddToDeletedSegChain(aFI, - aTI, - FileHeader, - BufferItem, - PffBLOBSegmentHeaderDel(DelSegPtr)); - - end else begin - { Nothing deleted yet. Make this the first item in the chain. } - with FileHeader^ do begin - bhfDelBLOBHead := aSegOffset; - bhfDelBLOBTail := aSegOffset; - PffBLOBSegmentHeaderDel(DelSegPtr)^.bshPrevSegment.iLow := ffc_W32NoValue; - PffBLOBSegmentHeaderDel(DelSegPtr)^.bshPrevSegment.iHigh := ffc_W32NoValue; - PffBLOBSegmentHeaderDel(DelSegPtr)^.bshNextSegment.iLow := ffc_W32NoValue; - PffBLOBSegmentHeaderDel(DelSegPtr)^.bshNextSegment.iHigh := ffc_W32NoValue; - end; - end; - - { Add the item to the list. } - if bsmUseTranList then - bsmAddToTranList(BufferItem, bsaAddToList) - else - bsmDelChain.Insert(BufferItem); - - { Decrement the used segment count in the BLOB block. } -// BLOBHeader := PffBlockHeaderBLOB(BLOBBlock); {Deleted !!.13} -// BLOBHeader^.bhbAssignedSegCount := BLOBHeader^.bhbAssignedSegCount - 1; {Deleted !!.13} - finally - aBLOBRelMethod(BLOBBlock); - aFHRelMethod(PffBlock(FileHeader)); - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -procedure TffBaseBLOBSegmentMgr.bsmAddToDeletedSegChain(aFI : PffFileInfo; - aTI : PffTransInfo; - aFileHeader : PffBlockHeaderFile; - aDelSeg : TffBLOBSegListItem; - aSegment : PffBLOBSegmentHeaderDel); -var - PrevSegment : PffBLOBSegmentHeaderDel; - BLOBBlock : PffBlock; - OffsetInBlock: TffWord32; - aRelMethod : TffReleaseMethod; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - { Assumptions: Deleted list contains at least one segment. - Segments are sorted by size when first read from disk so it is not - necessary to maintain sort order on disk. } - { Get the last segment in the chain. } - BLOBBlock := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - aFileHeader^.bhfDelBLOBTail, - OffsetInBlock, - aRelMethod); - PrevSegment := @BLOBBlock^[OffsetInBlock]; - - { Point the last segment to the new deleted segment & vice versa. } - PrevSegment^.bshNextSegment := aDelSeg.Offset; - aSegment^.bshNextSegment.iLow := ffc_W32NoValue; - aSegment^.bshNextSegment.iHigh := ffc_W32NoValue; - aSegment^.bshPrevSegment := aFileHeader^.bhfDelBLOBTail; - aRelMethod(BLOBBlock); - - { Mark the new deleted segment as the end of the chain. } - aFileHeader^.bhfDelBLOBTail := aDelSeg.Offset; - - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -function TffBaseBLOBSegmentMgr.GetNewSeg(aFI : PffFileInfo; - aTI : PffTransInfo; - const aSize : TffWord32) : TffInt64; -var - BLOBBlock : PffBlock; - DelSegHeader : PffBLOBSegmentHeaderDel; - TempI64 : TffInt64; - NewSegHeader : PffBLOBSegmentHeader; - aRelMethod : TffReleaseMethod; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - { Create a new BLOB block. } - BLOBBlock := FFTblHlpGetNewBlock(aFI, aTI, aRelMethod); - try - PffBlockHeaderBLOB(BLOBBlock)^.bhbSignature := ffc_SigBLOBBlock; - PffBlockHeaderBLOB(BLOBBlock)^.bhbNextBlock := ffc_W32NoValue; - PffBlockHeaderBLOB(BLOBBlock)^.bhbLSN := 0; - - { Make a new aSize segment in the block and return its file offset. } - TempI64.iLow := PffBlockHeaderBLOB(BLOBBlock)^.bhbThisBlock; - TempI64.iHigh := 0; - { Set TempI64 to file offset of new segment. } - ffI64MultInt(TempI64, aFI^.fiBlockSize, TempI64); - ffI64AddInt(TempI64, sizeof(TffBlockHeaderBLOB), Result); - NewSegHeader := PffBLOBSegmentHeader(@BLOBBlock^[sizeof(TffBlockHeaderBLOB)]); - NewSegHeader^.bshSegmentLen := aSize; - - { If there is left over space, make deleted segment and put in deleted - chain. We must create the deleted seg header now and store it, else we - won't know how big it is. } - if aSize < aFI^.fiMaxSegSize then begin -// PffBlockHeaderBLOB(BLOBBlock)^.bhbAssignedSegCount := 2; {Deleted !!.13} - DelSegHeader := PffBLOBSegmentHeaderDel(@BLOBBlock^[ffc_BlockHeaderSizeBLOB + aSize]); - DelSegHeader^.bshSegmentLen := aFI^.fiMaxSegSize - aSize; - { Set TempI64 to file offset of deleted segment and add it to deleted - chain. } - ffI64AddInt(Result, aSize, TempI64); - DeleteSegment(aFI, aTI, TempI64); - end; - {block only has 1 segment if the new segment was max seg size} -// else PffBlockHeaderBLOB(BLOBBlock)^.bhbAssignedSegCount := 1; {Deleted !!.13} - finally - aRelMethod(BLOBBlock); - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -procedure TffBaseBLOBSegmentMgr.bsmSliceSegment(aFI : PffFileInfo; - aTI : PffTransInfo; - aSegOfs : TffInt64; - aSegSize : TffWord32; - const aNewSize : TffWord32; - aInDelChain : Boolean); -var - BLOBBlock : PffBlock; - BlockNum : TffWord32; - DelSegHeader : PffBLOBSegmentHeaderDel; - OffsetInBlock : TffWord32; - TempI64 : TffInt64; - TempI64b : TffInt64; - ThisSeg : PffBLOBSegmentHeaderDel; - aRelMethod : TffReleaseMethod; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - { Post condition: New segment of aSize is always at aSegOfs. } - - { Remove the segment we're slicing from the deleted chain. } - if (aInDelChain) then - bsmRemoveFromDeletedChain(aFI, aTI, aSegOfs); - - { Get the segment to be sliced. } - BLOBBlock := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - aSegOfs, - OffsetInBlock, - aRelMethod); - try - ThisSeg := @BLOBBlock^[OffsetInBlock]; - - {increase this blobs used segment count by 2 to keep the count correct - - one of them will be removed when the unused portion slice segment - is returned to the deleted segment chain} -// Inc(PffBlockHeaderBLOB(BLOBBlock)^.bhbAssignedSegCount, 2); {Deleted !!.13} - - { Set the segment's new size. } - ThisSeg^.bshSegmentLen := aNewSize; - - { Get the offset for the remainder of the segment that will become a deleted - segment. } - ffI64AddInt(aSegOfs, aNewSize, TempI64); - BlockNum := FFGetBlockNum(aFI, TempI64); - ffI64MinusInt(TempI64, (BlockNum shl aFI^.fiLog2BlockSize), TempI64); - DelSegHeader := @BLOBBlock^[TempI64.iLow]; - - { Initialize the deleted segment. } - DelSegHeader^.bshSegmentLen := (aSegSize - aNewSize); - DelSegHeader^.bshPrevSegment.iLow := ffc_W32NoValue; - DelSegHeader^.bshPrevSegment.iHigh := ffc_W32NoValue; - DelSegHeader^.bshNextSegment.iLow := ffc_W32NoValue; - DelSegHeader^.bshNextSegment.iHigh := ffc_W32NoValue; - - { Put the new unused segment back in the chain. } - TempI64b.iLow := BlockNum; - TempI64b.iHigh := 0; - ffShiftI64L(TempI64b, aFI^.fiLog2BlockSize, TempI64b); - ffI64AddInt(TempI64b, TempI64.iLow, TempI64); - DeleteSegment(aFI, aTI, TempI64); - finally - aRelMethod(BLOBBlock); - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -procedure TffBaseBLOBSegmentMgr.bsmRemoveFromDeletedChain(aFI : PffFileInfo; - aTI : PffTransInfo; - aSegOfs : TffInt64); -var - aFileHeader : PffBlockHeaderFile; - OffsetInBlock : TffWord32; - ThisSegBlock : PffBlock; - ThisSeg : PffBLOBSegmentHeaderDel; - PrevSegBlock : PffBlock; - PrevSeg : PffBLOBSegmentHeaderDel; - NextSegBlock : PffBlock; - NextSeg : PffBLOBSegmentHeaderDel; - aFHRelMethod, - aSegRelMethod, - aSegRelMethod2 : TffReleaseMethod; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - { Assumptions: This segment has already been removed from the in-memory{ - deleted list. } - - { First get the file header, block 0. } - aFileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_MarkDirty, - aFHRelMethod)); - try - { Get the block. } - ThisSegBlock := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - aSegOfs, - OffsetInBlock, - aSegRelMethod); - try - ThisSeg := @ThisSegBlock^[OffsetInBlock]; - - { Is there a segment before this segment? } - if ThisSeg^.bshPrevSegment.iLow <> ffc_W32NoValue then begin - { Yes. Point the prior segment to the next segment. } - PrevSegBlock := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - ThisSeg^.bshPrevSegment, OffsetInBlock, - aSegRelMethod2); - PrevSeg := @PrevSegBlock^[OffsetInBlock]; - PrevSeg^.bshNextSegment := ThisSeg^.bshNextSegment; - - { If the removed segment was the tail then update the tail on the - file header. } - if PrevSeg^.bshNextSegment.iLow = ffc_W32NoValue then - aFileHeader^.bhfDelBLOBTail := ThisSeg^.bshPrevSegment; - - aSegRelMethod2(PrevSegBlock); - - end else - { No. This segment was the head. Update the head on the file header. } - aFileHeader^.bhfDelBLOBHead := ThisSeg^.bshNextSegment; - - { Is there a segment after this segment? } - if ThisSeg^.bshNextSegment.iLow <> ffc_W32NoValue then begin - { Yes. Point the next segment back to the prior segment. } - NextSegBlock := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - ThisSeg^.bshNextSegment, OffsetInBlock, - aSegRelMethod2); - NextSeg := @NextSegBlock^[OffsetInBlock]; - NextSeg^.bshPrevSegment := ThisSeg^.bshPrevSegment; - - { If the removed segment was the head of the chain then update the head - in the file header. } - if NextSeg^.bshPrevSegment.iLow = ffc_W32NoValue then - aFileHeader^.bhfDelBLOBHead := ThisSeg^.bshNextSegment; - - aSegRelMethod2(NextSegBlock); - - end else - { No. This was the tail segment. Update the tail in the file header. } - aFileHeader^.bhfDelBLOBTail := ThisSeg^.bshPrevSegment; - finally - aSegRelMethod(ThisSegBlock); - end; - finally - aFHRelMethod(PffBlock(aFileHeader)); - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -procedure WriteToStream(const aMsg : string; aStream : TStream); -begin - aStream.Write(aMsg[1], Length(aMsg)); -end; -{--------} -procedure TffBaseBLOBSegmentMgr.ListFreeSpace(aFI : PffFileInfo; - aTI : PffTransInfo; - const aInMemory : Boolean; - aStream : TStream); -var - aRelMethod, - aFHRelMethod : TffReleaseMethod; - anInx : Longint; - aSegItem : TffBLOBSegListItem; - aSegment : TffInt64; - aStr : string; - BLOBBlock : PffBlock; - DelSegment : PffBLOBSegmentHeaderDel; - FileHeader : PffBlockHeaderFile; - OffsetInBlock : TffWord32; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - - { Write the segment manager's in-memory list or the list as saved to the - file? } - if aInMemory then begin - { In-memory list. } - WriteToStream('In-memory deleted chain:' + #13#10, aStream); - for anInx := 0 to Pred(bsmDelChain.Count) do begin - aSegItem := TffBLOBSegListItem(bsmDelChain[anInx]); - aStr := IntToStr(anInx) + ': Size ' + IntToStr(aSegItem.Size) + - ', Offset ' + IntToStr(aSegItem.Offset.iHigh) + - ':' + IntToStr(aSegItem.Offset.iLow); - case aSegItem.FPendingAction of - bsaAddToList : aStr := aStr + ', add'; - bsaDeleteFromList : aStr := aStr + ', del'; - end; { case } - aStr := aStr + #13#10; - WriteToStream(aStr, aStream); - end; - - if bsmTranListHead <> nil then begin - WriteToStream('Transaction list:' + #13#10, aStream); - aSegItem := bsmTranListHead; - anInx := 0; - while aSegItem <> nil do begin - aStr := Format('%d : Size %d, Offset %d:%d', - [anInx, aSegItem.Size, aSegItem.Offset.iHigh, - aSegItem.Offset.iLow]); - aStr := aStr + ', Pending: '; - case aSegItem.FPendingAction of - bsaNone : aStr := aStr + 'N/A'; - bsaAddToList : aStr := aStr + 'add'; - bsaDeleteFromList : aStr := aStr + 'del'; - end; { case } - aSegItem := aSegItem.FTranNextItem; - inc(anInx); - aStr := aStr + #13#10; - WriteToStream(aStr, aStream); - end; - end - else begin - WriteToStream(#13#10 + 'Transaction list: EMPTY', aStream); - end; - end - else begin - { The list as saved to file. Need to walk through the BLOB deleted chain. } - { Get the file header. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, - aTI, - 0, - ffc_ReadOnly, - aFHRelMethod)); - try - { BLOB deleted chain is empty? } - if FileHeader^.bhfDelBLOBHead.iLow = ffc_W32NoValue then begin - { Yes. Write blurb & exit. } - WriteToStream('BLOB deleted chain is empty.', aStream); - WriteToStream(#0, aStream); - Exit; - end; - - { Not empty. Walk through the chain. } - anInx := 0; - aSegment := FileHeader^.bhfDelBLOBHead; - while (aSegment.iLow <> ffc_W32NoValue) do begin - { Get the block containing the segment. } - BLOBBlock := ReadVfyBlobBlock(aFI, - aTI, - ffc_ReadOnly, - aSegment, - OffsetInBlock, - aRelMethod); - { Get the segment & write pertinent info to the stream. } - DelSegment := @BLOBBlock^[OffsetInBlock]; - WriteToStream(Format('%d : Size %d, Offset %d:%d' + #13#10, - [anInx, DelSegment^.bshSegmentLen, aSegment.iHigh, - aSegment.iLow]), aStream); - aSegment := DelSegment^.bshNextSegment; - aRelMethod(BLOBBlock); - inc(anInx); - end; - finally - aFHRelMethod(PffBlock(FileHeader)); - end; - end; - WriteToStream(#0, aStream); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -procedure TffBaseBLOBSegmentMgr.Rollback; -var - CurItem, TmpItem : TffBLOBSegListItem; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - CurItem := bsmTranListHead; - while CurItem <> nil do begin - TmpItem := CurItem; - CurItem := TmpItem.FTranNextItem; - case TmpItem.FPendingAction of - bsaAddToList : - { The item won't be added to the in-memory deleted chain so free - the item. } - TmpItem.Free; - bsaDeleteFromList : - begin - { The item has been removed from the in-memory deleted list. We need - to reset its transaction info & add it back to the list. } - TmpItem.FPendingAction := bsaNone; - TmpItem.FTranNextItem := nil; - bsmDelChain.Insert(TmpItem); - end; - end; { case } - end; - bsmTranListHead := nil; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{====================================================================} - -{===TffBLOBSegListItem===============================================} -constructor TffBLOBSegListItem.Create; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - inherited Create; - fOffset.iLow := 0; - fOffset.iHigh := 0; - fSize := 0; - MaintainLinks := False; - FPendingAction := bsaNone; - FTranNextItem := nil; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{--------} -function TffBLOBSegListItem.Compare(aKey : pointer) : integer; -begin - Result := FFCmpI32(fSize, Longint(aKey^)); - if Result = 0 then - Result := 1; -end; -{--------} -function TffBLOBSegListItem.Key : pointer; -begin - Result := @fSize; -end; -{====================================================================} - -{===TffBLOBSegmentMgr================================================} -function TffBLOBSegmentMgr.GetRecycledSeg(aFI : PffFileInfo; - aTI : PffTransInfo; - var aSizeNeeded : Longint; - const aMinSizeAllowed : Longint) - : TffInt64; -var -// BLOBBlock : PffBlock; {Deleted !!.13} - L, R, M : Integer; - OldSegSize : Integer; -// aRelMethod : TffReleaseMethod; {Deleted !!.13} - SearchSize : Longint; - aPrevSegItem, - aSegItem : TffBLOBSegListItem; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - { Max TffInt64 returned if segment of aSize not available. } - Result.iLow := ffc_W32NoValue; - Result.iHigh := ffc_W32NoValue; - - { Is there a segment in the segment manager's transaction list? } - if (bsmUseTranList) then begin - { We are looking for a segment that is being added to the deleted - segment list and is at least as big as the segment we need. } - aPrevSegItem := nil; - aSegItem := bsmTranListHead; - while (aSegItem <> nil) do begin - if (aSegItem.FPendingAction = bsaAddTolist) then begin - if (aSegItem.FSize > aSizeNeeded) then begin - { Too big so we'll keeep looking. If we don't find a more - optimum sized segment, we'll use this one. } - aPrevSegItem := aSegItem; - end else begin - if (aSegItem.FSize < aMinSizeAllowed) then - aSegItem := aPrevSegItem; - Break; - end; - end; - - if (aSegItem.FTranNextItem = nil) then begin - aSegItem := aPrevSegItem; - Break; - end else - aSegItem := aSegItem.FTranNextItem - end; - - { Did we find one in the transaction list? } - if (aSegItem <> nil) then begin - { Yes. Prepare to return it. } - Result := aSegItem.FOffset; - bsmRemoveFromTranList(aSegItem); - bsmRemoveFromDeletedChain(aFI, aTI, Result); - { Do we need to slice it down to the correct size? } - if (aSegItem.FSize > aSizeNeeded) then begin - bsmSliceSegment(aFI, - aTI, - Result, - aSegItem.FSize, - aSizeNeeded, - False); - end else if (aSegItem.FSize < aSizeNeeded) then - aSizeNeeded := aSegItem.FSize; - aSegItem.Free; - Exit; - end; - end; - - { We can exit if the list is empty or if there is not a segment big enough - for the minimum size. } - if (bsmDelChain.IsEmpty) or - (Pinteger(bsmDelChain[0].Key)^ < aMinSizeAllowed) then - Exit; - - { Determine the size of segment to search for. } - if PInteger(bsmDelChain[0].Key)^ < aSizeNeeded then - SearchSize := aMinSizeAllowed - else - SearchSize := aSizeNeeded; - - { We know the list doesn't contain the exact size we're looking for, - but it does contain one that we can "slice" to the right size. - - using a standard binary search, we will slice L - 1} - L := 0; - R := pred(bsmDelChain.Count); - repeat - M := (L + R) div 2; - aSegItem := TffBLOBSegListItem(bsmDelChain[M]); - if (aSegItem.Size < SearchSize) then - R := M - 1 - else if (aSegItem.Size > SearchSize) then - L := M + 1 - else {found it} begin - Result := aSegItem.Offset; - if bsmUseTranList then begin - bsmAddToTranList(aSegItem, bsaDeleteFromList); - bsmDelChain.RemoveAt(M); - end - else - bsmDelChain.DeleteAt(M); - bsmRemoveFromDeletedChain(aFI, aTI, Result); - Break; - end; - until (L > R); - if (L > R) and (L > 0) then begin - {the item just bigger is at L-1} - dec(L); - aSegItem := TffBLOBSegListItem(bsmDelChain[L]); - Result := aSegItem.Offset; - OldSegSize := aSegItem.Size; - if bsmUseTranList then begin - bsmAddToTranList(aSegItem, bsaDeleteFromList); - bsmDelChain.RemoveAt(L); - end - else begin - bsmDelChain.DeleteAt(L); - end; - bsmSliceSegment(aFI, - aTI, - Result, - OldSegSize, - SearchSize, - True); - end; - aSizeNeeded := SearchSize; - - { Get the segment's block & update the used segment count. } -{Begin !!.13} -// BLOBBlock := ReadVfyBlobBlock3(aFI, aTI, ffc_MarkDirty, Result, aRelMethod); -// inc(PffBlockHeaderBLOB(BLOBBlock)^.bhbAssignedSegCount); -// aRelMethod(BLOBBlock); -{End !!.13} - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{====================================================================} - -{===Tff210BLOBSegmentMgr=============================================} -function Tff210BLOBSegmentMgr.GetRecycledSeg(aFI : PffFileInfo; - aTI : PffTransInfo; - var aSizeNeeded : Longint; - const aMinSizeAllowed : Longint) - : TffInt64; -var -// BLOBBlock : PffBlock; {Deleted !!.13} - L, R, M : Integer; - OldSegSize : Integer; -// aRelMethod : TffReleaseMethod; {Deleted !!.13} - aSegItem : TffBLOBSegListItem; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - { Max TffInt64 returned if segment of aSize not available. } - Result.iLow := ffc_W32NoValue; - Result.iHigh := ffc_W32NoValue; - - { Is there a segment in the segment manager's transaction list? } - if (bsmUseTranList) then begin - { We are looking for a segment that is being added to the deleted - segment list and is at least as big as the segment we need. } - aSegItem := bsmTranListHead; - while (aSegItem <> nil) do begin - if ((aSegItem.FPendingAction = bsaAddToList) and - (aSegItem.FSize >= aSizeNeeded)) then begin - Result := aSegItem.FOffset; - bsmRemoveFromTranList(aSegItem); - bsmRemoveFromDeletedChain(aFI, aTI, Result); - { Do we need to slice it down to the correct size? } - if (aSegItem.FSize > aSizeNeeded) then - bsmSliceSegment(aFI, - aTI, - Result, - aSegItem.FSize, - aSizeNeeded, - False); - aSegItem.Free; - Exit; - end; - aSegItem := aSegItem.FTranNextItem; - end; - end; - - if (bsmDelChain.IsEmpty) then - Exit; - if (Pinteger(bsmDelChain[0].Key)^ < aSizeNeeded) then - Exit; - - {we know the list doesn't contain the exact size we're looking for, - but it does contain one that we can "slice" to the right size. - - using a standard binary search, we will slice L - 1} - L := 0; - R := pred(bsmDelChain.Count); - repeat - M := (L + R) div 2; - aSegItem := TffBLOBSegListItem(bsmDelChain[M]); - if (aSegItem.Size < aSizeNeeded) then - R := M - 1 - else if (aSegItem.Size > aSizeNeeded) then - L := M + 1 - else {found it} begin - Result := aSegItem.Offset; - if bsmUseTranList then begin - bsmAddToTranList(aSegItem, bsaDeleteFromList); - bsmDelChain.RemoveAt(M); - end - else - bsmDelChain.DeleteAt(M); - bsmRemoveFromDeletedChain(aFI, aTI, Result); - Break; - end; - until (L > R); - if (L > R) and (L > 0) then begin - {the item just bigger is at L-1} - dec(L); - aSegItem := TffBLOBSegListItem(bsmDelChain[L]); - Result := aSegItem.Offset; - OldSegSize := aSegItem.Size; - if bsmUseTranList then begin - bsmAddToTranList(aSegItem, bsaDeleteFromList); - bsmDelChain.RemoveAt(L); - end - else begin - bsmDelChain.DeleteAt(L); - end; - bsmSliceSegment(aFI, - aTI, - Result, - OldSegSize, - aSizeNeeded, - True); - end; - { Get the segment's block & update the used segment count. } -{Begin !!.13} -// BLOBBlock := ReadVfyBlobBlock3(aFI, aTI, ffc_MarkDirty, Result, aRelMethod); -// inc(PffBlockHeaderBLOB(BLOBBlock)^.bhbAssignedSegCount); -// aRelMethod(BLOBBlock); -{End !!.13} - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{====================================================================} -{End !!.11} - -{===Initialization/Finalization======================================} -procedure FinalizeUnit; -begin - Pool4k.Free; - Pool8k.Free; - Pool16k.Free; - Pool32k.Free; - Pool64k.Free; - ffStrResServer.Free; - if (EncryptBuffer <> nil) then - FreeMem(EncryptBuffer, 64*1024); - - {$IFDEF RAMPageCheck} - aLog.Flush; - aLog.Free; - {$ENDIF} -end; -{--------} -procedure InitializeUnit; -begin - Pool4k := nil; - Pool8k := nil; - Pool16k := nil; - Pool32k := nil; - Pool64k := nil; - EncryptBuffer := nil; - ffStrResServer := nil; - ffStrResServer := TffStringResource.Create(hInstance, 'FF_SERVER_STRINGS'); - - {$IFDEF RAMPageCheck} - aLog := TffEventLog.Create(nil); - aLog.FileName := 'RAMPage.log'; - aLog.Enabled := True; - {$ENDIF} -end; -{--------} - -initialization - InitializeUnit; - -finalization - FinalizeUnit; - -end. - diff --git a/components/flashfiler/sourcelaz/ffsrbde.pas b/components/flashfiler/sourcelaz/ffsrbde.pas deleted file mode 100644 index 8fae1532b..000000000 --- a/components/flashfiler/sourcelaz/ffsrbde.pas +++ /dev/null @@ -1,1622 +0,0 @@ -{*********************************************************} -{* FlashFiler: BDE consts and types 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 ***** *) - -{Note: The following definitions are copied from BDE.PAS. The server - 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 server} - -{BDE.PAS source file and error codes are - (c) Copyright Borland International Inc, 1997} - -{$I ffdefine.inc} - -{$Z+} - -unit ffsrbde; - -interface - -uses - Windows, - SysUtils, - Classes, - ffconst, - ffllbase; - -type - DBIMSG = array [0..127] of AnsiChar; {!!.55} - - -{============================================================================} -{ Error Categories } -{============================================================================} - -const - ERRCAT_NONE = 0; { 0 No error } - ERRCAT_SYSTEM = $21; { 33 System related (Fatal Error) } - ERRCAT_NOTFOUND = $22; { 34 Object of interest Not Found } - ERRCAT_DATACORRUPT = $23; { 35 Physical Data Corruption } - ERRCAT_IO = $24; { 36 I/O related error } - ERRCAT_LIMIT = $25; { 37 Resource or Limit error } - ERRCAT_INTEGRITY = $26; { 38 Integrity Violation } - ERRCAT_INVALIDREQ = $27; { 39 Invalid Request } - ERRCAT_LOCKCONFLICT = $28; { 40 Locking/Contention related } - ERRCAT_SECURITY = $29; { 41 Access Violation - Security related } - ERRCAT_INVALIDCONTEXT = $2A; { 42 Invalid context } - ERRCAT_OS = $2B; { 43 Os Error not handled by Idapi } - ERRCAT_NETWORK = $2C; { 44 Network related } - ERRCAT_OPTPARAM = $2D; { 45 Optional parameter related } - ERRCAT_QUERY = $2E; { 46 Query related } - ERRCAT_VERSION = $2F; { 47 Version Mismatch Category } - ERRCAT_CAPABILITY = $30; { 48 Capability not supported } - ERRCAT_CONFIG = $31; { 49 System configuration error } - ERRCAT_WARNING = $32; { 50 } - ERRCAT_OTHER = $33; { 51 Miscellaneous } - ERRCAT_COMPATIBILITY = $34; { 52 Compatibility related } - ERRCAT_REPOSITORY = $35; { 53 Data Repository related } - - ERRCAT_DRIVER = $3E; { 62 Driver related } - ERRCAT_RC = $3F; { 63 Internal } - - - ERRBASE_NONE = 0; { No error } - ERRBASE_SYSTEM = $2100; { System related (Fatal Error) } - ERRBASE_NOTFOUND = $2200; { Object of interest Not Found } - ERRBASE_DATACORRUPT = $2300; { Physical Data Corruption } - ERRBASE_IO = $2400; { I/O related error } - ERRBASE_LIMIT = $2500; { Resource or Limit error } - ERRBASE_INTEGRITY = $2600; { Integrity Violation } - ERRBASE_INVALIDREQ = $2700; { Invalid Request } - ERRBASE_LOCKCONFLICT = $2800; { Locking/Contention related } - ERRBASE_SEC = $2900; { Access Violation - Security related } - ERRBASE_IC = $2A00; { Invalid context } - ERRBASE_OS = $2B00; { Os Error not handled by Idapi } - ERRBASE_NETWORK = $2C00; { Network related } - ERRBASE_OPTPARAM = $2D00; { Optional Parameter related } - ERRBASE_QUERY = $2E00; { Query related } - ERRBASE_VERSION = $2F00; { Version Mismatch Category } - ERRBASE_CAPABILITY = $3000; { Capability not supported } - ERRBASE_CONFIG = $3100; { System configuration error } - ERRBASE_WARNING = $3200; - ERRBASE_OTHER = $3300; { Miscellaneous } - ERRBASE_COMPATIBILITY = $3400; { Compatibility related } - ERRBASE_REPOSITORY = $3500; { Data Repository related } - - ERRBASE_DRIVER = $3E00; { Driver related } - ERRBASE_RC = $3F00; { Internal } - - -{=============================================================================} -{ Error Codes By Category } -{=============================================================================} - -{ ERRCAT_NONE (0) } -{ =========== } - - ERRCODE_NONE = 0; - - DBIERR_NONE = (ERRBASE_NONE + ERRCODE_NONE); - -{ ERRCAT_SYSTEM } -{ ============= } - - ERRCODE_SYSFILEOPEN = 1; { Cannot open a system file } - ERRCODE_SYSFILEIO = 2; { I/O error on a system file } - ERRCODE_SYSCORRUPT = 3; { Data structure corruption } - ERRCODE_NOCONFIGFILE = 4; { Cannot find config file } - ERRCODE_CFGCANNOTWRITE = 5; { Cannot write config file (READONLY) } - ERRCODE_CFGMULTIFILE = 6; { Initializing with different ini file } - ERRCODE_REENTERED = 7; { System has been illegally re-entered } - ERRCODE_CANTFINDIDAPI = 8; { Cannot locate IDAPIxx.DLL } - ERRCODE_CANTLOADIDAPI = 9; { Cannot load IDAPIxx.DLL } - ERRCODE_CANTLOADLIBRARY = 10; { Cannot load a service DLL } - ERRCODE_TEMPFILEERR = 11; { Cannot create or open temporary file } - ERRCODE_MULTIPLEIDAPI = 12; { Trying to load multiple IDAPIxx.DLL } - - DBIERR_SYSFILEOPEN = (ERRBASE_SYSTEM + ERRCODE_SYSFILEOPEN); - DBIERR_SYSFILEIO = (ERRBASE_SYSTEM + ERRCODE_SYSFILEIO); - DBIERR_SYSCORRUPT = (ERRBASE_SYSTEM + ERRCODE_SYSCORRUPT); - DBIERR_NOCONFIGFILE = (ERRBASE_SYSTEM + ERRCODE_NOCONFIGFILE); - DBIERR_CFGCANNOTWRITE = (ERRBASE_SYSTEM + ERRCODE_CFGCANNOTWRITE); - DBIERR_CFGMULTIFILE = (ERRBASE_SYSTEM + ERRCODE_CFGMULTIFILE); - DBIERR_REENTERED = (ERRBASE_SYSTEM + ERRCODE_REENTERED); - DBIERR_CANTFINDIDAPI = (ERRBASE_SYSTEM + ERRCODE_CANTFINDIDAPI); - DBIERR_CANTLOADIDAPI = (ERRBASE_SYSTEM + ERRCODE_CANTLOADIDAPI); - DBIERR_CANTLOADLIBRARY = (ERRBASE_SYSTEM + ERRCODE_CANTLOADLIBRARY); - DBIERR_TEMPFILEERR = (ERRBASE_SYSTEM + ERRCODE_TEMPFILEERR); - DBIERR_MULTIPLEIDAPI = (ERRBASE_SYSTEM + ERRCODE_MULTIPLEIDAPI); - - DBIERR_CANTFINDODAPI = DBIERR_CANTFINDIDAPI; - DBIERR_CANTLOADODAPI = DBIERR_CANTLOADIDAPI; - -{ ERRCAT_NOTFOUND } -{ =============== } - - ERRCODE_BOF = 1; { Beginning of Virtual table } - ERRCODE_EOF = 2; { End of Virtual table } - ERRCODE_RECMOVED = 3; { Fly-away } - ERRCODE_KEYORRECDELETED = 4; { Record Deleted/Key Modified } - ERRCODE_NOCURRREC = 5; { No current record } - ERRCODE_RECNOTFOUND = 6; { Record was not found } - ERRCODE_ENDOFBLOB = 7; { End of Blob reached } - ERRCODE_OBJNOTFOUND = 8; { Generic Not found } - ERRCODE_FMLMEMBERNOTFOUND = 9; { Family member not found } - ERRCODE_BLOBFILEMISSING = 10; { 0x0a Blob file for table is missing } - ERRCODE_LDNOTFOUND = 11; { 0x0b Language driver not found } - - DBIERR_BOF = (ERRBASE_NOTFOUND + ERRCODE_BOF); - DBIERR_EOF = (ERRBASE_NOTFOUND + ERRCODE_EOF); - DBIERR_RECMOVED = (ERRBASE_NOTFOUND + ERRCODE_RECMOVED); - DBIERR_RECDELETED = (ERRBASE_NOTFOUND + ERRCODE_KEYORRECDELETED); - DBIERR_KEYORRECDELETED = (ERRBASE_NOTFOUND + ERRCODE_KEYORRECDELETED); - DBIERR_NOCURRREC = (ERRBASE_NOTFOUND + ERRCODE_NOCURRREC); - DBIERR_RECNOTFOUND = (ERRBASE_NOTFOUND + ERRCODE_RECNOTFOUND); - DBIERR_ENDOFBLOB = (ERRBASE_NOTFOUND + ERRCODE_ENDOFBLOB); - DBIERR_OBJNOTFOUND = (ERRBASE_NOTFOUND + ERRCODE_OBJNOTFOUND); - DBIERR_FMLMEMBERNOTFOUND = (ERRBASE_NOTFOUND + ERRCODE_FMLMEMBERNOTFOUND); - DBIERR_BLOBFILEMISSING = (ERRBASE_NOTFOUND + ERRCODE_BLOBFILEMISSING); - DBIERR_LDNOTFOUND = (ERRBASE_NOTFOUND + ERRCODE_LDNOTFOUND); - -{ ERRCAT_DATACORRUPT } -{ ================== } - - ERRCODE_HEADERCORRUPT = 1; { Corrupt Header } - ERRCODE_FILECORRUPT = 2; { File corrupt - other than header } - ERRCODE_MEMOCORRUPT = 3; { Memo file corrupted } - ERRCODE_BMPCORRUPT = 4; { BitMap is corrupt (Internal error) } - ERRCODE_INDEXCORRUPT = 5; { Index is corrupt } - ERRCODE_CORRUPTLOCKFILE = 6; { Corrupt lock file } - ERRCODE_FAMFILEINVALID = 7; { Corrupt family file } - ERRCODE_VALFILECORRUPT = 8; { Val file is missing or corrupt } - ERRCODE_FOREIGNINDEX = 9; { Index is in a foreign format - import first } - - - DBIERR_HEADERCORRUPT = (ERRBASE_DATACORRUPT + ERRCODE_HEADERCORRUPT); - DBIERR_FILECORRUPT = (ERRBASE_DATACORRUPT + ERRCODE_FILECORRUPT); - DBIERR_MEMOCORRUPT = (ERRBASE_DATACORRUPT + ERRCODE_MEMOCORRUPT); - DBIERR_BMPCORRUPT = (ERRBASE_DATACORRUPT + ERRCODE_BMPCORRUPT); - DBIERR_INDEXCORRUPT = (ERRBASE_DATACORRUPT + ERRCODE_INDEXCORRUPT); - DBIERR_CORRUPTLOCKFILE = (ERRBASE_DATACORRUPT + ERRCODE_CORRUPTLOCKFILE); - DBIERR_FAMFILEINVALID = (ERRBASE_DATACORRUPT + ERRCODE_FAMFILEINVALID); - DBIERR_VALFILECORRUPT = (ERRBASE_DATACORRUPT + ERRCODE_VALFILECORRUPT); - DBIERR_FOREIGNINDEX = (ERRBASE_DATACORRUPT + ERRCODE_FOREIGNINDEX); - - -{ ERRCAT_IO } -{ ========= } - - ERRCODE_READERR = 1; { Read failure (not expected) } - ERRCODE_WRITEERR = 2; { Write failure (not expected) } - ERRCODE_DIRNOACCESS = 3; { No access to dir } - ERRCODE_FILEDELETEFAIL = 4; { File delete failed } - ERRCODE_FILENOACCESS = 5; { No access to file } - ERRCODE_ACCESSDISABLED = 6; { Access to table disabled (previous error) } - - DBIERR_READERR = (ERRBASE_IO + ERRCODE_READERR); - DBIERR_WRITEERR = (ERRBASE_IO + ERRCODE_WRITEERR); - DBIERR_DIRNOACCESS = (ERRBASE_IO + ERRCODE_DIRNOACCESS); - DBIERR_FILEDELETEFAIL = (ERRBASE_IO + ERRCODE_FILEDELETEFAIL); - DBIERR_FILENOACCESS = (ERRBASE_IO + ERRCODE_FILENOACCESS); - DBIERR_ACCESSDISABLED = (ERRBASE_IO + ERRCODE_ACCESSDISABLED); - -{ ERRCAT_LIMIT } -{ ============ } - - ERRCODE_NOMEMORY = 1; { Not enough Memory for this op } - ERRCODE_NOFILEHANDLES = 2; { Not enough File handles } - ERRCODE_NODISKSPACE = 3; { Not enough Disk space } - ERRCODE_NOTEMPTBLSPACE = 4; { Temporary Table resource limit } - ERRCODE_RECTOOBIG = 5; { Too big a record size for table } - ERRCODE_CURSORLIMIT = 6; { Too many open cursors } - ERRCODE_TABLEFULL = 7; { Table is full } - ERRCODE_WSSESLIMIT = 8; { Too many sessions from this WS } - ERRCODE_SERNUMLIMIT = 9; { Serial number limit (paradox) } - ERRCODE_INTERNALLIMIT = 10; { 0x0a Some internal limit (see context) } - ERRCODE_OPENTBLLIMIT = 11; { 0x0b Too many open tables } - ERRCODE_TBLCURSORLIMIT = 12; { 0x0c Too many cursors per table } - ERRCODE_RECLOCKLIMIT = 13; { 0x0d Too many record locks on table } - ERRCODE_CLIENTSLIMIT = 14; { 0x0e Too many clients } - ERRCODE_INDEXLIMIT = 15; { 0x0f Too many indexes (also in Table Create) } - ERRCODE_SESSIONSLIMIT = 16; { 0x10 Too many sessions } - ERRCODE_DBLIMIT = 17; { 0x11 Too many databases } - ERRCODE_PASSWORDLIMIT = 18; { 0x12 Too many passwords } - ERRCODE_DRIVERLIMIT = 19; { 0x13 Too many active drivers } - ERRCODE_FLDLIMIT = 20; { 0x14 Too many Fields in Table Create } - ERRCODE_TBLLOCKLIMIT = 21; { 0x15 Too many table locks } - ERRCODE_OPENBLOBLIMIT = 22; { 0x16 Too many open blobs } - ERRCODE_LOCKFILELIMIT = 23; { 0x17 Lock file has grown too big } - ERRCODE_OPENQRYLIMIT = 24; { 0x18 Too many open queries } - ERRCODE_THREADLIMIT = 25; { 0x19 Too many threads for client } - ERRCODE_BLOBLIMIT = 26; { 0x1a Too many blobs } - ERRCODE_PDX50NAMELIMIT = 27; { 0x1b Pathname is too long for a Paradox 5.0 or less table } - ERRCODE_ROWFETCHLIMIT = 28; { 0x1c Row fetch limit } - ERRCODE_LONGNAMENOTALLOWED = 29; { 0x1d Long name is not allowed for this tableversion } - - DBIERR_NOMEMORY = (ERRBASE_LIMIT + ERRCODE_NOMEMORY); - DBIERR_NOFILEHANDLES = (ERRBASE_LIMIT + ERRCODE_NOFILEHANDLES); - DBIERR_NODISKSPACE = (ERRBASE_LIMIT + ERRCODE_NODISKSPACE); - DBIERR_NOTEMPTBLSPACE = (ERRBASE_LIMIT + ERRCODE_NOTEMPTBLSPACE); - DBIERR_RECTOOBIG = (ERRBASE_LIMIT + ERRCODE_RECTOOBIG); - DBIERR_CURSORLIMIT = (ERRBASE_LIMIT + ERRCODE_CURSORLIMIT); - DBIERR_TABLEFULL = (ERRBASE_LIMIT + ERRCODE_TABLEFULL); - DBIERR_WSSESLIMIT = (ERRBASE_LIMIT + ERRCODE_WSSESLIMIT); - DBIERR_SERNUMLIMIT = (ERRBASE_LIMIT + ERRCODE_SERNUMLIMIT); - DBIERR_INTERNALLIMIT = (ERRBASE_LIMIT + ERRCODE_INTERNALLIMIT); - DBIERR_OPENTBLLIMIT = (ERRBASE_LIMIT + ERRCODE_OPENTBLLIMIT); - DBIERR_TBLCURSORLIMIT = (ERRBASE_LIMIT + ERRCODE_TBLCURSORLIMIT); - DBIERR_RECLOCKLIMIT = (ERRBASE_LIMIT + ERRCODE_RECLOCKLIMIT); - DBIERR_CLIENTSLIMIT = (ERRBASE_LIMIT + ERRCODE_CLIENTSLIMIT); - DBIERR_INDEXLIMIT = (ERRBASE_LIMIT + ERRCODE_INDEXLIMIT); - DBIERR_SESSIONSLIMIT = (ERRBASE_LIMIT + ERRCODE_SESSIONSLIMIT); - DBIERR_DBLIMIT = (ERRBASE_LIMIT + ERRCODE_DBLIMIT); - DBIERR_PASSWORDLIMIT = (ERRBASE_LIMIT + ERRCODE_PASSWORDLIMIT); - DBIERR_DRIVERLIMIT = (ERRBASE_LIMIT + ERRCODE_DRIVERLIMIT); - DBIERR_FLDLIMIT = (ERRBASE_LIMIT + ERRCODE_FLDLIMIT); - DBIERR_TBLLOCKLIMIT = (ERRBASE_LIMIT + ERRCODE_TBLLOCKLIMIT); - DBIERR_OPENBLOBLIMIT = (ERRBASE_LIMIT + ERRCODE_OPENBLOBLIMIT); - DBIERR_LOCKFILELIMIT = (ERRBASE_LIMIT + ERRCODE_LOCKFILELIMIT); - DBIERR_OPENQRYLIMIT = (ERRBASE_LIMIT + ERRCODE_OPENQRYLIMIT); - DBIERR_THREADLIMIT = (ERRBASE_LIMIT + ERRCODE_THREADLIMIT); - DBIERR_BLOBLIMIT = (ERRBASE_LIMIT + ERRCODE_BLOBLIMIT); - DBIERR_PDX50NAMELIMIT = (ERRBASE_LIMIT + ERRCODE_PDX50NAMELIMIT); - DBIERR_ROWFETCHLIMIT = (ERRBASE_LIMIT + ERRCODE_ROWFETCHLIMIT); - DBIERR_LONGNAMENOTALLOWED = (ERRBASE_LIMIT + ERRCODE_LONGNAMENOTALLOWED); - -{ ERRCAT_INTEGRITY } -{ ================ } - - ERRCODE_KEYVIOL = 1; { Key violation } - ERRCODE_MINVALERR = 2; { Min val check failed } - ERRCODE_MAXVALERR = 3; { Max val check failed } - ERRCODE_REQDERR = 4; { Field value required } - ERRCODE_FORIEGNKEYERR = 5; { Master record missing } - ERRCODE_DETAILRECORDSEXIST = 6; { Cannot MODIFY or DELETE this Master record } - ERRCODE_MASTERTBLLEVEL = 7; { Master Table Level is incorrect } - ERRCODE_LOOKUPTABLEERR = 8; { Field value out of lookup tbl range } - ERRCODE_LOOKUPTBLOPENERR = 9; { Lookup Table Open failed } - ERRCODE_DETAILTBLOPENERR = 10; { 0x0a Detail Table Open failed } - ERRCODE_MASTERTBLOPENERR = 11; { 0x0b Master Table Open failed } - ERRCODE_FIELDISBLANK = 12; { 0x0c Field is blank } - - ERRCODE_MASTEREXISTS = 13; { 0x0d Master Table exists } - ERRCODE_MASTERTBLOPEN = 14; { 0x0e Master Table is open } - - ERRCODE_DETAILTABLESEXIST = 15; { 0x0f Detail Tables exist ( cannot delete, rename ... ) } - ERRCODE_DETAILRECEXISTEMPTY = 16; { 0x10 Cannot empty because details exist } - ERRCODE_MASTERREFERENCEERR = 17; { 0x11 Cannot modify while adding self referencing Referential Integrity } - ERRCODE_DETAILTBLOPEN = 18; { 0x12 Detail Table is opened } - ERRCODE_DEPENDENTSMUSTBEEMPTY = 19; { 0x13 Cannot make a master a detail of another table if its details are not empty. } - ERRCODE_RINTREQINDEX = 20; { 0x14 Ref. integrity fields must be indexed } - ERRCODE_LINKEDTBLPROTECTED = 21; { 0x15 Master Table is protected ( requires password to open) } - ERRCODE_FIELDMULTILINKED = 22; { 0x16 Field has more than one master } - - DBIERR_KEYVIOL = (ERRBASE_INTEGRITY + ERRCODE_KEYVIOL); - DBIERR_MINVALERR = (ERRBASE_INTEGRITY + ERRCODE_MINVALERR); - DBIERR_MAXVALERR = (ERRBASE_INTEGRITY + ERRCODE_MAXVALERR); - DBIERR_REQDERR = (ERRBASE_INTEGRITY + ERRCODE_REQDERR); - DBIERR_FORIEGNKEYERR = (ERRBASE_INTEGRITY + ERRCODE_FORIEGNKEYERR); - DBIERR_DETAILRECORDSEXIST = (ERRBASE_INTEGRITY + ERRCODE_DETAILRECORDSEXIST); - DBIERR_MASTERTBLLEVEL = (ERRBASE_INTEGRITY + ERRCODE_MASTERTBLLEVEL); - DBIERR_LOOKUPTABLEERR = (ERRBASE_INTEGRITY + ERRCODE_LOOKUPTABLEERR); - DBIERR_LOOKUPTBLOPENERR = (ERRBASE_INTEGRITY + ERRCODE_LOOKUPTBLOPENERR); - DBIERR_DETAILTBLOPENERR = (ERRBASE_INTEGRITY + ERRCODE_DETAILTBLOPENERR); - DBIERR_MASTERTBLOPENERR = (ERRBASE_INTEGRITY + ERRCODE_MASTERTBLOPENERR); - DBIERR_FIELDISBLANK = (ERRBASE_INTEGRITY + ERRCODE_FIELDISBLANK); - DBIERR_MASTEREXISTS = (ERRBASE_INTEGRITY + ERRCODE_MASTEREXISTS); - DBIERR_MASTERTBLOPEN = (ERRBASE_INTEGRITY + ERRCODE_MASTERTBLOPEN); - DBIERR_DETAILTABLESEXIST = (ERRBASE_INTEGRITY + ERRCODE_DETAILTABLESEXIST); - DBIERR_DETAILRECEXISTEMPTY = (ERRBASE_INTEGRITY + ERRCODE_DETAILRECEXISTEMPTY); - DBIERR_MASTERREFERENCEERR = (ERRBASE_INTEGRITY + ERRCODE_MASTERREFERENCEERR); - DBIERR_DETAILTBLOPEN = (ERRBASE_INTEGRITY + ERRCODE_DETAILTBLOPEN); - DBIERR_DEPENDENTSMUSTBEEMPTY = (ERRBASE_INTEGRITY + ERRCODE_DEPENDENTSMUSTBEEMPTY); - DBIERR_RINTREQINDEX = (ERRBASE_INTEGRITY + ERRCODE_RINTREQINDEX); - DBIERR_LINKEDTBLPROTECTED = (ERRBASE_INTEGRITY + ERRCODE_LINKEDTBLPROTECTED); - DBIERR_FIELDMULTILINKED = (ERRBASE_INTEGRITY + ERRCODE_FIELDMULTILINKED); - - -{ ERRCAT_INVALIDREQ } -{ ================= } - - ERRCODE_OUTOFRANGE = 1; { Number out of range (e.g field no) } - ERRCODE_INVALIDPARAM = 2; { Generic invalid parameter } - ERRCODE_INVALIDFILENAME = 3; { Invalid file name } - ERRCODE_NOSUCHFILE = 4; { No such file } - ERRCODE_INVALIDOPTION = 5; { Invalid option for a parameter } - ERRCODE_INVALIDHNDL = 6; { Invalid handle to the function } - ERRCODE_UNKNOWNTBLTYPE = 7; { Table type given not known } - ERRCODE_UNKNOWNFILE = 8; { Dont know how to open file } - ERRCODE_PRIMARYKEYREDEFINE = 9; { Cannot redefine primary key } - ERRCODE_INVALIDRINTDESCNUM = 10; { 0x0a Cannot change this RINTDesc } - ERRCODE_KEYFLDTYPEMISMATCH = 11; { 0x0b Foreign & Primary Key Mismatch } - ERRCODE_INVALIDMODIFYREQUEST = 12; { 0x0c Invalid modify request } - ERRCODE_NOSUCHINDEX = 13; { 0x0d Index does not exist } - ERRCODE_INVALIDBLOBOFFSET = 14; { 0x0e Invalid Offset into the Blob } - ERRCODE_INVALIDDESCNUM = 15; { 0x0f Invalid descriptor number } - ERRCODE_INVALIDFLDTYPE = 16; { 0x10 Invalid field type } - ERRCODE_INVALIDFLDDESC = 17; { 0x11 Invalid field descriptor } - ERRCODE_INVALIDFLDXFORM = 18; { 0x12 Invalid field transform } - ERRCODE_INVALIDRECSTRUCT = 19; { 0x13 Invalid record structure } - ERRCODE_INVALIDDESC = 20; { 0x14 Generic: invalid descriptor } - ERRCODE_INVALIDINDEXSTRUCT = 21; { 0x15 Invalid array of indexes descriptors } - ERRCODE_INVALIDVCHKSTRUCT = 22; { 0x16 Invalid array of val. check descriptors } - ERRCODE_INVALIDRINTSTRUCT = 23; { 0x17 Invalid array of ref. integrity descriptors } - ERRCODE_INVALIDRESTRTBLORDER = 24; { 0x18 Invalid ordering of tables during restructure } - ERRCODE_NAMENOTUNIQUE = 25; { 0x19 Name not unique in this context } - ERRCODE_INDEXNAMEREQUIRED = 26; { 0x1a Index name required } - ERRCODE_INVALIDSESHANDLE = 27; { 0x1b Invalid ses handle } - ERRCODE_INVALIDRESTROP = 28; { 0x1c Invalid restructure operation } - ERRCODE_UNKNOWNDRIVER = 29; { 0x1d Driver not known to system } - ERRCODE_UNKNOWNDB = 30; { 0x1e Unknown db } - ERRCODE_INVALIDPASSWORD = 31; { 0x1f Invalid password given } - ERRCODE_NOCALLBACK = 32; { 0x20 No callback function } - ERRCODE_INVALIDCALLBACKBUFLEN = 33; { 0x21 Invalid callback buffer length } - ERRCODE_INVALIDDIR = 34; { 0x22 Invalid directory } - ERRCODE_INVALIDXLATION = 35; { 0x23 Translate Error - Translate DID NOT happen } - ERRCODE_DIFFERENTTABLES = 36; { 0x24 Cannot Set Cursor of one Table to another } - ERRCODE_INVALIDBOOKMARK = 37; { 0x25 Bookmarks does not match table, etc. } - ERRCODE_INVALIDINDEXNAME = 38; { 0x26 Index/Tag Name is invalid } - ERRCODE_INVALIDIDXDESC = 39; { 0x27 Invalid index descriptor } - ERRCODE_NOSUCHTABLE = 40; { 0x28 No such table } - ERRCODE_USECOUNT = 41; { 0x29 Table has too many users } - ERRCODE_INVALIDKEY = 42; { 0x2a Key does not pass filter condition } - ERRCODE_INDEXEXISTS = 43; { 0x2b Index already exists } - ERRCODE_INDEXOPEN = 44; { 0x2c Index is open } - ERRCODE_INVALIDBLOBLEN = 45; { 0x2d Invalid Blob Length } - ERRCODE_INVALIDBLOBHANDLE = 46; { 0x2e Invalid Blob handle (in record buffer) } - ERRCODE_TABLEOPEN = 47; { 0x2f Table is open } - ERRCODE_NEEDRESTRUCTURE = 48; { 0x30 Need to do (hard) restructure } - ERRCODE_INVALIDMODE = 49; { 0x31 Invalid mode } - ERRCODE_CANNOTCLOSE = 50; { 0x32 Cannot close index } - ERRCODE_ACTIVEINDEX = 51; { 0x33 Index is being used to order tbl } - ERRCODE_INVALIDUSRPASS = 52; { 0x34 Bad user name or password } - ERRCODE_MULTILEVELCASCADE = 53; { 0x35 Multi level Cascade not supported } - ERRCODE_INVALIDFIELDNAME = 54; { 0x36 Invalid field name } - ERRCODE_INVALIDTABLENAME = 55; { 0x37 Invalid table name } - ERRCODE_INVALIDLINKEXPR = 56; { 0x38 Invalid linked cursor expression } - ERRCODE_NAMERESERVED = 57; { 0x39 Name is reserved } - ERRCODE_INVALIDFILEEXTN = 58; { 0x3a Invalid file extention } - ERRCODE_INVALIDLANGDRV = 59; { 0x3b Invalid language driver } - ERRCODE_ALIASNOTOPEN = 60; { 0x3c Requested alias in not open } - ERRCODE_INCOMPATRECSTRUCTS = 61; { 0x3d Incompatible record structures } - ERRCODE_RESERVEDDOSNAME = 62; { 0x3e Reserved dos name } - ERRCODE_DESTMUSTBEINDEXED = 63; { 0x3f Destination must be indexed } - ERRCODE_INVALIDINDEXTYPE = 64; { 0x40 Invalid index type } - ERRCODE_LANGDRVMISMATCH = 65; { 0x41 Language driver of table and index do not match } - ERRCODE_NOSUCHFILTER = 66; { 0x42 Filter handle is invalid } - ERRCODE_INVALIDFILTER = 67; { 0x43 Invalid filter } - - ERRCODE_INVALIDTABLECREATE = 68; { 0x44 Bad table create request (exact prob unknown) } - ERRCODE_INVALIDTABLEDELETE = 69; { 0x45 Bad table delete request (exact prob unknown) } - ERRCODE_INVALIDINDEXCREATE = 70; { 0x46 Bad index create request (exact prob unknown) } - ERRCODE_INVALIDINDEXDELETE = 71; { 0x47 Bad index delete request (exact prob unknown) } - ERRCODE_INVALIDTABLE = 72; { 0x48 Invalid table name specified } - ERRCODE_MULTIRESULTS = 73; { 0X49 Multi results } - ERRCODE_INVALIDTIME = 74; { 0X4A Multi results } - ERRCODE_INVALIDDATE = 75; { 0X4B Multi results } - ERRCODE_INVALIDTIMESTAMP = 76; { 0X4C Multi results } - ERRCODE_DIFFERENTPATH = 77; { 0X4d Tables in different paths } - ERRCODE_MISMATCHARGS = 78; { 0x4e MisMatch in the # of arguments } - ERRCODE_FUNCTIONNOTFOUND = 79; { 0x4f Loaderlib cant find a func in the DLL (bad version?) } - ERRCODE_MUSTUSEBASEORDER = 80; { 0x50 Must use baseorder for this operation } - ERRCODE_INVALIDPROCEDURENAME = 81; { 0x51 Invalid procedure name } - ERRCODE_INVALIDFLDMAP = 82; { 0x52 invalid field map } - - - DBIERR_OUTOFRANGE = (ERRBASE_INVALIDREQ + ERRCODE_OUTOFRANGE); - DBIERR_INVALIDPARAM = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDPARAM); - DBIERR_INVALIDFILENAME = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDFILENAME); - DBIERR_NOSUCHFILE = (ERRBASE_INVALIDREQ + ERRCODE_NOSUCHFILE); - DBIERR_INVALIDOPTION = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDOPTION); - DBIERR_INVALIDHNDL = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDHNDL); - DBIERR_UNKNOWNTBLTYPE = (ERRBASE_INVALIDREQ + ERRCODE_UNKNOWNTBLTYPE); - DBIERR_UNKNOWNFILE = (ERRBASE_INVALIDREQ + ERRCODE_UNKNOWNFILE); - DBIERR_PRIMARYKEYREDEFINE = (ERRBASE_INVALIDREQ + ERRCODE_PRIMARYKEYREDEFINE); - DBIERR_INVALIDRINTDESCNUM = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDRINTDESCNUM); - DBIERR_KEYFLDTYPEMISMATCH = (ERRBASE_INVALIDREQ + ERRCODE_KEYFLDTYPEMISMATCH); - DBIERR_INVALIDMODIFYREQUEST = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDMODIFYREQUEST); - DBIERR_NOSUCHINDEX = (ERRBASE_INVALIDREQ + ERRCODE_NOSUCHINDEX); - DBIERR_INVALIDBLOBOFFSET = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDBLOBOFFSET); - DBIERR_INVALIDDESCNUM = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDDESCNUM); - DBIERR_INVALIDFLDTYPE = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDFLDTYPE); - DBIERR_INVALIDFLDDESC = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDFLDDESC); - DBIERR_INVALIDFLDXFORM = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDFLDXFORM); - DBIERR_INVALIDRECSTRUCT = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDRECSTRUCT); - DBIERR_INVALIDDESC = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDDESC); - DBIERR_INVALIDINDEXSTRUCT = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDINDEXSTRUCT); - DBIERR_INVALIDVCHKSTRUCT = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDVCHKSTRUCT); - DBIERR_INVALIDRINTSTRUCT = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDRINTSTRUCT); - DBIERR_INVALIDRESTRTBLORDER = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDRESTRTBLORDER); - DBIERR_NAMENOTUNIQUE = (ERRBASE_INVALIDREQ + ERRCODE_NAMENOTUNIQUE); - DBIERR_INDEXNAMEREQUIRED = (ERRBASE_INVALIDREQ + ERRCODE_INDEXNAMEREQUIRED); - DBIERR_INVALIDSESHANDLE = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDSESHANDLE); - DBIERR_INVALIDRESTROP = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDRESTROP); - DBIERR_UNKNOWNDRIVER = (ERRBASE_INVALIDREQ + ERRCODE_UNKNOWNDRIVER); - DBIERR_UNKNOWNDB = (ERRBASE_INVALIDREQ + ERRCODE_UNKNOWNDB); - DBIERR_INVALIDPASSWORD = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDPASSWORD); - DBIERR_NOCALLBACK = (ERRBASE_INVALIDREQ + ERRCODE_NOCALLBACK); - DBIERR_INVALIDCALLBACKBUFLEN = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDCALLBACKBUFLEN ); - DBIERR_INVALIDDIR = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDDIR); - DBIERR_INVALIDXLATION = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDXLATION); - DBIERR_DIFFERENTTABLES = (ERRBASE_INVALIDREQ + ERRCODE_DIFFERENTTABLES); - DBIERR_INVALIDBOOKMARK = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDBOOKMARK); - DBIERR_INVALIDINDEXNAME = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDINDEXNAME); - DBIERR_INVALIDIDXDESC = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDIDXDESC); - DBIERR_NOSUCHTABLE = (ERRBASE_INVALIDREQ + ERRCODE_NOSUCHTABLE); - DBIERR_USECOUNT = (ERRBASE_INVALIDREQ + ERRCODE_USECOUNT); - DBIERR_INVALIDKEY = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDKEY); - DBIERR_INDEXEXISTS = (ERRBASE_INVALIDREQ + ERRCODE_INDEXEXISTS); - DBIERR_INDEXOPEN = (ERRBASE_INVALIDREQ + ERRCODE_INDEXOPEN); - DBIERR_INVALIDBLOBLEN = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDBLOBLEN); - DBIERR_INVALIDBLOBHANDLE = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDBLOBHANDLE); - DBIERR_TABLEOPEN = (ERRBASE_INVALIDREQ + ERRCODE_TABLEOPEN); - DBIERR_NEEDRESTRUCTURE = (ERRBASE_INVALIDREQ + ERRCODE_NEEDRESTRUCTURE); - DBIERR_INVALIDMODE = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDMODE); - DBIERR_CANNOTCLOSE = (ERRBASE_INVALIDREQ + ERRCODE_CANNOTCLOSE); - DBIERR_ACTIVEINDEX = (ERRBASE_INVALIDREQ + ERRCODE_ACTIVEINDEX); - DBIERR_INVALIDUSRPASS = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDUSRPASS); - DBIERR_MULTILEVELCASCADE = (ERRBASE_INVALIDREQ + ERRCODE_MULTILEVELCASCADE); - DBIERR_INVALIDFIELDNAME = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDFIELDNAME); - DBIERR_INVALIDTABLENAME = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDTABLENAME); - DBIERR_INVALIDLINKEXPR = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDLINKEXPR); - DBIERR_NAMERESERVED = (ERRBASE_INVALIDREQ + ERRCODE_NAMERESERVED); - DBIERR_INVALIDFILEEXTN = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDFILEEXTN); - DBIERR_INVALIDLANGDRV = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDLANGDRV); - DBIERR_ALIASNOTOPEN = (ERRBASE_INVALIDREQ + ERRCODE_ALIASNOTOPEN); - DBIERR_INCOMPATRECSTRUCTS = (ERRBASE_INVALIDREQ + ERRCODE_INCOMPATRECSTRUCTS); - DBIERR_RESERVEDOSNAME = (ERRBASE_INVALIDREQ + ERRCODE_RESERVEDDOSNAME); - DBIERR_DESTMUSTBEINDEXED = (ERRBASE_INVALIDREQ + ERRCODE_DESTMUSTBEINDEXED); - DBIERR_INVALIDINDEXTYPE = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDINDEXTYPE); - DBIERR_LANGDRVMISMATCH = (ERRBASE_INVALIDREQ + ERRCODE_LANGDRVMISMATCH); - DBIERR_NOSUCHFILTER = (ERRBASE_INVALIDREQ + ERRCODE_NOSUCHFILTER); - DBIERR_INVALIDFILTER = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDFILTER); - DBIERR_INVALIDTABLECREATE = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDTABLECREATE); - DBIERR_INVALIDTABLEDELETE = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDTABLEDELETE); - DBIERR_INVALIDINDEXCREATE = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDINDEXCREATE); - DBIERR_INVALIDINDEXDELETE = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDINDEXDELETE); - DBIERR_INVALIDTABLE = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDTABLE); - DBIERR_MULTIRESULTS = (ERRBASE_INVALIDREQ + ERRCODE_MULTIRESULTS); - DBIERR_INVALIDTIME = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDTIME); - DBIERR_INVALIDDATE = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDDATE); - DBIERR_INVALIDTIMESTAMP = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDTIMESTAMP); - DBIERR_DIFFERENTPATH = (ERRBASE_INVALIDREQ + ERRCODE_DIFFERENTPATH); - DBIERR_MISMATCHARGS = (ERRBASE_INVALIDREQ + ERRCODE_MISMATCHARGS); - DBIERR_FUNCTIONNOTFOUND = (ERRBASE_INVALIDREQ + ERRCODE_FUNCTIONNOTFOUND); - DBIERR_MUSTUSEBASEORDER = (ERRBASE_INVALIDREQ + ERRCODE_MUSTUSEBASEORDER); - DBIERR_INVALIDPROCEDURENAME = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDPROCEDURENAME); - DBIERR_INVALIDFLDMAP = (ERRBASE_INVALIDREQ + ERRCODE_INVALIDFLDMAP); - -{ ERRCAT_LOCKCONFLICT } -{ =================== } - - ERRCODE_LOCKED = 1; - ERRCODE_UNLOCKFAILED = 2; - ERRCODE_FILEBUSY = 3; - ERRCODE_DIRBUSY = 4; - ERRCODE_FILELOCKED = 5; - ERRCODE_DIRLOCKED = 6; - ERRCODE_ALREADYLOCKED = 7; - ERRCODE_NOTLOCKED = 8; - ERRCODE_LOCKTIMEOUT = 9; - ERRCODE_GROUPLOCKED = 10; { 0x0a } - ERRCODE_LOSTTBLLOCK = 11; { 0x0b } - ERRCODE_LOSTEXCLACCESS = 12; { 0x0c } - ERRCODE_NEEDEXCLACCESS = 13; { 0x0d } - ERRCODE_RECGROUPCONFLICT = 14; { 0x0e } - ERRCODE_DEADLOCK = 15; - ERRCODE_ACTIVETRAN = 16; - ERRCODE_NOACTIVETRAN = 17; - ERRCODE_RECLOCKFAILED = 18; - ERRCODE_OPTRECLOCKFAILED = 19; - ERRCODE_OPTRECLOCKRECDEL = 20; - ERRCODE_LOCKEDRECS = 21; - ERRCODE_NEEDWRITELOCK = 22; - - DBIERR_LOCKED = (ERRBASE_LOCKCONFLICT + ERRCODE_LOCKED); - DBIERR_UNLOCKFAILED = (ERRBASE_LOCKCONFLICT + ERRCODE_UNLOCKFAILED); - DBIERR_FILEBUSY = (ERRBASE_LOCKCONFLICT + ERRCODE_FILEBUSY); - DBIERR_DIRBUSY = (ERRBASE_LOCKCONFLICT + ERRCODE_DIRBUSY); - DBIERR_FILELOCKED = (ERRBASE_LOCKCONFLICT + ERRCODE_FILELOCKED); - DBIERR_DIRLOCKED = (ERRBASE_LOCKCONFLICT + ERRCODE_DIRLOCKED); - DBIERR_ALREADYLOCKED = (ERRBASE_LOCKCONFLICT + ERRCODE_ALREADYLOCKED); - DBIERR_NOTLOCKED = (ERRBASE_LOCKCONFLICT + ERRCODE_NOTLOCKED); - DBIERR_LOCKTIMEOUT = (ERRBASE_LOCKCONFLICT + ERRCODE_LOCKTIMEOUT); - DBIERR_GROUPLOCKED = (ERRBASE_LOCKCONFLICT + ERRCODE_GROUPLOCKED); - DBIERR_LOSTTBLLOCK = (ERRBASE_LOCKCONFLICT + ERRCODE_LOSTTBLLOCK); - DBIERR_LOSTEXCLACCESS = (ERRBASE_LOCKCONFLICT + ERRCODE_LOSTEXCLACCESS); - DBIERR_NEEDEXCLACCESS = (ERRBASE_LOCKCONFLICT + ERRCODE_NEEDEXCLACCESS); - DBIERR_RECGROUPCONFLICT = (ERRBASE_LOCKCONFLICT + ERRCODE_RECGROUPCONFLICT); - DBIERR_DEADLOCK = (ERRBASE_LOCKCONFLICT + ERRCODE_DEADLOCK); - DBIERR_ACTIVETRAN = (ERRBASE_LOCKCONFLICT + ERRCODE_ACTIVETRAN); - DBIERR_NOACTIVETRAN = (ERRBASE_LOCKCONFLICT + ERRCODE_NOACTIVETRAN); - DBIERR_RECLOCKFAILED = (ERRBASE_LOCKCONFLICT + ERRCODE_RECLOCKFAILED); - DBIERR_OPTRECLOCKFAILED = (ERRBASE_LOCKCONFLICT + ERRCODE_OPTRECLOCKFAILED); - DBIERR_OPTRECLOCKRECDEL = (ERRBASE_LOCKCONFLICT + ERRCODE_OPTRECLOCKRECDEL); - -{ ERRCAT_SECURITY } -{ =============== } - - ERRCODE_NOTSUFFFIELDRIGHTS = 1; { Not sufficient field rights for operation } - ERRCODE_NOTSUFFTABLERIGHTS = 2; { Not sufficient table rights for operation } - ERRCODE_NOTSUFFFAMILYRIGHTS = 3; { Not sufficient family rights for operation } - ERRCODE_READONLYDIR = 4; { Is a read-only directory } - ERRCODE_READONLYDB = 5; { Database is read-only } - ERRCODE_READONLYFLD = 6; { Trying to modify read-only field } - ERRCODE_TBLENCRYPTED = 7; { Table is encrypted (dBASE only) } - ERRCODE_NOTSUFFSQLRIGHTS = 8; { Not sufficient sql rights for operation } - - - DBIERR_NOTSUFFFIELDRIGHTS = (ERRBASE_SEC + ERRCODE_NOTSUFFFIELDRIGHTS); - DBIERR_NOTSUFFTABLERIGHTS = (ERRBASE_SEC + ERRCODE_NOTSUFFTABLERIGHTS); - DBIERR_NOTSUFFFAMILYRIGHTS = (ERRBASE_SEC + ERRCODE_NOTSUFFFAMILYRIGHTS); - DBIERR_READONLYDIR = (ERRBASE_SEC + ERRCODE_READONLYDIR); - DBIERR_READONLYDB = (ERRBASE_SEC + ERRCODE_READONLYDB); - DBIERR_READONLYFLD = (ERRBASE_SEC + ERRCODE_READONLYFLD); - DBIERR_TBLENCRYPTED = (ERRBASE_SEC + ERRCODE_TBLENCRYPTED); - DBIERR_NOTSUFFSQLRIGHTS = (ERRBASE_SEC + ERRCODE_NOTSUFFSQLRIGHTS); - - -{ ERRCAT_INVALIDCONTEXT } -{ ===================== } - - ERRCODE_NOTABLOB = 1; { Field is not a blob } - ERRCODE_BLOBOPENED = 2; { Blob already opened } - ERRCODE_BLOBNOTOPENED = 3; { Blob not opened } - ERRCODE_NA = 4; { Operation not applicable } - ERRCODE_NOTINDEXED = 5; { Table is not indexed } - ERRCODE_NOTINITIALIZED = 6; { Engine not initialized } - ERRCODE_MULTIPLEINIT = 7; { Attempt to re-initialize engine } - ERRCODE_NOTSAMESESSION = 8; { Attempt to mix objs from diff ses } - ERRCODE_PDXDRIVERNOTACTIVE = 9; { Paradox driver not active } - ERRCODE_DRIVERNOTLOADED = 10; { 0x0a Driver not loaded } - ERRCODE_TABLEREADONLY = 11; { 0x0b Table is read only } - ERRCODE_NOASSOCINDEX = 12; { 0x0c No index associated with the cursor } - ERRCODE_HASOPENCURSORS = 13; { 0x0d Has open cursors } - ERRCODE_NOTABLESUPPORT = 14; { 0x0e Op cannot be done on this table } - ERRCODE_INDEXREADONLY = 15; { 0x0f Index is read only } - ERRCODE_NOUNIQUERECS = 16; { 0x10 Records are not unique } - ERRCODE_NOTCURSESSION = 17; { 0x11 Not the current/active session } - ERRCODE_INVALIDKEYWORD = 18; { 0x12 Invalid use of keyword. } - ERRCODE_CONNECTINUSE = 19; { 0x13 Connection in use } - ERRCODE_CONNECTNOTSHARED = 20; { 0x14 Passthru SQL connection not share } - - - DBIERR_NOTABLOB = (ERRBASE_IC + ERRCODE_NOTABLOB); - DBIERR_BLOBOPENED = (ERRBASE_IC + ERRCODE_BLOBOPENED); - DBIERR_BLOBNOTOPENED = (ERRBASE_IC + ERRCODE_BLOBNOTOPENED); - DBIERR_NA = (ERRBASE_IC + ERRCODE_NA); - DBIERR_NOTINDEXED = (ERRBASE_IC + ERRCODE_NOTINDEXED); - DBIERR_NOTINITIALIZED = (ERRBASE_IC + ERRCODE_NOTINITIALIZED); - DBIERR_MULTIPLEINIT = (ERRBASE_IC + ERRCODE_MULTIPLEINIT); - DBIERR_NOTSAMESESSION = (ERRBASE_IC + ERRCODE_NOTSAMESESSION); - DBIERR_PDXDRIVERNOTACTIVE = (ERRBASE_IC + ERRCODE_PDXDRIVERNOTACTIVE); - DBIERR_DRIVERNOTLOADED = (ERRBASE_IC + ERRCODE_DRIVERNOTLOADED); - DBIERR_TABLEREADONLY = (ERRBASE_IC + ERRCODE_TABLEREADONLY); - DBIERR_NOASSOCINDEX = (ERRBASE_IC + ERRCODE_NOASSOCINDEX); - DBIERR_HASOPENCURSORS = (ERRBASE_IC + ERRCODE_HASOPENCURSORS); - DBIERR_NOTABLESUPPORT = (ERRBASE_IC + ERRCODE_NOTABLESUPPORT); - DBIERR_INDEXREADONLY = (ERRBASE_IC + ERRCODE_INDEXREADONLY); - DBIERR_NOUNIQUERECS = (ERRBASE_IC + ERRCODE_NOUNIQUERECS); - DBIERR_NOTCURSESSION = (ERRBASE_IC + ERRCODE_NOTCURSESSION); - DBIERR_INVALIDKEYWORD = (ERRBASE_IC + ERRCODE_INVALIDKEYWORD); - DBIERR_CONNECTINUSE = (ERRBASE_IC + ERRCODE_CONNECTINUSE); - DBIERR_CONNECTNOTSHARED = (ERRBASE_IC + ERRCODE_CONNECTNOTSHARED); - - -{ ERRCAT_OS } -{ ========= } -{ DOS extended errors: } - - ERRCODE_OSEINVFNC = 1; { Invalid function number } - ERRCODE_OSENOENT = 2; { No such file or directory } - ERRCODE_OSENOPATH = 3; { Path not found } - ERRCODE_OSEMFILE = 4; { Too many open files } - ERRCODE_OSEACCES = 5; { Permission denied } - ERRCODE_OSEBADF = 6; { Bad file number } - ERRCODE_OSECONTR = 7; { Memory blocks destroyed } - ERRCODE_OSENOMEM = 8; { Not enough core } - ERRCODE_OSEINVMEM = 9; { Invalid memory block address } - ERRCODE_OSEINVENV = 10; { 0x0a Invalid environment } - ERRCODE_OSEINVFMT = 11; { 0x0b Invalid format } - ERRCODE_OSEINVACC = 12; { 0x0c Invalid access code } - ERRCODE_OSEINVDAT = 13; { 0x0d Invalid data } - ERRCODE_OSENODEV = 15; { 0x0f No such device } - ERRCODE_OSECURDIR = 16; { 0x10 Attempt to remove curdir } - ERRCODE_OSENOTSAM = 17; { 0x11 Not same device } - ERRCODE_OSENMFILE = 18; { 0x12 No more files } - ERRCODE_OSEINVAL = 19; { 0x13 Invalid argument } - ERRCODE_OSE2BIG = 20; { 0x14 Arg list too long } - ERRCODE_OSENOEXEC = 21; { 0x15 Exec format error } - ERRCODE_OSEXDEV = 22; { 0x16 Cross-device link } - ERRCODE_OSEDOM = 33; { 0x21 Math argument } - ERRCODE_OSERANGE = 34; { 0x22 Result to large } - ERRCODE_OSEEXIST = 35; { 0x23 File already exists } - ERRCODE_OSUNKNOWN = 39; { 0x27 Unkown | illegal error from rtl } - - ERRCODE_OSSHAREVIOL = 50; { 0x32 Share viol, ext. err 0x20 } - ERRCODE_OSLOCKVIOL = 51; { 0x33 Lock viol, ext. err 0x21 } - ERRCODE_OSINT24FAIL = 52; { 0x34 INT24 called } - ERRCODE_OSDRIVENOTREADY = 53; { 0x35 Drive not ready } - - - -{ OTHER Os errors: } -{ 1. idapi errors } -{ 2. errors from non-dos systems ( i.e. NOVELL ) } - - ERRCODE_NOTEXACT = 100; { 0x64 Not exact read/write } - ERRCODE_OSNETERR = 101; { 0x65 Generic network error } - ERRCODE_OSUNKNOWNSRVERR = 102; { 0x66 Error from file server } - ERRCODE_SERVERNOMEMORY = 103; { 0x67 Server out of memory } - ERRCODE_OSALREADYLOCKED = 104; { 0x68 Record already locked (by you) } - ERRCODE_OSNOTLOCKED = 105; { 0x69 Record not locked } - ERRCODE_NOSERVERSW = 106; { 0x6a Server software not running the workstation/server } - - - DBIERR_OSEINVFNC = ( ERRBASE_OS + ERRCODE_OSEINVFNC ); - DBIERR_OSENOENT = ( ERRBASE_OS + ERRCODE_OSENOENT ); - DBIERR_OSENOPATH = ( ERRBASE_OS + ERRCODE_OSENOPATH ); - DBIERR_OSEMFILE = ( ERRBASE_OS + ERRCODE_OSEMFILE ); - DBIERR_OSEACCES = ( ERRBASE_OS + ERRCODE_OSEACCES ); - DBIERR_OSEBADF = ( ERRBASE_OS + ERRCODE_OSEBADF ); - DBIERR_OSECONTR = ( ERRBASE_OS + ERRCODE_OSECONTR ); - DBIERR_OSENOMEM = ( ERRBASE_OS + ERRCODE_OSENOMEM ); - DBIERR_OSEINVMEM = ( ERRBASE_OS + ERRCODE_OSEINVMEM ); - DBIERR_OSEINVENV = ( ERRBASE_OS + ERRCODE_OSEINVENV ); - DBIERR_OSEINVFMT = ( ERRBASE_OS + ERRCODE_OSEINVFMT ); - DBIERR_OSEINVACC = ( ERRBASE_OS + ERRCODE_OSEINVACC ); - DBIERR_OSEINVDAT = ( ERRBASE_OS + ERRCODE_OSEINVDAT ); - DBIERR_OSENODEV = ( ERRBASE_OS + ERRCODE_OSENODEV ); - DBIERR_OSECURDIR = ( ERRBASE_OS + ERRCODE_OSECURDIR ); - DBIERR_OSENOTSAM = ( ERRBASE_OS + ERRCODE_OSENOTSAM ); - DBIERR_OSENMFILE = ( ERRBASE_OS + ERRCODE_OSENMFILE ); - DBIERR_OSEINVAL = ( ERRBASE_OS + ERRCODE_OSEINVAL ); - DBIERR_OSE2BIG = ( ERRBASE_OS + ERRCODE_OSE2BIG ); - DBIERR_OSENOEXEC = ( ERRBASE_OS + ERRCODE_OSENOEXEC ); - DBIERR_OSEXDEV = ( ERRBASE_OS + ERRCODE_OSEXDEV ); - DBIERR_OSEDOM = ( ERRBASE_OS + ERRCODE_OSEDOM ); - DBIERR_OSERANGE = ( ERRBASE_OS + ERRCODE_OSERANGE ); - DBIERR_OSEEXIST = ( ERRBASE_OS + ERRCODE_OSEEXIST ); - DBIERR_OSUNKNOWN = ( ERRBASE_OS + ERRCODE_OSUNKNOWN ); - DBIERR_OSSHAREVIOL = ( ERRBASE_OS + ERRCODE_OSSHAREVIOL ); - DBIERR_OSLOCKVIOL = ( ERRBASE_OS + ERRCODE_OSLOCKVIOL ); - DBIERR_OSNETERR = ( ERRBASE_OS + ERRCODE_OSNETERR ); - DBIERR_OSINT24FAIL = ( ERRBASE_OS + ERRCODE_OSINT24FAIL ); - DBIERR_OSDRIVENOTREADY = ( ERRBASE_OS + ERRCODE_OSDRIVENOTREADY ); - - - DBIERR_NOTEXACT = ( ERRBASE_OS + ERRCODE_NOTEXACT ); - DBIERR_OSUNKNOWNSRVERR = ( ERRBASE_OS + ERRCODE_OSUNKNOWNSRVERR ); - DBIERR_SERVERNOMEMORY = ( ERRBASE_OS + ERRCODE_SERVERNOMEMORY ); - DBIERR_OSALREADYLOCKED = ( ERRBASE_OS + ERRCODE_OSALREADYLOCKED ); - DBIERR_OSNOTLOCKED = ( ERRBASE_OS + ERRCODE_OSNOTLOCKED ); - DBIERR_NOSERVERSW = ( ERRBASE_OS + ERRCODE_NOSERVERSW); - -{ ERRCAT_NETWORK } -{ ============== } - - ERRCODE_NETINITERR = 1; { Net init failed } - ERRCODE_NETUSERLIMIT = 2; { Net user limit exceeded } - ERRCODE_NETFILEVERSION = 3; { Wrong net file version } - ERRCODE_NETFILELOCKED = 4; { Not able to lock net file } - ERRCODE_DIRNOTPRIVATE = 5; - ERRCODE_NETMULTIPLE = 6; { Multiple net files in use } - ERRCODE_NETUNKNOWN = 7; { Unknown net error } - ERRCODE_SHAREDFILE = 8; { Cannot access a shared file } - ERRCODE_SHARENOTLOADED = 9; { Share not loaded } - ERRCODE_NOTONANETWORK = 10; { 0x0a Not an Network } - ERRCODE_SQLCOMMLOST = 11; { 0x0b Lost Communication with SQL server } - ERRCODE_SERVERCOMMLOST = 12; { 0x0c Lost Communication with IDAPI server } - ERRCODE_SQLSERVERNOTFOUND = 13; { 0x0d SQL Server not found } - ERRCODE_SERVERNOTFOUND = 14; { 0x0e SQL Server not found } - - DBIERR_NETINITERR = (ERRBASE_NETWORK + ERRCODE_NETINITERR); - DBIERR_NETUSERLIMIT = (ERRBASE_NETWORK + ERRCODE_NETUSERLIMIT); - DBIERR_NETFILEVERSION = (ERRBASE_NETWORK + ERRCODE_NETFILEVERSION); - DBIERR_NETFILELOCKED = (ERRBASE_NETWORK + ERRCODE_NETFILELOCKED); - DBIERR_DIRNOTPRIVATE = (ERRBASE_NETWORK + ERRCODE_DIRNOTPRIVATE); - DBIERR_NETMULTIPLE = (ERRBASE_NETWORK + ERRCODE_NETMULTIPLE); - DBIERR_NETUNKNOWN = (ERRBASE_NETWORK + ERRCODE_NETUNKNOWN); - DBIERR_SHAREDFILE = (ERRBASE_NETWORK + ERRCODE_SHAREDFILE); - DBIERR_SHARENOTLOADED = (ERRBASE_NETWORK + ERRCODE_SHARENOTLOADED); - DBIERR_NOTONANETWORK = (ERRBASE_NETWORK + ERRCODE_NOTONANETWORK); - DBIERR_SQLCOMMLOST = (ERRBASE_NETWORK + ERRCODE_SQLCOMMLOST); - DBIERR_SERVERCOMMLOST = (ERRBASE_NETWORK + ERRCODE_SERVERCOMMLOST); - DBIERR_SQLSERVERNOTFOUND = (ERRBASE_NETWORK + ERRCODE_SQLSERVERNOTFOUND); - DBIERR_SERVERNOTFOUND = (ERRBASE_NETWORK + ERRCODE_SERVERNOTFOUND); - -{ ERRCAT_DRIVER } -{ ============= } - - ERRCODE_WRONGDRVNAME = 1; { Wrong driver name } - ERRCODE_WRONGSYSVER = 2; { Wrong system version } - ERRCODE_WRONGDRVVER = 3; { Wrong driver version } - ERRCODE_WRONGDRVTYPE = 4; { Wrong driver type } - ERRCODE_CANNOTLOADDRV = 5; { Can not load driver } - ERRCODE_CANNOTLOADLDDRV = 6; { Can not load language driver } - ERRCODE_VENDINITFAIL = 7; { Vendor init failure } - ERRCODE_DRIVERRESTRICTED = 8; { Client not enabled for this driver } - - - DBIERR_WRONGDRVNAME = (ERRBASE_DRIVER + ERRCODE_WRONGDRVNAME); - DBIERR_WRONGSYSVER = (ERRBASE_DRIVER + ERRCODE_WRONGSYSVER); - DBIERR_WRONGDRVVER = (ERRBASE_DRIVER + ERRCODE_WRONGDRVVER); - DBIERR_WRONGDRVTYPE = (ERRBASE_DRIVER + ERRCODE_WRONGDRVTYPE); - DBIERR_CANNOTLOADDRV = (ERRBASE_DRIVER + ERRCODE_CANNOTLOADDRV); - DBIERR_CANNOTLOADLDDRV = (ERRBASE_DRIVER + ERRCODE_CANNOTLOADLDDRV); - DBIERR_VENDINITFAIL = (ERRBASE_DRIVER + ERRCODE_VENDINITFAIL); - DBIERR_DRIVERRESTRICTED = (ERRBASE_DRIVER + ERRCODE_DRIVERRESTRICTED); - - -{ ERRCAT_QUERY } -{ ============ } - - - - DBICODE_AMBJOASY = 1; { obsolete } - DBICODE_AMBJOSYM = 2; { obsolete } - DBICODE_AMBOUTEX = 3; - DBICODE_AMBOUTPR = 4; { obsolete } - DBICODE_AMBSYMAS = 5; { obsolete } - DBICODE_ASETOPER = 6; - DBICODE_AVENUMDA = 7; - DBICODE_BADEXPR1 = 8; - DBICODE_BADFLDOR = 9; - DBICODE_BADVNAME = 10; { 0x0a } - DBICODE_BITMAPER = 11; { 0x0b } - DBICODE_CALCBADR = 12; { 0x0c } - DBICODE_CALCTYPE = 13; { 0x0d } - DBICODE_CHGTO1TI = 14; { 0x0e } - DBICODE_CHGTOCHG = 15; { 0x0f } - DBICODE_CHGTOEXP = 16; { 0x10 } - DBICODE_CHGTOINS = 17; { 0x11 } - DBICODE_CHGTONEW = 18; { 0x12 } - DBICODE_CHGTOVAL = 19; { 0x13 } - DBICODE_CHKMRKFI = 20; { 0x14 } - DBICODE_CHNAMBIG = 21; { 0x15 } - DBICODE_CHUNKERR = 22; { 0x16 } - DBICODE_COLUM255 = 23; { 0x17 } - DBICODE_CONAFTAS = 24; { 0x18 } - DBICODE_DEL1TIME = 25; { 0x19 } - DBICODE_DELAMBIG = 26; { 0x1a } - DBICODE_DELFRDEL = 27; { 0x1b } - DBICODE_EGFLDTYP = 28; { 0x1c } - DBICODE_EXAMINOR = 29; { 0x1d } - DBICODE_EXPRTYPS = 30; { 0x1e } - DBICODE_EXTRACOM = 31; { 0x1f } - DBICODE_EXTRAORO = 32; { 0x20 } - DBICODE_EXTRAQRO = 33; { 0x21 } - DBICODE_FIND1ATT = 34; { 0x22 } - DBICODE_FINDANST = 35; { 0x23 } - DBICODE_GRPNOSET = 36; { 0x24 } - DBICODE_GRPSTROW = 37; { 0x25 } - DBICODE_IDFINLCO = 38; { 0x26 } - DBICODE_IDFPERLI = 39; { 0x27 } - DBICODE_INANEXPR = 40; { 0x28 } - DBICODE_INS1TIME = 41; { 0x29 } - DBICODE_INSAMBIG = 42; { 0x2a } - DBICODE_INSDELCH = 43; { 0x2b } - DBICODE_INSEXPRR = 44; { 0x2c } - DBICODE_INSTOINS = 45; { 0x2d } - DBICODE_ISARRAY = 46; { 0x2e } - DBICODE_LABELERR = 47; { 0x2f } - DBICODE_LINKCALC = 48; { 0x30 } - DBICODE_LNGVNAME = 49; { 0x31 } - DBICODE_LONGQURY = 50; { 0x32 } - DBICODE_MEMVPROC = 51; { 0x33 } - DBICODE_MISNGCOM = 52; { 0x34 } - DBICODE_MISNGRPA = 53; { 0x35 } - DBICODE_MISSRTQU = 54; { 0x36 } - DBICODE_NAMTWICE = 55; { 0x37 } - DBICODE_NOCHKMAR = 56; { 0x38 } - DBICODE_NODEFOCC = 57; { 0x39 } - DBICODE_NOGROUPS = 58; { 0x3a } - DBICODE_NONSENSE = 59; { 0x3b } - DBICODE_NOPATTER = 60; { 0x3c } - DBICODE_NOSUCHDA = 61; { 0x3d } - DBICODE_NOVALUE = 62; { 0x3e } - DBICODE_ONLYCONS = 63; { 0x3f } - DBICODE_ONLYSETR = 64; { 0x40 } - DBICODE_OUTSENS1 = 65; { 0x41 } - DBICODE_OUTTWIC1 = 66; { 0x42 } - DBICODE_PAROWCNT = 67; { 0x43 } - DBICODE_PERSEPAR = 68; { 0x44 } - DBICODE_PROCPLSW = 69; { 0x45 } - DBICODE_PWINSRTS = 70; { 0x46 } - DBICODE_PWMODRTS = 71; { 0x47 } - DBICODE_QBEFLDFOUND = 72; { 0x48 } - DBICODE_QBENOFENCE = 73; { 0x49 } - DBICODE_QBENOFENCET = 74; { 0x4a } - DBICODE_QBENOHEADERT = 75; { 0x4b } - DBICODE_QBENOTAB = 76; { 0x4c } - DBICODE_QBENUMCOLS = 77; { 0x4d } - DBICODE_QBEOPENTAB = 78; { 0x4e } - DBICODE_QBETWICE = 79; { 0x4f } - DBICODE_QRYNOANSWER = 80; { 0x50 } - DBICODE_QRYNOTPREP = 81; { 0x51 } - DBICODE_QUAINDEL = 82; { 0x52 } - DBICODE_QUAININS = 83; { 0x53 } - DBICODE_RAGININS = 84; { 0x54 } - DBICODE_RAGINSET = 85; { 0x55 } - DBICODE_ROWUSERR = 86; { 0x56 } - DBICODE_SETEXPEC = 87; { 0x57 } - DBICODE_SETVAMB1 = 88; { 0x58 } - DBICODE_SETVBAD1 = 89; { 0x59 } - DBICODE_SETVDEF1 = 90; { 0x5a } - DBICODE_SUMNUMBE = 91; { 0x5b } - DBICODE_TBLISWP3 = 92; { 0x5c } - DBICODE_TOKENNOT = 93; { 0x5d } - DBICODE_TWOOUTR1 = 94; { 0x5e } - DBICODE_TYPEMISM = 95; { 0x5f } - DBICODE_UNRELQ1 = 96; { 0x60 } - DBICODE_UNUSEDST = 97; { 0x61 } - DBICODE_USEINSDE = 98; { 0x62 } - DBICODE_USEOFCHG = 99; { 0x63 } - DBICODE_VARMUSTF = 100; { 0x64 } - DBICODE_REGISTER = 101; { 0x65 } - DBICODE_LONGEXPR = 102; { 0x66 } - DBICODE_REFRESH = 103; { 0x67 } - DBICODE_CANCEXCEPT = 104; { 0x68 } - DBICODE_DBEXCEPT = 105; { 0x69 } - DBICODE_MEMEXCEPT = 106; { 0x6a } - DBICODE_FATALEXCEPT = 107; { 0x6b } - DBICODE_QRYNIY = 108; { 0x6c } - DBICODE_BADFORMAT = 109; { 0x6d } - DBICODE_QRYEMPTY = 110; { 0x6e } - DBICODE_NOQRYTOPREP = 111; { 0x6f } - DBICODE_BUFFTOOSMALL = 112; { 0x70 } - DBICODE_QRYNOTPARSE = 113; { 0x71 } - DBICODE_NOTHANDLE = 114; { 0x72 } - DBICODE_QRYSYNTERR = 115; { 0x73 } - DBICODE_QXFLDCOUNT = 116; { 0x74 } - DBICODE_QXFLDSYMNOTFOUND = 117; { 0x75 } - DBICODE_QXTBLSYMNOTFOUND = 118; { 0x76 } - DBICODE_BLOBTERM = 119; { 0x77 } - DBICODE_BLOBERR = 120; { 0x78 } - DBICODE_RESTARTQRY = 121; { 0x79 } - DBICODE_UNKNOWNANSTYPE = 122; { 0x7a } - -{ Internal QBE use Only. } - DBICODE_SQLG_MDIST = 123; { 0x7b } - DBICODE_SQLG_NOARI = 124; { 0x7c } - DBICODE_SQLG_LIKEN = 125; { 0x7d } - DBICODE_SQLG_ALPHO = 126; { 0x7e } - DBICODE_SQLG_DATEO = 127; { 0x7f } - DBICODE_SQLG_RELOP = 128; { 0x80 } - DBICODE_SQLG_ONLYC = 129; { 0x81 } - DBICODE_SQLG_CNTLN = 130; { 0x82 } - DBICODE_SQLG_CHINI = 131; { 0x83 } - DBICODE_SQLG_UNION = 132; { 0x84 } - DBICODE_SQLG_SLFIN = 133; { 0x85 } - DBICODE_SQLG_OTJVR = 134; { 0x86 } - DBICODE_SQLG_STROW = 135; { 0x87 } - DBICODE_SQLG_QUANT = 136; { 0x88 } - DBICODE_SQLG_REGSO = 137; { 0x89 } - DBICODE_SQLG_COUNT = 138; { 0x8a } - DBICODE_SQLG_AVERA = 139; { 0x8b } - DBICODE_SQLG_DATEA = 140; { 0x8c } - DBICODE_SQLG_BADPT = 141; { 0x8d } - DBICODE_SQLG_RELPA = 142; { 0x8e } - DBICODE_SQLG_PATRN = 143; { 0x8f } - DBICODE_SQLG_FNDSU = 144; { 0x90 } - DBICODE_SQLG_IFDCS = 145; { 0x91 } - DBICODE_SQLG_IDCCO = 146; { 0x92 } - DBICODE_SQLG_ONLYI = 147; { 0x93 } - DBICODE_SQLG_SQLDIALECT = 148; { 0x94 } - DBICODE_SQLG_NOQUERY = 149; { 0x95 } -{ End of Internal. } - - DBICODE_BLOBGROUP = 150; { 0x96 } - DBICODE_QRYNOPROP = 151; { 0x97 } - DBICODE_ANSTYPNOTSUP = 152; { 0x98 } - DBICODE_ANSALIASNOTSUP = 153; { 0x99 } - DBICODE_INSBLOBREQ = 154; { 0x9a } - DBICODE_CHGUNIQUENDXREQ = 155; { 0x9b } - DBICODE_DELUNIQUENDXREQ = 156; { 0x9c } - DBICODE_SQLNOFULLUPDATE = 157; { 0x9d } - DBICODE_CANTEXECREMOTE = 158; { 0x9e } - DBICODE_UNEXPECTEDEOC = 159; { 0x9f } - DBICODE_SQLPARAMNOTSET = 160; { 0xA0 } - DBICODE_QUERYTOOLONG = 161; { 0xA1 } - -{ Errors added for localsql } - DBICODE_NOSUCHRELORALIAS = 170; - DBICODE_TYPEAMBIGUITY = 171; - DBICODE_ORDERBYNOTAPROJ = 172; - DBICODE_SQLPARSE = 173; - DBICODE_CONSTRAINTFAILED = 174; - DBICODE_NOTGROUPINGFIELD = 175; - DBICODE_UDFNOTDEFINED = 176; - DBICODE_UDFERROR = 177; - DBICODE_SINGLEROWERROR = 178; - DBICODE_GROUPEXPR = 179; - DBICODE_QUERYTEXT = 180; - DBICODE_ANSIJOINSUP = 181; - DBICODE_DISTUNION = 182; - DBICODE_GROUPBYREQ = 183; - DBICODE_INSUPDAUTOIC = 184; - DBICODE_UPDREFINTSINGLE = 185; - - DBIERR_AMBJOASY = (ERRBASE_QUERY+DBICODE_AMBJOASY); - DBIERR_AMBJOSYM = (ERRBASE_QUERY+DBICODE_AMBJOSYM); - DBIERR_AMBOUTEX = (ERRBASE_QUERY+DBICODE_AMBOUTEX); - DBIERR_AMBOUTPR = (ERRBASE_QUERY+DBICODE_AMBOUTPR); - DBIERR_AMBSYMAS = (ERRBASE_QUERY+DBICODE_AMBSYMAS); - DBIERR_ASETOPER = (ERRBASE_QUERY+DBICODE_ASETOPER); - DBIERR_AVENUMDA = (ERRBASE_QUERY+DBICODE_AVENUMDA); - DBIERR_BADEXPR1 = (ERRBASE_QUERY+DBICODE_BADEXPR1); - DBIERR_BADFLDOR = (ERRBASE_QUERY+DBICODE_BADFLDOR); - DBIERR_BADVNAME = (ERRBASE_QUERY+DBICODE_BADVNAME); - DBIERR_BITMAPER = (ERRBASE_QUERY+DBICODE_BITMAPER); - DBIERR_CALCBADR = (ERRBASE_QUERY+DBICODE_CALCBADR); - DBIERR_CALCTYPE = (ERRBASE_QUERY+DBICODE_CALCTYPE); - DBIERR_CHGTO1TI = (ERRBASE_QUERY+DBICODE_CHGTO1TI); - DBIERR_CHGTOCHG = (ERRBASE_QUERY+DBICODE_CHGTOCHG); - DBIERR_CHGTOEXP = (ERRBASE_QUERY+DBICODE_CHGTOEXP); - DBIERR_CHGTOINS = (ERRBASE_QUERY+DBICODE_CHGTOINS); - DBIERR_CHGTONEW = (ERRBASE_QUERY+DBICODE_CHGTONEW); - DBIERR_CHGTOVAL = (ERRBASE_QUERY+DBICODE_CHGTOVAL); - DBIERR_CHKMRKFI = (ERRBASE_QUERY+DBICODE_CHKMRKFI); - DBIERR_CHNAMBIG = (ERRBASE_QUERY+DBICODE_CHNAMBIG); - DBIERR_CHUNKERR = (ERRBASE_QUERY+DBICODE_CHUNKERR); - DBIERR_COLUM255 = (ERRBASE_QUERY+DBICODE_COLUM255); - DBIERR_CONAFTAS = (ERRBASE_QUERY+DBICODE_CONAFTAS); - DBIERR_DEL1TIME = (ERRBASE_QUERY+DBICODE_DEL1TIME); - DBIERR_DELAMBIG = (ERRBASE_QUERY+DBICODE_DELAMBIG); - DBIERR_DELFRDEL = (ERRBASE_QUERY+DBICODE_DELFRDEL); - DBIERR_EGFLDTYP = (ERRBASE_QUERY+DBICODE_EGFLDTYP); - DBIERR_EXAMINOR = (ERRBASE_QUERY+DBICODE_EXAMINOR); - DBIERR_EXPRTYPS = (ERRBASE_QUERY+DBICODE_EXPRTYPS); - DBIERR_EXTRACOM = (ERRBASE_QUERY+DBICODE_EXTRACOM); - DBIERR_EXTRAORO = (ERRBASE_QUERY+DBICODE_EXTRAORO); - DBIERR_EXTRAQRO = (ERRBASE_QUERY+DBICODE_EXTRAQRO); - DBIERR_FIND1ATT = (ERRBASE_QUERY+DBICODE_FIND1ATT); - DBIERR_FINDANST = (ERRBASE_QUERY+DBICODE_FINDANST); - DBIERR_GRPNOSET = (ERRBASE_QUERY+DBICODE_GRPNOSET); - DBIERR_GRPSTROW = (ERRBASE_QUERY+DBICODE_GRPSTROW); - DBIERR_IDFINLCO = (ERRBASE_QUERY+DBICODE_IDFINLCO); - DBIERR_IDFPERLI = (ERRBASE_QUERY+DBICODE_IDFPERLI); - DBIERR_INANEXPR = (ERRBASE_QUERY+DBICODE_INANEXPR); - DBIERR_INS1TIME = (ERRBASE_QUERY+DBICODE_INS1TIME); - DBIERR_INSAMBIG = (ERRBASE_QUERY+DBICODE_INSAMBIG); - DBIERR_INSDELCH = (ERRBASE_QUERY+DBICODE_INSDELCH); - DBIERR_INSEXPRR = (ERRBASE_QUERY+DBICODE_INSEXPRR); - DBIERR_INSTOINS = (ERRBASE_QUERY+DBICODE_INSTOINS); - DBIERR_ISARRAY = (ERRBASE_QUERY+DBICODE_ISARRAY); - DBIERR_LABELERR = (ERRBASE_QUERY+DBICODE_LABELERR); - DBIERR_LINKCALC = (ERRBASE_QUERY+DBICODE_LINKCALC); - DBIERR_LNGVNAME = (ERRBASE_QUERY+DBICODE_LNGVNAME); - DBIERR_LONGQURY = (ERRBASE_QUERY+DBICODE_LONGQURY); - DBIERR_MEMVPROC = (ERRBASE_QUERY+DBICODE_MEMVPROC); - DBIERR_MISNGCOM = (ERRBASE_QUERY+DBICODE_MISNGCOM); - DBIERR_MISNGRPA = (ERRBASE_QUERY+DBICODE_MISNGRPA); - DBIERR_MISSRTQU = (ERRBASE_QUERY+DBICODE_MISSRTQU); - DBIERR_NAMTWICE = (ERRBASE_QUERY+DBICODE_NAMTWICE); - DBIERR_NOCHKMAR = (ERRBASE_QUERY+DBICODE_NOCHKMAR); - DBIERR_NODEFOCC = (ERRBASE_QUERY+DBICODE_NODEFOCC); - DBIERR_NOGROUPS = (ERRBASE_QUERY+DBICODE_NOGROUPS); - DBIERR_NONSENSE = (ERRBASE_QUERY+DBICODE_NONSENSE); - DBIERR_NOPATTER = (ERRBASE_QUERY+DBICODE_NOPATTER); - DBIERR_NOSUCHDA = (ERRBASE_QUERY+DBICODE_NOSUCHDA); - DBIERR_NOVALUE = (ERRBASE_QUERY+DBICODE_NOVALUE); - DBIERR_ONLYCONS = (ERRBASE_QUERY+DBICODE_ONLYCONS); - DBIERR_ONLYSETR = (ERRBASE_QUERY+DBICODE_ONLYSETR); - DBIERR_OUTSENS1 = (ERRBASE_QUERY+DBICODE_OUTSENS1); - DBIERR_OUTTWIC1 = (ERRBASE_QUERY+DBICODE_OUTTWIC1); - DBIERR_PAROWCNT = (ERRBASE_QUERY+DBICODE_PAROWCNT); - DBIERR_PERSEPAR = (ERRBASE_QUERY+DBICODE_PERSEPAR); - DBIERR_PROCPLSW = (ERRBASE_QUERY+DBICODE_PROCPLSW); - DBIERR_PWINSRTS = (ERRBASE_QUERY+DBICODE_PWINSRTS); - DBIERR_PWMODRTS = (ERRBASE_QUERY+DBICODE_PWMODRTS); - DBIERR_QBEFLDFOUND = (ERRBASE_QUERY+DBICODE_QBEFLDFOUND); - DBIERR_QBENOFENCE = (ERRBASE_QUERY+DBICODE_QBENOFENCE); - DBIERR_QBENOFENCET = (ERRBASE_QUERY+DBICODE_QBENOFENCET); - DBIERR_QBENOHEADERT = (ERRBASE_QUERY+DBICODE_QBENOHEADERT); - DBIERR_QBENOTAB = (ERRBASE_QUERY+DBICODE_QBENOTAB); - DBIERR_QBENUMCOLS = (ERRBASE_QUERY+DBICODE_QBENUMCOLS); - DBIERR_QBEOPENTAB = (ERRBASE_QUERY+DBICODE_QBEOPENTAB); - DBIERR_QBETWICE = (ERRBASE_QUERY+DBICODE_QBETWICE); - DBIERR_QRYNOANSWER = (ERRBASE_QUERY+DBICODE_QRYNOANSWER); - DBIERR_QRYNOTPREP = (ERRBASE_QUERY+DBICODE_QRYNOTPREP); - DBIERR_QUAINDEL = (ERRBASE_QUERY+DBICODE_QUAINDEL); - DBIERR_QUAININS = (ERRBASE_QUERY+DBICODE_QUAININS); - DBIERR_RAGININS = (ERRBASE_QUERY+DBICODE_RAGININS); - DBIERR_RAGINSET = (ERRBASE_QUERY+DBICODE_RAGINSET); - DBIERR_ROWUSERR = (ERRBASE_QUERY+DBICODE_ROWUSERR); - DBIERR_SETEXPEC = (ERRBASE_QUERY+DBICODE_SETEXPEC); - DBIERR_SETVAMB1 = (ERRBASE_QUERY+DBICODE_SETVAMB1); - DBIERR_SETVBAD1 = (ERRBASE_QUERY+DBICODE_SETVBAD1); - DBIERR_SETVDEF1 = (ERRBASE_QUERY+DBICODE_SETVDEF1); - DBIERR_SUMNUMBE = (ERRBASE_QUERY+DBICODE_SUMNUMBE); - DBIERR_TBLISWP3 = (ERRBASE_QUERY+DBICODE_TBLISWP3); - DBIERR_TOKENNOT = (ERRBASE_QUERY+DBICODE_TOKENNOT); - DBIERR_TWOOUTR1 = (ERRBASE_QUERY+DBICODE_TWOOUTR1); - DBIERR_TYPEMISM = (ERRBASE_QUERY+DBICODE_TYPEMISM); - DBIERR_UNRELQ1 = (ERRBASE_QUERY+DBICODE_UNRELQ1); - DBIERR_UNUSEDST = (ERRBASE_QUERY+DBICODE_UNUSEDST); - DBIERR_USEINSDE = (ERRBASE_QUERY+DBICODE_USEINSDE); - DBIERR_USEOFCHG = (ERRBASE_QUERY+DBICODE_USEOFCHG); - DBIERR_VARMUSTF = (ERRBASE_QUERY+DBICODE_VARMUSTF); - DBIERR_REGISTER = (ERRBASE_QUERY+DBICODE_REGISTER); - DBIERR_LONGEXPR = (ERRBASE_QUERY+DBICODE_LONGEXPR); - DBIERR_REFRESH = (ERRBASE_QUERY+DBICODE_REFRESH); - DBIERR_CANCEXCEPT = (ERRBASE_QUERY+DBICODE_CANCEXCEPT); - DBIERR_DBEXCEPT = (ERRBASE_QUERY+DBICODE_DBEXCEPT); - DBIERR_MEMEXCEPT = (ERRBASE_QUERY+DBICODE_MEMEXCEPT); - DBIERR_FATALEXCEPT = (ERRBASE_QUERY+DBICODE_FATALEXCEPT); - DBIERR_QRYNIY = (ERRBASE_QUERY+ DBICODE_QRYNIY); - DBIERR_BADFORMAT = (ERRBASE_QUERY+ DBICODE_BADFORMAT); - DBIERR_QRYEMPTY = (ERRBASE_QUERY+ DBICODE_QRYEMPTY); - DBIERR_NOQRYTOPREP = (ERRBASE_QUERY+ DBICODE_NOQRYTOPREP); - DBIERR_BUFFTOOSMALL = (ERRBASE_QUERY+ DBICODE_BUFFTOOSMALL); - DBIERR_QRYNOTPARSE = (ERRBASE_QUERY+ DBICODE_QRYNOTPARSE); - DBIERR_NOTHANDLE = (ERRBASE_QUERY+ DBICODE_NOTHANDLE); - DBIERR_QRYSYNTERR = (ERRBASE_QUERY+ DBICODE_QRYSYNTERR); - DBIERR_QXFLDCOUNT = (ERRBASE_QUERY+ DBICODE_QXFLDCOUNT); - DBIERR_QXFLDSYMNOTFOUND = (ERRBASE_QUERY+ DBICODE_QXFLDSYMNOTFOUND); - DBIERR_QXTBLSYMNOTFOUND = (ERRBASE_QUERY+ DBICODE_QXTBLSYMNOTFOUND); - DBIERR_BLOBTERM = (ERRBASE_QUERY+ DBICODE_BLOBTERM); - DBIERR_BLOBERR = (ERRBASE_QUERY+ DBICODE_BLOBERR); - DBIERR_RESTARTQRY = (ERRBASE_QUERY+ DBICODE_RESTARTQRY); - DBIERR_UNKNOWNANSTYPE = (ERRBASE_QUERY+ DBICODE_UNKNOWNANSTYPE); - DBIERR_SQLG_MDIST = (ERRBASE_QUERY+ DBICODE_SQLG_MDIST); - DBIERR_SQLG_NOARI = (ERRBASE_QUERY+ DBICODE_SQLG_NOARI); - DBIERR_SQLG_LIKEN = (ERRBASE_QUERY+ DBICODE_SQLG_LIKEN); - DBIERR_SQLG_ALPHO = (ERRBASE_QUERY+ DBICODE_SQLG_ALPHO); - DBIERR_SQLG_DATEO = (ERRBASE_QUERY+ DBICODE_SQLG_DATEO); - DBIERR_SQLG_RELOP = (ERRBASE_QUERY+ DBICODE_SQLG_RELOP); - DBIERR_SQLG_ONLYC = (ERRBASE_QUERY+ DBICODE_SQLG_ONLYC); - DBIERR_SQLG_CNTLN = (ERRBASE_QUERY+ DBICODE_SQLG_CNTLN); - DBIERR_SQLG_CHINI = (ERRBASE_QUERY+ DBICODE_SQLG_CHINI); - DBIERR_SQLG_UNION = (ERRBASE_QUERY+ DBICODE_SQLG_UNION); - DBIERR_SQLG_SLFIN = (ERRBASE_QUERY+ DBICODE_SQLG_SLFIN); - DBIERR_SQLG_OTJVR = (ERRBASE_QUERY+ DBICODE_SQLG_OTJVR); - DBIERR_SQLG_STROW = (ERRBASE_QUERY+ DBICODE_SQLG_STROW); - DBIERR_SQLG_QUANT = (ERRBASE_QUERY+ DBICODE_SQLG_QUANT); - DBIERR_SQLG_REGSO = (ERRBASE_QUERY+ DBICODE_SQLG_REGSO); - DBIERR_SQLG_COUNT = (ERRBASE_QUERY+ DBICODE_SQLG_COUNT); - DBIERR_SQLG_AVERA = (ERRBASE_QUERY+ DBICODE_SQLG_AVERA); - DBIERR_SQLG_DATEA = (ERRBASE_QUERY+ DBICODE_SQLG_DATEA); - DBIERR_SQLG_BADPT = (ERRBASE_QUERY+ DBICODE_SQLG_BADPT); - DBIERR_SQLG_RELPA = (ERRBASE_QUERY+ DBICODE_SQLG_RELPA); - DBIERR_SQLG_PATRN = (ERRBASE_QUERY+ DBICODE_SQLG_PATRN); - DBIERR_SQLG_FNDSU = (ERRBASE_QUERY+ DBICODE_SQLG_FNDSU); - DBIERR_SQLG_IFDCS = (ERRBASE_QUERY+ DBICODE_SQLG_IFDCS); - DBIERR_SQLG_IDCCO = (ERRBASE_QUERY+ DBICODE_SQLG_IDCCO); - DBIERR_SQLG_ONLYI = (ERRBASE_QUERY+ DBICODE_SQLG_ONLYI); - DBIERR_SQLG_SQLDIALECT = (ERRBASE_QUERY+ DBICODE_SQLG_SQLDIALECT); - DBIERR_SQLG_NOQUERY = (ERRBASE_QUERY+ DBICODE_SQLG_NOQUERY); - DBIERR_BLOBGROUP = (ERRBASE_QUERY+ DBICODE_BLOBGROUP); - DBIERR_QRYNOPROP = (ERRBASE_QUERY+DBICODE_QRYNOPROP); - DBIERR_ANSTYPNOTSUP = (ERRBASE_QUERY+DBICODE_ANSTYPNOTSUP); - DBIERR_ANSALIASNOTSUP = (ERRBASE_QUERY+DBICODE_ANSALIASNOTSUP); - DBIERR_INSBLOBREQ = (ERRBASE_QUERY+DBICODE_INSBLOBREQ ); { 0x9a } - DBIERR_CHGUNIQUENDXREQ = (ERRBASE_QUERY+DBICODE_CHGUNIQUENDXREQ); { 0x9b } - DBIERR_DELUNIQUENDXREQ = (ERRBASE_QUERY+DBICODE_DELUNIQUENDXREQ); { 0x9c } - DBIERR_SQLNOFULLUPDATE = (ERRBASE_QUERY+DBICODE_SQLNOFULLUPDATE); { 0x9d } - DBIERR_CANTEXECREMOTE = (ERRBASE_QUERY+DBICODE_CANTEXECREMOTE); { 0x9e } - DBIERR_UNEXPECTEDEOC = (ERRBASE_QUERY+DBICODE_UNEXPECTEDEOC); - DBIERR_SQLPARAMNOTSET = (ERRBASE_QUERY+DBICODE_SQLPARAMNOTSET); - DBIERR_QUERYTOOLONG = (ERRBASE_QUERY+DBICODE_QUERYTOOLONG); - - DBIERR_NOSUCHRELORALIAS = (ERRBASE_QUERY+DBICODE_NOSUCHRELORALIAS); - DBIERR_TYPEAMBIGUITY = (ERRBASE_QUERY+DBICODE_TYPEAMBIGUITY); - DBIERR_ORDERBYNOTAPROJ = (ERRBASE_QUERY+DBICODE_ORDERBYNOTAPROJ); - DBIERR_SQLPARSE = (ERRBASE_QUERY+DBICODE_SQLPARSE); - DBIERR_CONSTRAINTFAILED = (ERRBASE_QUERY+DBICODE_CONSTRAINTFAILED); - DBIERR_NOTGROUPINGFIELD = (ERRBASE_QUERY+DBICODE_NOTGROUPINGFIELD); - DBIERR_UDFNOTDEFINED = (ERRBASE_QUERY+DBICODE_UDFNOTDEFINED); - DBIERR_UDFERROR = (ERRBASE_QUERY+DBICODE_UDFERROR); - DBIERR_SINGLEROWERROR = (ERRBASE_QUERY+DBICODE_SINGLEROWERROR); - DBIERR_GROUPEXPR = (ERRBASE_QUERY+DBICODE_GROUPEXPR); - DBIERR_QUERYTEXT = (ERRBASE_QUERY+DBICODE_QUERYTEXT); - DBIERR_ANSIJOINSUP = (ERRBASE_QUERY+DBICODE_ANSIJOINSUP); - DBIERR_DISTUNION = (ERRBASE_QUERY+DBICODE_DISTUNION); - DBIERR_GROUPBYREQ = (ERRBASE_QUERY+DBICODE_GROUPBYREQ); - DBIERR_INSUPDAUTOINC = (ERRBASE_QUERY+DBICODE_INSUPDAUTOIC); - DBIERR_UPDREFINTSINGLE = (ERRBASE_QUERY+DBICODE_UPDREFINTSINGLE); - - - -{ END_OF_QUERY_MESSAGES } - -{ ERRCAT_VERSION } -{ ============== } - - ERRCODE_INTERFACEVER = 1; { Interface mismatch } - ERRCODE_INDEXOUTOFDATE = 2; { Index is out of date } - ERRCODE_OLDVERSION = 3; { Older version (see context) } - ERRCODE_VALFILEINVALID = 4; { Val. file is out of date } - ERRCODE_BLOBVERSION = 5; { Old Blob file version } - ERRCODE_ENGQRYMISMATCH = 6; { Query and IDAPI are mismatched } - ERRCODE_SERVERVERSION = 7; { Server is incompatible version } - ERRCODE_TABLELEVEL = 8; { Higher table level required } - - DBIERR_INTERFACEVER = (ERRBASE_VERSION + ERRCODE_INTERFACEVER); - DBIERR_INDEXOUTOFDATE = (ERRBASE_VERSION + ERRCODE_INDEXOUTOFDATE); - DBIERR_OLDVERSION = (ERRBASE_VERSION + ERRCODE_OLDVERSION); - DBIERR_VALFILEINVALID = (ERRBASE_VERSION + ERRCODE_VALFILEINVALID); - DBIERR_BLOBVERSION = (ERRBASE_VERSION + ERRCODE_BLOBVERSION); - DBIERR_ENGQRYMISMATCH = (ERRBASE_VERSION + ERRCODE_ENGQRYMISMATCH); - DBIERR_SERVERVERSION = (ERRBASE_VERSION + ERRCODE_SERVERVERSION); - DBIERR_TABLELEVEL = (ERRBASE_VERSION + ERRCODE_TABLELEVEL); - -{ ERRCAT_CAPABILITY } -{ ================= } - - ERRCODE_NOTSUPPORTED = 1; { Capability not supported } - ERRCODE_NIY = 2; { Not Implemented Yet } - ERRCODE_TABLESQL = 3; { Cannot access SQL replica } - ERRCODE_SEARCHCOLREQD = 4; { Searchable (Non-blob column) required } - ERRCODE_NOMULTCONNECT = 5; { Multiple connections not supported } - ERRCODE_NODBASEEXPR = 6; { Full dBASE Expressions not supported } - - DBIERR_NOTSUPPORTED = (ERRBASE_CAPABILITY + ERRCODE_NOTSUPPORTED); - DBIERR_NIY = (ERRBASE_CAPABILITY + ERRCODE_NIY); - DBIERR_TABLESQL = (ERRBASE_CAPABILITY + ERRCODE_TABLESQL); - DBIERR_SEARCHCOLREQD = (ERRBASE_CAPABILITY + ERRCODE_SEARCHCOLREQD); - DBIERR_NOMULTCONNECT = (ERRBASE_CAPABILITY + ERRCODE_NOMULTCONNECT); - DBIERR_NODBASEEXPR = (ERRBASE_CAPABILITY + ERRCODE_NODBASEEXPR); - -{ ERRCAT_CONFIG } -{ ============= } - - ERRCODE_INVALIDDBSPEC = 1; - ERRCODE_UNKNOWNDBTYPE = 2; - ERRCODE_INVALIDSYSDATA = 3; - ERRCODE_UNKNOWNNETTYPE = 4; - ERRCODE_NOTONTHATNET = 5; - ERRCODE_INVALIDCFGPARAM = 6; { Generic invalid config param } - - - DBIERR_INVALIDDBSPEC = (ERRBASE_CONFIG + ERRCODE_INVALIDDBSPEC); - DBIERR_UNKNOWNDBTYPE = (ERRBASE_CONFIG + ERRCODE_UNKNOWNDBTYPE); - DBIERR_INVALIDSYSDATA = (ERRBASE_CONFIG + ERRCODE_INVALIDSYSDATA); - DBIERR_UNKNOWNNETTYPE = (ERRBASE_CONFIG + ERRCODE_UNKNOWNNETTYPE); - DBIERR_NOTONTHATNET = (ERRBASE_CONFIG + ERRCODE_NOTONTHATNET); - DBIERR_INVALIDCFGPARAM = (ERRBASE_CONFIG + ERRCODE_INVALIDCFGPARAM); - -{ ERRCAT_WARNING non-fatal warnings: } -{ warn user of action, or ask for optional behavior } -{ ================================================= } - ERRCODE_OBJIMPLICITLYDROPPED = 1; - ERRCODE_OBJMAYBETRUNCATED = 2; - ERRCODE_OBJIMPLICITLYMODIFIED = 3; - ERRCODE_VALIDATEDATA = 4; - ERRCODE_VALFIELDMODIFIED = 5; - ERRCODE_TABLELEVELCHANGED = 6; - ERRCODE_COPYLINKEDTABLES = 7; - ERRCODE_OTHERSERVERLOADED = 8; - ERRCODE_OBJIMPLICITLYTRUNCATED = 9; - ERRCODE_VCHKMAYNOTBEENFORCED = 10; - ERRCODE_MULTIPLEUNIQRECS = 11; - ERRCODE_FIELDMUSTBETRIMMED = 12; - - DBIERR_OBJIMPLICITLYDROPPED = ( ERRBASE_WARNING + ERRCODE_OBJIMPLICITLYDROPPED); - DBIERR_OBJMAYBETRUNCATED = ( ERRBASE_WARNING + ERRCODE_OBJMAYBETRUNCATED); - DBIERR_OBJIMPLICITLYMODIFIED = ( ERRBASE_WARNING + ERRCODE_OBJIMPLICITLYMODIFIED); - DBIERR_VALIDATEDATA = ( ERRBASE_WARNING + ERRCODE_VALIDATEDATA); - DBIERR_VALFIELDMODIFIED = ( ERRBASE_WARNING + ERRCODE_VALFIELDMODIFIED); - DBIERR_TABLELEVELCHANGED = ( ERRBASE_WARNING + ERRCODE_TABLELEVELCHANGED); - DBIERR_COPYLINKEDTABLES = ( ERRBASE_WARNING + ERRCODE_COPYLINKEDTABLES); - DBIERR_OTHERSERVERLOADED = ( ERRBASE_WARNING + ERRCODE_OTHERSERVERLOADED); - DBIERR_OBJIMPLICITLYTRUNCATED = ( ERRBASE_WARNING + ERRCODE_OBJIMPLICITLYTRUNCATED); - DBIERR_VCHKMAYNOTBEENFORCED = ( ERRBASE_WARNING + ERRCODE_VCHKMAYNOTBEENFORCED ); - DBIERR_MULTIPLEUNIQRECS = ( ERRBASE_WARNING + ERRCODE_MULTIPLEUNIQRECS ); - DBIERR_FIELDMUSTBETRIMMED = ( ERRBASE_WARNING + ERRCODE_FIELDMUSTBETRIMMED ); - - -{ ERRCAT_OTHER } -{ ============ } - - ERRCODE_FILEEXISTS = 1; { File already exsits } - ERRCODE_BLOBMODIFIED = 2; { Another user modified Blob } - ERRCODE_UNKNOWNSQL = 3; { Unknown SQL error } - ERRCODE_TABLEEXISTS = 4; { Table already exsits } - ERRCODE_PDX10TABLE = 5; { Paradox 1.0 tables not supported } - ERRCODE_UPDATEABORT = 6; { Update operation aborted } - - - DBIERR_FILEEXISTS = (ERRBASE_OTHER + ERRCODE_FILEEXISTS); - DBIERR_BLOBMODIFIED = (ERRBASE_OTHER + ERRCODE_BLOBMODIFIED); - DBIERR_UNKNOWNSQL = (ERRBASE_OTHER + ERRCODE_UNKNOWNSQL); - DBIERR_TABLEEXISTS = (ERRBASE_OTHER + ERRCODE_TABLEEXISTS); - DBIERR_PDX10TABLE = (ERRBASE_OTHER + ERRCODE_PDX10TABLE); - DBIERR_UPDATEABORT = (ERRBASE_OTHER + ERRCODE_UPDATEABORT); - - -{ ERRCAT_COMPATIBILITY } -{ ==================== } - - ERRCODE_DIFFSORTORDER = 1; { Sortorders not compatible } - ERRCODE_DIRINUSEBYOLDVER = 2; { Directory in use by old version } - ERRCODE_PDX35LDDRIVER = 3; { Needs Pdox 3.5 compatible language driver } - - DBIERR_DIFFSORTORDER = (ERRBASE_COMPATIBILITY + ERRCODE_DIFFSORTORDER); - DBIERR_DIRINUSEBYOLDVER = (ERRBASE_COMPATIBILITY + ERRCODE_DIRINUSEBYOLDVER); - DBIERR_PDX35LDDRIVER = (ERRBASE_COMPATIBILITY + ERRCODE_PDX35LDDRIVER); - -{ ERRCAT_OPTPARAM } -{ =============== } - - ERRCODE_REQOPTPARAM = 1; { Required optional parameter missing } - ERRCODE_INVALIDOPTPARAM = 2; { Optional param out-of-range or bad } - - - DBIERR_REQOPTPARAM = (ERRBASE_OPTPARAM + ERRCODE_REQOPTPARAM); - DBIERR_INVALIDOPTPARAM = (ERRBASE_OPTPARAM + ERRCODE_INVALIDOPTPARAM); - -{ ERRCAT_REPOSITORY } -{ ================= } - - ERRCODE_REPOSITORYCORRUPT = 1; { Data Repository is corrupt } - ERRCODE_INFOBLOBCORRUPT = 2; { Info Blob corrupted } - ERRCODE_SCHEMACORRUPT = 3; { DR Schema is corrupt } - ERRCODE_ATTRTYPEEXISTS = 4; { Attribute Type exists } - ERRCODE_INVALIDOBJTYPE = 5; { Invalid Object Type } - ERRCODE_INVALIDRELATIONTYPE = 6; { Invalid Relation Type } - ERRCODE_VIEWEXISTS = 7; { View already exists } - ERRCODE_NOSUCHVIEW = 8; { No such View exists } - ERRCODE_INVALIDRECCONSTRAINT = 9; { Invalid Record Constraint } - ERRCODE_LDBCONNECTION = 10; { Object is in a Logical DB } - ERRCODE_REPOSITORYEXISTS = 11; { Repository already exists } - ERRCODE_NOSUCHREPOSITORY = 12; { Repository does not exist } - ERRCODE_REPOSITORYDBMISSING = 13; { Repository database does not exist } - ERRCODE_REPOSITORYOUTOFDATE = 14; { Repository info is out of date } - ERRCODE_REPOSITORYVERSION = 15; { DR Version mismatch } - ERRCODE_REPOSITORYNAME = 16; { Invalid Repository name } - ERRCODE_DEPENDENTOBJECTS = 17; { Dependent Objects exist } - ERRCODE_RELATIONLIMIT = 18; { Too many Relationships for this Object Type } - ERRCODE_RELATIONSHIPSEXIST = 19; { Relationships to the Object exist } - ERRCODE_EXCHANGEFILECORRUPT = 20; { Exchange File Corrupt } - ERRCODE_EXCHANGEFILEVERSION = 21; { Exchange File Version Mismatch } - ERRCODE_TYPEMISMATCH = 22; { Exchange File and Repository Types don't match } - ERRCODE_OBJECTEXISTS = 23; { Object Exists in the Target Repository } - ERRCODE_REPOSITORYACCESS = 24; { Access to Repository Denied } - ERRCODE_REPOSITORYCREATE = 25; { Cannot Create Repository } - ERRCODE_DATABASEOPENFAILED = 26; { Cannot Open a Database } - - - DBIERR_REPOSITORYCORRUPT = (ERRBASE_REPOSITORY + ERRCODE_REPOSITORYCORRUPT); - DBIERR_INFOBLOBCORRUPT = (ERRBASE_REPOSITORY + ERRCODE_INFOBLOBCORRUPT); - DBIERR_SCHEMACORRUPT = (ERRBASE_REPOSITORY + ERRCODE_SCHEMACORRUPT); - DBIERR_ATTRTYPEEXISTS = (ERRBASE_REPOSITORY + ERRCODE_ATTRTYPEEXISTS); - DBIERR_INVALIDOBJTYPE = (ERRBASE_REPOSITORY + ERRCODE_INVALIDOBJTYPE); - DBIERR_INVALIDRELATIONTYPE = (ERRBASE_REPOSITORY + ERRCODE_INVALIDRELATIONTYPE); - DBIERR_VIEWEXISTS = (ERRBASE_REPOSITORY + ERRCODE_VIEWEXISTS); - DBIERR_NOSUCHVIEW = (ERRBASE_REPOSITORY + ERRCODE_NOSUCHVIEW); - DBIERR_INVALIDRECCONSTRAINT = (ERRBASE_REPOSITORY + ERRCODE_INVALIDRECCONSTRAINT); - DBIERR_LDBCONNECTION = (ERRBASE_REPOSITORY + ERRCODE_LDBCONNECTION); - DBIERR_REPOSITORYEXISTS = (ERRBASE_REPOSITORY + ERRCODE_REPOSITORYEXISTS); - DBIERR_NOSUCHREPOSITORY = (ERRBASE_REPOSITORY + ERRCODE_NOSUCHREPOSITORY); - DBIERR_REPOSITORYDBMISSING = (ERRBASE_REPOSITORY + ERRCODE_REPOSITORYDBMISSING); - DBIERR_REPOSITORYOUTOFDATE = (ERRBASE_REPOSITORY + ERRCODE_REPOSITORYOUTOFDATE); - DBIERR_REPOSITORYVERSION = (ERRBASE_REPOSITORY + ERRCODE_REPOSITORYVERSION); - DBIERR_REPOSITORYNAME = (ERRBASE_REPOSITORY + ERRCODE_REPOSITORYNAME); - DBIERR_DEPENDENTOBJECTS = (ERRBASE_REPOSITORY + ERRCODE_DEPENDENTOBJECTS); - DBIERR_RELATIONLIMIT = (ERRBASE_REPOSITORY + ERRCODE_RELATIONLIMIT); - DBIERR_RELATIONSHIPSEXIST = (ERRBASE_REPOSITORY + ERRCODE_RELATIONSHIPSEXIST); - DBIERR_EXCHANGEFILECORRUPT = (ERRBASE_REPOSITORY + ERRCODE_EXCHANGEFILECORRUPT); - DBIERR_EXCHANGEFILEVERSION = (ERRBASE_REPOSITORY + ERRCODE_EXCHANGEFILEVERSION); - DBIERR_TYPEMISMATCH = (ERRBASE_REPOSITORY + ERRCODE_TYPEMISMATCH); - DBIERR_OBJECTEXISTS = (ERRBASE_REPOSITORY + ERRCODE_OBJECTEXISTS); - DBIERR_REPOSITORYACCESS = (ERRBASE_REPOSITORY + ERRCODE_REPOSITORYACCESS); - DBIERR_REPOSITORYCREATE = (ERRBASE_REPOSITORY + ERRCODE_REPOSITORYCREATE); - DBIERR_DATABASEOPENFAILED = (ERRBASE_REPOSITORY + ERRCODE_DATABASEOPENFAILED); - -type - DBIDATE = Longint; - DBITIME = Longint; - TIMESTAMP = Double; - -const -{ Field Types (Logical) } - - fldUNKNOWN = 0; - fldZSTRING = 1; { Null terminated string } - fldDATE = 2; { Date (32 bit) } - fldBLOB = 3; { Blob } - fldBOOL = 4; { Boolean (16 bit) } - fldINT16 = 5; { 16 bit signed number } - fldINT32 = 6; { 32 bit signed number } - fldFLOAT = 7; { 64 bit floating point } - fldBCD = 8; { BCD } - fldBYTES = 9; { Fixed number of bytes } - fldTIME = 10; { Time (32 bit) } - fldTIMESTAMP = 11; { Time-stamp (64 bit) } - fldUINT16 = 12; { Unsigned 16 bit integer } - fldUINT32 = 13; { Unsigned 32 bit integer } - fldFLOATIEEE = 14; { 80-bit IEEE float } - fldVARBYTES = 15; { Length prefixed var bytes } - fldLOCKINFO = 16; { Look for LOCKINFO typedef } - fldCURSOR = 17; { For Oracle Cursor type } - fldINT64 = 18; { 64 bit signed number } - fldUINT64 = 19; { Unsigned 64 bit integer } - fldADT = 20; { Abstract datatype (structure) } - fldARRAY = 21; { Array field type } - fldREF = 22; { Reference to ADT } - fldTABLE = 23; { Nested table (reference) } - - {$IFDEF DCC6OrLater} - MaxLogFldTypes = 26; - {$ELSE} - MaxLogFldTypes = 24; { Number of logical fieldtypes } - {$ENDIF} - -{ Sub Types (Logical) } - -{ fldFLOAT subtype } - - fldstMONEY = 21; { Money } - -{ fldBLOB subtypes } - - fldstMEMO = 22; { Text Memo } - fldstBINARY = 23; { Binary data } - fldstFMTMEMO = 24; { Formatted Text } - fldstOLEOBJ = 25; { OLE object (Paradox) } - fldstGRAPHIC = 26; { Graphics object } - fldstDBSOLEOBJ = 27; { dBASE OLE object } - fldstTYPEDBINARY = 28; { Typed Binary data } - fldstACCOLEOBJ = 30; { Access OLE object } - fldstHMEMO = 33; { CLOB } - fldstHBINARY = 34; { BLOB } - fldstBFILE = 36; { BFILE } - -{ fldZSTRING subtype } - - fldstPASSWORD = 1; { Password } - fldstFIXED = 31; { CHAR type } - fldstUNICODE = 32; { Unicode } - -{ fldINT32 subtype } - - fldstAUTOINC = 29; - -{ fldADT subtype } - - fldstADTNestedTable = 35; { ADT for nested table (has no name) } - -{ fldDATE subtype } - fldstADTDATE = 37; { DATE (OCIDate ) with in an ADT } - -{============================================================================} -{ Filter description } -{============================================================================} - -type - pffCANOp = ^ffCANOp; {!!.01} - ffCANOp = ( - canNOTDEFINED, { (*) } - canISBLANK, { CANUnary; is operand blank. (*) } - canNOTBLANK, { CANUnary; is operand not blank. (*) } - canEQ, { CANBinary, CANCompare; equal. (*) } - canNE, { CANBinary; NOT equal. (*) } - canGT, { CANBinary; greater than. (*) } - canLT, { CANBinary; less than. (*) } - canGE, { CANBinary; greater or equal. (*) } - canLE, { CANBinary; less or equal. (*) } - canNOT, { CANUnary; NOT (*) } - canAND, { CANBinary; AND (*) } - canOR, { CANBinary; OR (*) } - canTUPLE2, { CANUnary; Entire record is operand. } - canFIELD2, { CANUnary; operand is field (*) } - canCONST2, { CANUnary; operand is constant (*) } - canMINUS, { CANUnary; minus. } - canADD, { CANBinary; addition. } - canSUB, { CANBinary; subtraction. } - canMUL, { CANBinary; multiplication. } - canDIV, { CANBinary; division. } - canMOD, { CANBinary; modulo division. } - canREM, { CANBinary; remainder of division. } - canSUM, { CANBinary, accumulate sum of. } - canCOUNT, { CANBinary, accumulate count of. } - canMIN, { CANBinary, find minimum of. } - canMAX, { CANBinary, find maximum of. } - canAVG, { CANBinary, find average of. } - canCONT, { CANBinary; provides a link between two } - canUDF2, { CANBinary; invokes a User defined fn } - canCONTINUE2, { CANUnary; Stops evaluating records } - canLIKE, { CANCompare, extended binary compare (*) } - canIN, { CANBinary field in list of values } - canLIST2, { List of constant values of same type } - canUPPER, { CANUnary: upper case } - canLOWER, { CANUnary: lower case } - canFUNC2, { CANFunc: Function } - canLISTELEM2, { CANListElem: List Element } - canASSIGN { CANBinary: 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 } - ); - -{ NODE definitions including misc data structures } -{-------------------------------------------------} - -type - pCANHdr = ^CANHdr; - CANHdr = packed record { Header part common to all (*) } - nodeClass : NODEClass; - canOp : ffCANOp; {!!.01} - end; - - pCANUnary = ^CANUnary; - CANUnary = packed record { Unary Node (*) } - nodeClass : NODEClass; - canOp : ffCANOp; {!!.01} - iOperand1 : Word; { Byte offset of Operand node } - end; - - pCANBinary = ^CANBinary; - CANBinary = packed record { Binary Node (*) } - nodeClass : NODEClass; - canOp : ffCANOp; {!!.01} - iOperand1 : Word; { Byte offset of Op1 } - iOperand2 : Word; { Byte offset of Op2 } - end; - - pCANField = ^CANField; - CANField = packed record { Field } - nodeClass : NODEClass; - canOp : ffCANOp; {!!.01} - iFieldNum : Word; - iNameOffset : Word; { Name offset in Literal pool } - end; - - pCANConst = ^CANConst; - CANConst = packed record { Constant } - nodeClass : NODEClass; - canOp : ffCANOp; {!!.01} - iType : Word; { Constant type. } - iSize : Word; { Constant size. (in bytes) } - iOffset : Word; { Offset in the literal pool. } - end; - - pCANTuple = ^CANTuple; - CANTuple = packed record { Tuple (record) } - nodeClass : NODEClass; - canOp : ffCANOp; {!!.01} - iSize : Word; { Record size. (in bytes) } - end; - - pCANContinue = ^CANContinue; - CANContinue = packed record { Break Node (*) } - nodeClass : NODEClass; - canOp : ffCANOp; {!!.01} - iContOperand : Word; { Continue if operand is true. } - end; - - pCANCompare = ^CANCompare; - CANCompare = packed record { Extended compare Node (text fields) (*) } - nodeClass : NODEClass; - canOp : ffCANOp; { canLIKE, canEQ } {!!.01} - bCaseInsensitive : WordBool; { 3 val: UNKNOWN = "fastest", "native" } - iPartialLen : Word; { Partial fieldlength (0 is full length) } - iOperand1 : Word; { Byte offset of Op1 } - iOperand2 : Word; { Byte offset of Op2 } - end; - - pCANFunc = ^CANFunc; - CANFunc = packed record { Function } - nodeClass : NODEClass; - canOp : ffCANOp; {!!.01} - iNameOffset : Word; { Name offset in Literal pool } - iElemOffset : Word; { Offset of first List Element in Node pool } - end; - - pCANListElem = ^CANListElem; - CANListElem = packed record { List Element } - nodeClass : NODEClass; - canOp : ffCANOp; {!!.01} - iOffset : Word; { Arg offset in Node pool } - iNextOffset : Word; { Offset in Node pool of next ListElem or 0 if end of list } - end; - -{This is the node to be used to pass User defined functions } -const - iLangSQL = 0; { Common SQL dialect } - iDbaseExpr = 2; { This is also the driver ID for dBASE } - -type - pCANUdf = ^CANUdf; - CANUdf = packed record { A user defined function } - nodeClass : NODEClass; - canOp : ffCANOp; {!!.01} - iOffSzFuncName : Word; { Offset in literal pool to Function Name string(0 terminated) } - iOperands : Word; { Byte offset of Operands (concatenated using canCONT) } - iDrvDialect : Word; { Driver Dialect ID for UDF string supplied } - iOffSzUDF : Word; { Offset in literal pool to UDF string (0 terminated) } - end; - - pCANList = ^CANList; - CANList = packed record { List of Constants } - nodeClass : NODEClass; - canOp : ffCANOp; {!!.01} - iType : Word; { Constant type. } - iTotalSize : Word; { Total list size; } - iElemSize : Word; { Size of each elem for fix-width types } - iElems : Word; { Number of elements in list } - iOffset : Word; { Offset in the literal pool to first elem. } - end; - - pCANNode = ^CANNode; - CANNode = packed record - case Integer of - 0: (canHdr : CANHdr); - 1: (canUnary : CANUnary); - 2: (canBinary : CANBinary); - 3: (canField : CANField); - 4: (canConst : CANConst); - 5: (canTuple : CANTuple); - 6: (canContinue : CANContinue); - 7: (canCompare : CANCompare); - 8: (canList : CANList); - 9: (canFunc : CANFunc); - 10: (canListElem : CANListElem); - end; - -{ Linear exression tree} -{----------------------} - -const - CANEXPRVERSION = 2; - -type - ppCANExpr = ^pCANExpr; - pCANExpr = ^CANExpr; - CANExpr = packed record { Expression Tree } - iVer : Word; { Version tag of expression. } - iTotalSize : Word; { Size of this structure } - iNodes : Word; { Number of nodes } - iNodeStart : Word; { Starting offet of Nodes in this } - iLiteralStart : Word; { Starting offset of Literals in this } - end; - -type - pfGENFilter = function ( - ulClientData : Longint; - pRecBuf : Pointer; - iPhyRecNum : Longint - ): SmallInt stdcall; - -implementation - -end. diff --git a/components/flashfiler/sourcelaz/ffsrblob.pas b/components/flashfiler/sourcelaz/ffsrblob.pas deleted file mode 100644 index 03e6760dc..000000000 --- a/components/flashfiler/sourcelaz/ffsrblob.pas +++ /dev/null @@ -1,223 +0,0 @@ -{*********************************************************} -{* FlashFiler: BLOB retrieval & verification 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 ffsrblob; - -interface - -uses - ffllbase, - ffsrbase, - ffsrlock; - -{---Blob retrieval & verification routines---} -function ReadBLOBBlock(FI : PffFileInfo; - TI : PffTransInfo; - const anOffset : TffInt64; - var aOffsetInBlock : TffWord32; {!!.11} - var aReleaseMethod : TffReleaseMethod) - : PffBlock; - { Reads the BLOB block containing the specified offset. This method does - not perform any locking so use it only when the block has previously - been locked and the lock is still in effect. } - -function ReadVfyBlobBlock(FI : PffFileInfo; - TI : PffTransInfo; - const aMarkDirty : Boolean; - const anOffset : TffInt64; - var aOffsetInBlock : TffWord32; {!!.11} - var aReleaseMethod : TffReleaseMethod) - : PffBlock; - -function ReadVfyBlobBlock2(FI : PffFileInfo; - TI : PffTransInfo; - const aMarkDirty : Boolean; - const anOffset : TffInt64; - var aBlockNum : TffWord32; - var aOffsetInBlock : TffWord32; {!!.11} - var aReleaseMethod : TffReleaseMethod) - : PffBlock; - -function ReadVfyBlobBlock3(FI : PffFileInfo; - TI : PffTransInfo; - const aMarkDirty : Boolean; - const anOffset : TffInt64; - var aReleaseMethod : TffReleaseMethod) - : PffBlock; - -implementation - -uses - ffconst, - ffllexcp, - fftbbase; - -{== Block verification routines ======================================} -function ReadBLOBBlock(FI : PffFileInfo; - TI : PffTransInfo; - const anOffset : TffInt64; - var aOffsetInBlock : TffWord32; {!!.11} - var aReleaseMethod : TffReleaseMethod) - : PffBlock; -var - BlockNumber : TffWord32; - BLOBBlock : PffBlock; - BLOBBlockHdr: PffBlockHeaderBLOB absolute BLOBBlock; - TempI64 : TffInt64; -begin - { Assumptions: The block was previously read and successfully verified. - The block was previously locked and the lock is still in - effect. } - with FI^ do begin - - { Get the BLOB block. } - ffShiftI64R(anOffset, fiLog2BlockSize, TempI64); - BlockNumber := TempI64.iLow; - - ffI64MinusInt(anOffset, (BlockNumber shl fiLog2BlockSize), TempI64); - aOffsetInBlock := TempI64.iLow; - BLOBBlock := FI^.fiBufMgr.GetBlock(FI, BlockNumber, TI, false, aReleaseMethod); - end; - Result := BLOBBlock; -end; -{--------} -function ReadVfyBlobBlock(FI : PffFileInfo; - TI : PffTransInfo; - const aMarkDirty : boolean; - const anOffset : TffInt64; - var aOffsetInBlock : TffWord32; {!!.11} - var aReleaseMethod : TffReleaseMethod) - : PffBlock; -var - BlockNumber : TffWord32; - BLOBBlock : PffBlock; - BLOBBlockHdr: PffBlockHeaderBLOB absolute BLOBBlock; - TempI64 : TffInt64; -begin - with FI^ do begin - {verify the BLOB number} - if not FFVerifyBLOBNr(anOffset, fiLog2BlockSize) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBadBLOBNr, [FI^.fiName^, anOffset.iLow, - anOffset.iHigh]); - {now get the BLOB block} - ffShiftI64R(anOffset, fiLog2BlockSize, TempI64); - BlockNumber := TempI64.iLow; - if (BlockNumber <= 0) or (BlockNumber >= fiUsedBlocks) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBadBlockNr, [FI^.fiName^, BlockNumber]); - ffI64MinusInt(anOffset, (BlockNumber shl fiLog2BlockSize), TempI64); - aOffsetInBlock := TempI64.iLow; - BLOBBlock := FFBMGetBlock(FI, TI, BlockNumber, aMarkDirty, aReleaseMethod); - { Verify that it's a BLOB header block. } - with BLOBBlockHdr^ do - if (bhbSignature <> ffc_SigBLOBBlock) or - (bhbThisBlock <> BlockNumber) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBadBLOBBlock, [FI^.fiName^, BlockNumber]); - end; - Result := BLOBBlock; -end; -{--------} -function ReadVfyBlobBlock2(FI : PffFileInfo; - TI : PffTransInfo; - const aMarkDirty : boolean; - const anOffset : TffInt64; - var aBlockNum : TffWord32; - var aOffsetInBlock : TffWord32; {!!.11} - var aReleaseMethod : TffReleaseMethod) - : PffBlock; -var - BLOBBlock : PffBlock; - BLOBBlockHdr: PffBlockHeaderBLOB absolute BLOBBlock; - TempI64 : TffInt64; -begin - with FI^ do begin - {verify the BLOB number} - if not FFVerifyBLOBNr(anOffset, fiLog2BlockSize) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBadBLOBNr, [FI^.fiName^, anOffset.iLow, - anOffset.iHigh]); - {now get the BLOB block} - ffShiftI64R(anOffset, fiLog2BlockSize, TempI64); - aBlockNum := TempI64.iLow; - if (aBlockNum <= 0) or (aBlockNum >= fiUsedBlocks) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBadBlockNr, [FI^.fiName^, aBlockNum]); - ffI64MinusInt(anOffset, (aBlockNum shl fiLog2BlockSize), TempI64); - aOffsetInBlock := TempI64.iLow; - BLOBBlock := FFBMGetBlock(FI, TI, aBlockNum, aMarkDirty, aReleaseMethod); - {verify that it's a BLOB header block} - with BLOBBlockHdr^ do - if (bhbSignature <> ffc_SigBLOBBlock) or - (bhbThisBlock <> aBlockNum) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBadBLOBBlock, [FI^.fiName^, aBlockNum]); - end; - Result := BLOBBlock; -end; -{--------} -function ReadVfyBlobBlock3(FI : PffFileInfo; - TI : PffTransInfo; - const aMarkDirty : boolean; - const anOffset : TffInt64; - var aReleaseMethod : TffReleaseMethod) : PffBlock; -var - BlockNumber : TffWord32; - BLOBBlock : PffBlock; - BLOBBlockHdr: PffBlockHeaderBLOB absolute BLOBBlock; - TempI64 : TffInt64; -begin - with FI^ do begin - {verify the segment number} - if not FFVerifyBLOBNr(anOffset, fiLog2BlockSize) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBadBLOBSeg, [FI^.fiName^, anOffset.iLow, - anOffset.iHigh, '']); - {get the BLOB block} - ffShiftI64R(anOffset, fiLog2BlockSize, TempI64); - BlockNumber := TempI64.iLow; - if (BlockNumber <= 0) or (BlockNumber >= fiUsedBlocks) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBadBlockNr, [FI^.fiName^, BlockNumber]); - BLOBBlock := FFBMGetBlock(FI, TI, BlockNumber, aMarkDirty, aReleaseMethod); - {verify that it's a BLOB block} - with BLOBBlockHdr^ do - if (bhbSignature <> ffc_SigBLOBBlock) or - (bhbThisBlock <> BlockNumber) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBadBLOBBlock, [FI^.fiName^, BlockNumber]); - end; - Result := BLOBBlock; -end; -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/ffsrcfg.pas b/components/flashfiler/sourcelaz/ffsrcfg.pas deleted file mode 100644 index 941c1d790..000000000 --- a/components/flashfiler/sourcelaz/ffsrcfg.pas +++ /dev/null @@ -1,883 +0,0 @@ -{*********************************************************} -{* FlashFiler: Server Configuration Information *} -{*********************************************************} - -(* ***** 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 ffsrcfg; - -interface - -uses - Windows, - SysUtils, - Classes, - ffconst, - ffllbase, - ffllunc, - ffsrmgr, - ffllexcp, - ffllprot, - ffsrintf, - ffsrbase; - -type - PffGeneralInfo = ^TffGeneralInfo; - TffGeneralInfo = packed record -{Begin !!.06} -{$IFDEF IsDelphi} - giServerName : TffNetName; -{$ELSE} - giServerName : TffNetNameShr; -{$ENDIF} -{End !!.06} - giMaxRAM : Longint; - giSingleUser : Boolean; - giIPXSPX : Boolean; - giIPXSPXLFB : Boolean; - giTCPIP : Boolean; - giTCPIPLFB : Boolean; - giTCPPort : Longint; - giUDPPortSr : Longint; - giUDPPortCl : Longint; - giIPXSocketSr : Longint; - giIPXSocketCl : Longint; - giSPXSocket : Longint; - giIsSecure : Boolean; - giAutoUp : Boolean; - giAutoMini : Boolean; - giDebugLog : Boolean; - giAllowEncrypt : Boolean; - giReadOnly : Boolean; - giLastMsgInterval : Longint; - giKAInterval : Longint; - giKARetries : Longint; - giPriority : Longint; - giTCPInterface : Longint; - giNoAutoSaveCfg : Boolean; - giTempStoreSize : Integer; - giCollectEnabled : Boolean; - giCollectFreq : Longint; - end; - -type - TffAliasItem = class(TffUCStrListItem) - protected {private} - FCheckDisk : Boolean; {!!.11} - FPath : PffShStr; - protected - function GetAlias : string; {!!.10} - function GetPath : string; {!!.10} - public - constructor Create(const aAlias : TffName; - const aPath : TffPath; - aCheckDisk : Boolean); {!!.11} - destructor Destroy; override; - - property Alias : string read GetAlias; {!!.10} - property Path : string read GetPath; {!!.10} - property CheckSpace : Boolean {!!.11} - read FCheckDisk; {!!.11} - end; - - TffAliasList = class(TffThreadList) - protected - function GetAliasItem(aInx : Integer) : TffAliasItem; - function GetAliasPath(const aAlias : TffName) : TffPath; - public - procedure AddAlias(aAliasItem : TffAliasItem); - function AliasExists(const aAlias : TffName) : Boolean; - function AliasIndex(const aAlias : TffName) : Integer; - function CheckDiskSpace(const aAlias : TffName) : Boolean; {!!.11} - procedure DeleteAlias(const aAlias : TffName); - - property AliasItem[aInx : Integer] : TffAliasItem - read GetAliasItem; default; - property Path[const aAlias : TffName] : TffPath - read GetAliasPath; - end; - - TffUserItem = class(TffUCStrListItem) - protected {private} - FFirst : PffShStr; - FLast : PffShStr; - FPwdHash : TffWord32; - FRights : TffUserRights; - protected - function GetFirstName : string; {!!.10} - function GetLastName : string; {!!.10} - function GetUserID : string; {!!.10} - public - constructor Create(const aUserID : TffName; - const aLastName : TffName; - const aFirstName : TffName; - aPwdHash : TffWord32; - aRights : TffUserRights); - destructor Destroy; override; - - property FirstName : string read GetFirstName; {!!.10} - property LastName : string read GetLastName; {!!.10} - property PasswordHash : TffWord32 read FPwdHash; - property Rights : TffUserRights read FRights; - property UserID : string read GetUserID; {!!.10} - end; - - TffUserList = class(TffObject) - protected {private} - FUserList : TffList; - protected - function GetUserItem(aInx : integer) : TffUserItem; - function GetUserPwdHash(const aUserID : TffName) : TffWord32; - function GetUserRights(const aUserID : TffName) : TffUserRights; - public - constructor Create; - destructor Destroy; override; - - procedure AddUser(aUserItem : TffUserItem); - function UserExists(const aUserID : TffName) : Boolean; - function UserIndex(const aUserID : TffName) : Integer; - function Count : integer; - procedure DeleteUser(const aUserID : TffName); - procedure Empty; - - property UserItem[aInx : integer] : TffUserItem read GetUserItem; default; - property PasswordHash[const aUserID : TffName] : TffWord32 read GetUserPwdHash; - property UserRights[const aUserID : TffName] : TffUserRights read GetUserRights; - end; - - TffKeyProcItem = class(TffUCStrListItem) - protected {private} - FIndexID : Integer; - FDLLName : PffShStr; - FBuildKey : TffKeyBuildFunc; - FBuildName : PffShStr; - FCompareKey : TffKeyCompareFunc; - FCompareName : PffShStr; - FPath : PffShStr; - FTable : PffShStr; - - kpiLibHandle : THandle; - protected - function GetBuildKeyName : string; {!!.10} - function GetCompareKeyName : string; {!!.10} - function GetDLLName : string; {!!.10} - function GetPath : string; {!!.10} - function GetTable : string; {!!.10} - function GetTableDataFileName : string; {!!.10} - public - constructor Create(const aPath : TffPath; - const aTable : TffTableName; - aIndexID : Integer; - const aDLLName : TffFullFileName; - const aBuildName : TffName; - const aCompareName : TffName); - destructor Destroy; override; - function Link : boolean; - procedure Unlink; - - property DLLName : string - read GetDLLName; {!!.10} - property IndexID : Integer - read FIndexID; - property BuildKey : TffKeyBuildFunc - read FBuildKey; - property BuildKeyName : string - read GetBuildKeyName; {!!.10} - property CompareKey : TffKeyCompareFunc - read FCompareKey; - property CompareKeyName : string - read GetCompareKeyName; {!!.10} - property Path : string - read GetPath; {!!.10} - property Table : string - read GetTable; {!!.10} - property TableDataFileName : string - read GetTableDataFileName; {!!.10} - end; - - TffKeyProcList = class(TffObject) - protected {private} - FKPList : TffList; - protected - function GetKPItem(aInx : integer) : TffKeyProcItem; - public - constructor Create; - destructor Destroy; override; - - procedure AddKeyProc(aKeyProcItem : TffKeyProcItem); - function KeyProcExists(const aPath : TffPath; - const aTable : TffTableName; - aIndexID : Integer) - : Boolean; - function KeyProcIndex(const aPath : TffPath; - const aTable : TffTableName; - aIndexID : Integer) - : Integer; - function Count : integer; - procedure DeleteKeyProc(const aPath : TffPath; - const aTable : TffTableName; - aIndexID : Integer); - procedure Empty; - - property KeyProcItem[aInx : Integer] : TffKeyProcItem - read GetKPItem; default; - end; - - TffServerConfiguration = class(TffObject) - protected {private} - FAliasList : TffAliasList; - FGeneralInfo : TffGeneralInfo; - FKeyProcList : TffKeyProcList; - FUserList : TffUserList; - scPadLock : TffPadLock; - protected - function GetGeneralInfo : PffGeneralInfo; - function GetServerName : string; {!!.10} - public - constructor Create; - destructor Destroy; override; - - procedure AddAlias(const aAlias : TffName; - const aPath : TffPath; - aCheckDisk : Boolean); {!!.11} - procedure AddKeyProc(const aPath : TffPath; - const aTable : TffTableName; - aIndexID : Integer; - const aDLLName : TffFullFileName; - const aBuildName : TffName; - const aCompareName : TffName); - procedure AddUser(const aUserID : TffName; - const aLastName : TffName; - const aFirstName : TffName; - aPwdHash : TffWord32; - aRights : TffUserRights); - procedure Lock; - procedure PerformDynamicLink; - procedure Unlock; - - property AliasList : TffAliasList - read FAliasList; - property GeneralInfo : PffGeneralInfo - read GetGeneralInfo; - property KeyProcList : TffKeyProcList - read FKeyProcList; - property ServerName : string - read GetServerName; {!!.10} - property UserList : TffUserList - read FUserList; - end; - -{---Internal helper routines---} -function srcfgCalcKPKey(const aTable : TffFullFileName; - aIndex : Integer) : TffShStr; -function srcfgAliasFromKPKey(const BKK : TffShStr) : TffName; -function srcfgTableFromKPKey(const BKK : TffShStr) : TffTableName; -function srcfgIndexFromKPKey(const BKK : TffShStr) : Integer; - -implementation - -{== Helper routines ==================================================} -function srcfgCalcKPKey(const aTable : TffFullFileName; - aIndex : Integer) - : TffShStr; -var - S : string[9]; -begin - Str(aIndex, S); - Result := aTable; - FFShStrAddChar(Result, '|'); - FFShStrConcat(Result, S); -end; -{--------} -function srcfgAliasFromKPKey(const BKK : TffShStr) : TffName; -var - PosSlash : integer; -begin - PosSlash := Pos('/', BKK); - if (PosSlash > 0) then - Result := Copy(BKK, 1, pred(PosSlash)) - else - Result := ''; -end; -{--------} -function srcfgTableFromKPKey(const BKK : TffShStr) : TffTableName; -var - PosColon : Integer; - PosSlash : Integer; -begin - PosSlash := Pos('/', BKK); - PosColon := Pos(':', BKK); - if (PosSlash > 0) and (PosColon > 0) then - Result := Copy(BKK, succ(PosSlash), pred(PosColon - PosSlash)) - else - Result := ''; -end; -{--------} -function srcfgIndexFromKPKey(const BKK : TffShStr) : Integer; -var - PosColon : Integer; - ec : Integer; - InxAsStr : string[9]; -begin - PosColon := Pos(':', BKK); - if (PosColon > 0) then begin - InxAsStr := Copy(BKK, succ(PosColon), 255); - Val(InxAsStr, Result, ec); - if (ec <> 0) then - Result := 0; - end - else - Result := 0; -end; -{=====================================================================} - -{== TffAliasItem =====================================================} -constructor TffAliasItem.Create(const aAlias : TffName; - const aPath : TffPath; - aCheckDisk : Boolean); {!!.11} -begin - inherited Create(aAlias); - FPath := FFShStrAlloc(FFExpandUNCFileName(aPath)); - FCheckDisk := aCheckDisk; {!!.11} -end; -{--------} -destructor TffAliasItem.Destroy; -begin - FFShStrFree(FPath); - inherited Destroy; -end; -{--------} -function TffAliasItem.GetAlias : string; {!!.10} -begin - Result := KeyAsStr; -end; -{--------} -function TffAliasItem.GetPath : string; {!!.10} -begin - Result := FPath^; -end; -{====================================================================} - - -{===TffAliasList=====================================================} -procedure TffAliasList.AddAlias(aAliasItem : TffAliasItem); -begin - Insert(aAliasItem); -end; -{--------} -function TffAliasList.AliasExists(const aAlias : TffName) : Boolean; -begin - Result := Exists(aAlias); -end; -{--------} -function TffAliasList.AliasIndex(const aAlias : TffName) : Integer; -begin - Result := Index(aAlias); -end; -{--------} -{!!.11 - New} -function TffAliasList.CheckDiskSpace(const aAlias : TffName) - : Boolean; -var - Position : Integer; -begin - Result := False; - Position := Index(aAlias); - if (Position > -1) then - Result := AliasItem[Position].CheckSpace; -end; -{--------} -procedure TffAliasList.DeleteAlias(const aAlias : TffName); -begin - Delete(aAlias); -end; -{--------} -function TffAliasList.GetAliasItem(aInx : Integer) : TffAliasItem; -begin - Result := TffAliasItem(fflList[aInx]); -end; -{--------} -function TffAliasList.GetAliasPath(const aAlias : TffName) : TffPath; -var - Inx : Integer; -begin - Inx := Index(aAlias); - if (Inx = -1) then - Result := '' - else - Result := TffAliasItem(fflList[Inx]).Path; -end; -{====================================================================} - - -{===TffUserItem======================================================} -constructor TffUserItem.Create(const aUserID : TffName; - const aLastName : TffName; - const aFirstName : TffName; - aPwdHash : TffWord32; - aRights : TffUserRights); -begin - inherited Create(aUserID); - FFirst := FFShStrAlloc(aFirstName); - FLast := FFShStrAlloc(aLastName); - FPwdHash := aPwdHash; - FRights := aRights; -end; -{--------} -destructor TffUserItem.Destroy; -begin - FFShStrFree(FFirst); - FFShStrFree(FLast); - inherited Destroy; -end; -{--------} -function TffUserItem.GetFirstName : string; {!!.10} -begin - Result := FFirst^; -end; -{--------} -function TffUserItem.GetLastName : string; {!!.10} -begin - Result := FLast^; -end; -{--------} -function TffUserItem.GetUserID : string; {!!.10} -begin - Result := KeyAsStr; -end; -{====================================================================} - - -{===TffUserList======================================================} -constructor TffUserList.Create; -begin - inherited Create; - FUserList := TffList.Create; -end; -{--------} -destructor TffUserList.Destroy; -begin - FUserList.Free; - inherited Destroy; -end; -{--------} -procedure TffUserList.AddUser(aUserItem : TffUserItem); -begin - FUserList.Insert(aUserItem); -end; -{--------} -function TffUserList.UserExists(const aUserID : TffName) : Boolean; -begin - Result := FUserList.Exists(aUserID); -end; -{--------} -function TffUserList.UserIndex(const aUserID : TffName) : Integer; -begin - Result := FUserList.Index(aUserID); -end; -{--------} -function TffUserList.Count : Integer; -begin - Result := FUserList.Count; -end; -{--------} -procedure TffUserList.DeleteUser(const aUserID : TffName); -begin - FUserList.Delete(aUserID); -end; -{--------} -procedure TffUserList.Empty; -begin - FUserList.Empty; -end; -{--------} -function TffUserList.GetUserItem(aInx : Integer) : TffUserItem; -begin - Result := TffUserItem(FUserList[aInx]); -end; -{--------} -function TffUserList.GetUserPwdHash(const aUserID : TffName) : TffWord32; -var - Inx : integer; -begin - if (aUserID = '') then - Result := 0 - else begin - Inx := FUserList.Index(aUserID); - if (Inx = -1) then - Result := $FFFFFFFF - else - Result := TffUserItem(FUserList[Inx]).PasswordHash; - end; -end; -{--------} -function TffUserList.GetUserRights(const aUserID : TffName) : TffUserRights; -var - Inx : integer; -begin - Inx := FUserList.Index(aUserID); - if (Inx = -1) then - Result := [] - else - Result := TffUserItem(FUserList[Inx]).Rights; -end; -{====================================================================} - - - -{===TffKeyProcItem===================================================} -constructor TffKeyProcItem.Create(const aPath : TffPath; - const aTable : TffTableName; - aIndexID : integer; - const aDLLName : TffFullFileName; - const aBuildName : TffName; - const aCompareName : TffName); -var - FFN : TffFullFileName; - UNCPath : TffPath; -begin - UNCPath := FFExpandUNCFileName(aPath); - FFN := FFMakeFullFileName(UNCPath, FFMakeFileNameExt(aTable, ffc_ExtForData)); - inherited Create(srcfgCalcKPKey(FFN, aIndexID)); - FIndexID := aIndexID; - FPath := FFShStrAlloc(UNCPath); - FTable := FFShStrAlloc(aTable); - FDLLName := FFShStrAlloc(aDLLName); - FBuildName := FFShStrAlloc(aBuildName); - FCompareName := FFShStrAlloc(aCompareName); -end; -{--------} -destructor TffKeyProcItem.Destroy; -begin - Unlink; - FFShStrFree(FCompareName); - FFShStrFree(FBuildName); - FFShStrFree(FDLLName); - FFShStrFree(FTable); - FFShStrFree(FPath); - inherited Destroy; -end; -{--------} -function TffKeyProcItem.GetDLLName : string; {!!.10} -begin - Result := FDLLName^; -end; -{--------} -function TffKeyProcItem.GetBuildKeyName : string; {!!.10} -begin - Result := FBuildName^; -end; -{--------} -function TffKeyProcItem.GetCompareKeyName : string; {!!.10} -begin - Result := FCompareName^; -end; -{--------} -function TffKeyProcItem.GetPath : string; {!!.10} -begin - Result := FPath^; -end; -{--------} -function TffKeyProcItem.GetTable : string; {!!.10} -begin - Result := FTable^; -end; -{--------} -function TffKeyProcItem.GetTableDataFileName : string; {!!.10} -begin - Result := FFMakeFullFileName(Path, FFMakeFileNameExt(Table, ffc_ExtForData)); -end; -{--------} -function TffKeyProcItem.Link : Boolean; -var - DLLPathZ : TffStringZ; - ProcNameZ : TffStringZ; -begin - Result := false; - Unlink; - kpiLibHandle := LoadLibrary(FFStrPCopy(DLLPathZ, DLLName)); - if (kpiLibHandle <> 0) then begin - @FBuildKey := GetProcAddress(kpiLibHandle, FFStrPCopy(ProcNameZ, BuildKeyName)); - if Assigned(FBuildKey) then begin - @FCompareKey := GetProcAddress(kpiLibHandle, FFStrPCopy(ProcNameZ, CompareKeyName)); - if Assigned(FCompareKey) then - Result := true - else - Unlink; - end - else - Unlink; - end; -end; -{--------} -procedure TffKeyProcItem.Unlink; -begin - if (kpiLibHandle <> 0) then - FreeLibrary(kpiLibHandle); - kpiLibHandle := 0; - FBuildKey := nil; - FCompareKey := nil; -end; -{====================================================================} - - -{===TffKeyProcList===================================================} -constructor TffKeyProcList.Create; -begin - inherited Create; - FKPList := TffList.Create; -end; -{--------} -destructor TffKeyProcList.Destroy; -begin - FKPList.Free; - inherited Destroy; -end; -{--------} -procedure TffKeyProcList.AddKeyProc(aKeyProcItem : TffKeyProcItem); -begin - FKPList.Insert(aKeyProcItem); -end; -{--------} -function TffKeyProcList.Count : Integer; -begin - Result := FKPList.Count; -end; -{--------} -procedure TffKeyProcList.DeleteKeyProc(const aPath : TffPath; - const aTable : TffTableName; - aIndexID : integer); -var - FFN : TffFullFileName; - KPKey : TffShStr; -begin - FFN := FFMakeFullFileName( - FFExpandUNCFileName(aPath), - FFMakeFileNameExt(aTable, ffc_ExtForData)); - KPKey := srcfgCalcKPKey(FFN, aIndexID); - FKPList.Delete(KPKey); -end; -{--------} -procedure TffKeyProcList.Empty; -begin - FKPList.Empty; -end; -{--------} -function TffKeyProcList.GetKPItem(aInx : Integer) : TffKeyProcItem; -begin - Result := TffKeyProcItem(FKPList[aInx]); -end; -{--------} -function TffKeyProcList.KeyProcExists(const aPath : TffPath; - const aTable : TffTableName; - aIndexID : Integer) : Boolean; -var - FFN : TffFullFileName; - KPKey : TffShStr; -begin - FFN := FFMakeFullFileName( - FFExpandUNCFileName(aPath), - FFMakeFileNameExt(aTable, ffc_ExtForData)); - KPKey := srcfgCalcKPKey(FFN, aIndexID); - Result := (FKPList.Index(KPKey) <> -1); -end; -{--------} -function TffKeyProcList.KeyProcIndex(const aPath : TffPath; - const aTable : TffTableName; - aIndexID : Integer) : Integer; -var - FFN : TffFullFileName; - KPKey : TffShStr; -begin - FFN := FFMakeFullFileName( - FFExpandUNCFileName(aPath), - FFMakeFileNameExt(aTable, ffc_ExtForData)); - KPKey := srcfgCalcKPKey(FFN, aIndexID); - Result := FKPList.Index(KPKey); -end; -{=====================================================================} - - -{== TffServerConfiguration ===========================================} -constructor TffServerConfiguration.Create; -begin - inherited Create; {!!.01} - - {set up the default general info} - with FGeneralInfo do begin - giServerName := ''; - giMaxRAM := 10; - giSingleUser := True; - giIPXSPX := False; - giIPXSPXLFB := True; - giTCPIP := False; - giTCPIPLFB := True; - giIsSecure := False; - giAutoUp := False; - giAutoMini := False; - giDebugLog := False; - {$IFDEF SecureServer} - giAllowEncrypt := True; - {$ELSE} - giAllowEncrypt := False; - {$ENDIF} - giReadOnly := False; - giNoAutoSaveCfg := False; - giLastMsgInterval := ffc_LastMsgInterval; - giKAInterval := ffc_KeepAliveInterval; - giKARetries := ffc_KeepAliveRetries; - giPriority := 2; {THREAD_PRIORITY_HIGHEST} - giTCPPort := FFGetTCPPort; - giUDPPortSr := FFGetUDPPortServer; - giUDPPortCl := FFGetUDPPortClient; - giIPXSocketSr := FFGetIPXSocketServer; - giIPXSocketCl := FFGetIPXSocketClient; - giSPXSocket := FFGetSPXSocket; - giTempStoreSize := ffcl_TempStorageSize; - giCollectEnabled := False; - giCollectFreq := ffcl_CollectionFrequency; - end; - - {create internal items} - scPadLock := TffPadLock.Create; - FAliasList := TffAliasList.Create; - FKeyProcList := TffKeyProcList.Create; - FUserList := TffUserList.Create; -end; -{--------} -destructor TffServerConfiguration.Destroy; -begin - FUserList.Free; - FKeyProcList.Free; - FAliasList.Free; - scPadLock.Free; - inherited Destroy; {!!.01} -end; -{--------} -procedure TffServerConfiguration.AddAlias(const aAlias : TffName; - const aPath : TffPath; - aCheckDisk : Boolean); {!!.11} -var - NewAlias : TffAliasItem; -begin - { Assumption: Thread-safeness enforced at a higher level. } - NewAlias := TffAliasItem.Create(aAlias, aPath, aCheckDisk); {!!.11} - try - FAliasList.AddAlias(NewAlias) - except - NewAlias.Free; - raise; - end;{try..except} -end; -{--------} -procedure TffServerConfiguration.AddKeyProc(const aPath : TffPath; - const aTable : TffTableName; - aIndexID : Integer; - const aDLLName : TffFullFileName; - const aBuildName : TffName; - const aCompareName : TffName); -var - NewKeyProc : TffKeyProcItem; -begin - { Assumption: Thread-safeness enforced at a higher level. } - NewKeyProc := TffKeyProcItem.Create(aPath, aTable, aIndexID, - aDLLName, aBuildName, aCompareName); - try - FKeyProcList.AddKeyProc(NewKeyProc) - except - NewKeyProc.Free; - raise; - end;{try..except} -end; -{--------} -procedure TffServerConfiguration.AddUser(const aUserID : TffName; - const aLastName : TffName; - const aFirstName : TffName; - aPwdHash : TffWord32; - aRights : TffUserRights); -var - NewUser : TffUserItem; -begin - { Assumption: Thread-safeness enforced at a higher level. } - NewUser := TffUserItem.Create(aUserID, aLastName, aFirstName, aPwdHash, aRights); - try - FUserList.AddUser(NewUser) - except - NewUser.Free; - raise; - end;{try..except} -end; -{--------} -function TffServerConfiguration.GetGeneralInfo : PffGeneralInfo; -begin - Result := @FGeneralInfo; -end; -{--------} -function TffServerConfiguration.GetServerName : string; {!!.10} -begin - Result := FGeneralInfo.giServerName; -end; -{--------} -procedure TffServerConfiguration.Lock; -begin - scPadLock.Lock; -end; -{--------} -procedure TffServerConfiguration.PerformDynamicLink; -var - i : integer; - lTable : TffFullFileName; - lDLL : TffFullFileName; - lBKName: TffName; - lCKName: TffName; -begin - Lock; - try - for i := 0 to pred(KeyProcList.Count) do begin - with KeyProcList[i] do begin - if not Link then begin - lTable := TableDataFileName; - lDLL := DLLName; - lBKName := BuildKeyName; - lCKName := CompareKeyName; - FFRaiseException(EffServerException, ffStrResServer, fferrDynamicLink, - [lTable, IndexID, lDLL, lBKName, lCKName]) - end; - end; - end; - finally - Unlock; - end;{try..finally} -end; -{--------} -procedure TffServerConfiguration.UnLock; -begin - scPadLock.Unlock; -end; -{====================================================================} -end. diff --git a/components/flashfiler/sourcelaz/ffsrcmd.pas b/components/flashfiler/sourcelaz/ffsrcmd.pas deleted file mode 100644 index 09a93b927..000000000 --- a/components/flashfiler/sourcelaz/ffsrcmd.pas +++ /dev/null @@ -1,3882 +0,0 @@ -{*********************************************************} -{* FlashFiler: Server command handler *} -{*********************************************************} - -(* ***** 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 ffsrcmd; - -interface - -uses - Classes, - Windows, - SysUtils, - ffconst, - ffhash, {!!.05} - ffllbase, - fflleng, - ffllcomm, - ffllprot, - ffnetmsg, - ffdtmsgq, - ffsrbase, - ffsrbde, - ffsrintm, - ffsrtran, - fftbdict, - ffsreng; - -type - TffServerCommandHandler = class(TffIntermediateCommandHandler) - protected {private} - - schSavedAddClientEvents : TffThreadHash; {!!.05} - - protected - {client message handling} - procedure nmAcqTableLock(var Msg : TffDataMessage); - message ffnmAcqTableLock; - procedure nmAddIndex(var Msg : TffDataMessage); - message ffnmAddIndex; - procedure nmAddFileBLOB(var Msg : TffDataMessage); - message ffnmAddFileBLOB; - procedure nmBuildTable(var Msg : TffDataMessage); - message ffnmBuildTable; - procedure nmCheckSecureComms(var Msg : TffDataMessage); - message ffnmCheckSecureComms; - procedure nmClientSetTimeout(var Msg : TffDataMessage); - message ffnmClientSetTimeout; - procedure nmCreateBLOB(var Msg : TffDataMessage); - message ffnmCreateBLOB; - procedure nmCursorClone(var Msg : TffDataMessage); - message ffnmCursorClone; - procedure nmCursorClose(var Msg : TffDataMessage); - message ffnmCursorClose; - procedure nmCursorCompareBMs(var Msg : TffDataMessage); - message ffnmCursorCompareBMs; - procedure nmCursorCopyRecords(var Msg : TffDataMessage); {!!.02} - message ffnmCursorCopyRecords; {!!.02} - procedure nmCursorDeleteRecords(var Msg : TffDataMessage); {!!.06} - message ffnmCursorDeleteRecords; {!!.06} -{Begin !!.03} - procedure nmCursorGetBLOBFreeSpace(var Msg : TffDataMessage); - message ffnmListBLOBFreeSpace; -{End !!.03} - procedure nmCursorGetBookmark(var Msg : TffDataMessage); - message ffnmCursorGetBookmark; - procedure nmCursorOverrideFilter(var Msg : TffDataMessage); - message ffnmCursorOverrideFilter; - procedure nmCursorResetRange(var Msg : TffDataMessage); - message ffnmCursorResetRange; - procedure nmCursorRestoreFilter(var Msg : TffDataMessage); - message ffnmCursorRestoreFilter; - procedure nmCursorSetRange(var Msg : TffDataMessage); - message ffnmCursorSetRange; - procedure nmCursorSetTimeout(var Msg : TffDataMessage); - message ffnmCursorSetTimeout; - procedure nmCursorSetToBegin(var Msg : TffDataMessage); - message ffnmCursorSetToBegin; - procedure nmCursorSetToBookmark(var Msg : TffDataMessage); - message ffnmCursorSetToBookmark; - procedure nmCursorSetToCursor(var Msg : TffDataMessage); - message ffnmCursorSetToCursor; - procedure nmCursorSetToEnd(var Msg : TffDataMessage); - message ffnmCursorSetToEnd; - procedure nmCursorSetToKey(var Msg : TffDataMessage); - message ffnmCursorSetToKey; - procedure nmCursorSwitchToIndex(var Msg : TffDataMessage); - message ffnmCursorSwitchToIndex; - procedure nmCursorSetFilter(var Msg : TffDataMessage); - message ffnmCursorSetFilter; - procedure nmDatabaseAddAlias(var Msg : TffDataMessage); - message ffnmDatabaseAddAlias; - procedure nmDatabaseAliasList(var Msg : TffDataMessage); - message ffnmDatabaseAliasList; - procedure nmDatabaseChgAliasPath(var Msg : TffDataMessage); - message ffnmDatabaseChgAliasPath; - procedure nmDatabaseClose(var Msg : TffDataMessage); - message ffnmDatabaseClose; - procedure nmDatabaseDeleteAlias(var Msg : TffDataMessage); - message ffnmDatabaseDeleteAlias; - procedure nmDatabaseGetAliasPath(var Msg : TffDataMessage); - message ffnmDatabaseGetAliasPath; - procedure nmDatabaseGetFreeSpace(var Msg : TffDataMessage); - message ffnmDatabaseGetFreeSpace; - procedure nmDatabaseModifyAlias(var Msg : TffDataMessage); - message ffnmDatabaseModifyAlias; - procedure nmDatabaseOpen(var Msg : TffDataMessage); - message ffnmDatabaseOpen; - procedure nmDatabaseOpenNoAlias(var Msg : TffDataMessage); - message ffnmDatabaseOpenNoAlias; - procedure nmDatabaseSetTimeout(var Msg : TffDataMessage); - message ffnmDatabaseSetTimeout; - procedure nmDatabaseTableExists(var Msg : TffDataMessage); - message ffnmDatabaseTableExists; - procedure nmDatabaseTableList(var Msg : TffDataMessage); - message ffnmDatabaseTableList; - procedure nmDatabaseTableLockedExclusive(var Msg : TffDataMessage); - message ffnmDatabaseTableLockedExclusive; - procedure nmDeleteBLOB(var Msg : TffDataMessage); - message ffnmDeleteBLOB; - procedure nmDeleteTable(var Msg : TffDataMessage); - message ffnmDeleteTable; - procedure nmDetachServerJIC(var Msg : TffDataMessage); - message ffnmDetachServerJIC; - procedure nmDropIndex(var Msg : TffDataMessage); - message ffnmDropIndex; - procedure nmEmptyTable(var Msg : TffDataMessage); - message ffnmEmptyTable; - procedure nmEndTransaction(var Msg : TffDataMessage); - message ffnmEndTransaction; - procedure nmFreeBLOB(var Msg : TffDataMessage); - message ffnmFreeBLOB; - procedure nmGetTableAutoIncValue(var Msg : TffDataMessage); - message ffnmGetTableAutoIncValue; - procedure nmGetBLOBLength(var Msg : TffDataMessage); - message ffnmGetBLOBLength; - procedure nmGetRebuildStatus(var Msg : TffDataMessage); - message ffnmGetRebuildStatus; - procedure nmGetServerDateTime(var Msg : TffDataMessage); - message ffnmGetServerDateTime; - {begin !!.07} - procedure nmGetServerSystemTime(var Msg : TffDataMessage); - message ffnmGetServerSystemTime; - procedure nmGetServerGUID(var Msg : TffDataMessage); - message ffnmGetServerGUID; - procedure nmGetServerID(var Msg : TffDataMessage); - message ffnmGetServerID; {end !!.07} - procedure nmGetTableDictionary(var Msg : TffDataMessage); - message ffnmGetTableDictionary; - procedure nmGetTableRecCount(var Msg : TffDataMessage); - message ffnmGetTableRecCount; - procedure nmGetTableRecCountAsync(var Msg : TffDataMessage); {!!.07} - message ffnmGetTableRecCountAsync; {!!.07} -{Begin !!.11} - procedure nmGetTableVersion(var Msg : TffDataMessage); - message ffnmGetTableVersion; -{End !!.11} - procedure nmIsTableLocked(var Msg : TffDataMessage); - message ffnmIsTableLocked; -{Begin !!.03} - procedure nmListBLOBSegments(var Msg : TffDataMessage); - message ffnmListBLOBSegments; -{End !!.03} - procedure nmOpenTable(var Msg : TffDataMessage); - message ffnmOpenTable; - procedure nmPackTable(var Msg : TffDataMessage); - message ffnmPackTable; - procedure nmReadBLOB( var Msg : TffDataMessage ); - message ffnmReadBLOB; - procedure nmRecordDelete( var Msg : TffDataMessage ); - message ffnmRecordDelete; - procedure nmRecordDeleteBatch(var Msg : TffDataMessage); - message ffnmRecordDeleteBatch; - procedure nmRecordExtractKey(var Msg : TffDataMessage); - message ffnmRecordExtractKey; - procedure nmRecordGet(var Msg : TffDataMessage); - message ffnmRecordGet; - procedure nmRecordGetBatch(var Msg : TffDataMessage); - message ffnmRecordGetBatch; - procedure nmRecordGetForKey(var Msg : TffDataMessage); - message ffnmRecordGetForKey; - procedure nmRecordGetForKey2(var Msg : TffDataMessage); - message ffnmRecordGetForKey2; - procedure nmRecordGetNext(var Msg : TffDataMessage); - message ffnmRecordGetNext; - procedure nmRecordGetPrev(var Msg : TffDataMessage); - message ffnmRecordGetPrev; - procedure nmRecordInsert(var Msg : TffDataMessage); - message ffnmRecordInsert; - procedure nmRecordInsertBatch(var Msg : TffDataMessage); - message ffnmRecordInsertBatch; - procedure nmRecordIsLocked(var Msg : TffDataMessage); - message ffnmRecordIsLocked; - procedure nmRecordModify(var Msg : TffDataMessage); - message ffnmRecordModify; - procedure nmRecordRelLock(var Msg : TffDataMessage); - message ffnmRecordRelLock; - procedure nmReindexTable(var Msg : TffDataMessage); - message ffnmReindexTable; - procedure nmRelTableLock(var Msg : TffDataMessage); - message ffnmRelTableLock; - procedure nmRenameTable(var Msg : TffDataMessage); - message ffnmRenameTable; - procedure nmRestructureTable(var Msg : TffDataMessage); - message ffnmRestructureTable; - procedure nmServerIsReadOnly(var Msg : TffDataMessage); - message ffnmServerIsReadOnly; - {begin !!.07} - procedure nmServerStatistics(var Msg : TffDataMessage); - message ffnmServerStatistics; - procedure nmCmdHandlerStatistics(var Msg : TffDataMessage); - message ffnmCmdHandlerStatistics; - procedure nmTransportStatistics(var Msg : TffDataMessage); - message ffnmTransportStatistics; {end !!.07} - procedure nmSessionAdd(var Msg : TffDataMessage); - message ffnmSessionAdd; - procedure nmSessionClose(var Msg : TffDataMessage); - message ffnmSessionClose; - procedure nmSessionCloseInactiveTables(var Msg : TffDataMessage); - message ffnmSessionCloseInactTbl; - procedure nmSessionGetCurrent(var Msg : TffDataMessage); - message ffnmSessionGetCurrent; - procedure nmSessionSetCurrent(var Msg : TffDataMessage); - message ffnmSessionSetCurrent; - procedure nmSessionSetTimeout(var Msg : TffDataMessage); - message ffnmSessionSetTimeout; - procedure nmSetTableAutoIncValue(var Msg : TffDataMessage); - message ffnmSetTableAutoIncValue; - procedure nmSQLAlloc(var Msg : TffDataMessage); - message ffnmSQLAlloc; - procedure nmSQLPrepare(var Msg : TffDataMessage); - message ffnmSQLPrepare; - procedure nmSQLExec(var Msg : TffDataMessage); - message ffnmSQLExec; - procedure nmSQLExecDirect(var Msg : TffDataMessage); - message ffnmSQLExecDirect; - procedure nmSQLSetParams(var Msg : TffDataMessage); - message ffnmSQLSetParams; - procedure nmSQLFree(var Msg : TffDataMessage); - message ffnmSQLFree; - procedure nmStartTransaction(var Msg : TffDataMessage); - message ffnmStartTransaction; - procedure nmStartTransactionWith(var Msg : TffDataMessage); {!!.10} - message ffnmStartTransactionWith; {!!.10} - procedure nmTruncateBLOB(var Msg : TffDataMessage); - message ffnmTruncateBLOB; - procedure nmWriteBLOB( var Msg : TffDataMessage ); - message ffnmWriteBLOB; - - procedure schDisposeRecord(Sender : TffBaseHashTable; {!!.05} - aData : Pointer); {!!.05} - - procedure schOnAddClient(Listener : TffBaseTransport; - const userID : TffName; - const timeout : longInt; - const clientVersion : longInt; - var passwordHash : TffWord32; - var aClientID : TffClientID; - var errorCode : TffResult; - var isSecure : boolean; - var aVersion : longInt); - { This method is called when the transport needs to establish a new - client. } - - procedure schOnRemoveClient(Listener : TffBaseTransport; - const aClientID : TffClientID; - var errorCode : TffResult); - { This method is called when the transport needs to remove an existing - client. } - - protected - - {State methods} - procedure scInitialize; override; - { This method is called when the command handler is to perform - its initialization. } - - procedure scPrepareForShutdown; override; - { This method is called when the command handler is to prepare for - shutdown. } - - procedure scShutdown; override; - { This method is called when the command handler is to stop processing - requests. } - - procedure scStartup; override; - { This method is called when the command handler is to start processing - requests. } - - public - constructor Create(aOwner : TComponent); override; - - destructor Destroy; override; - - procedure DefaultHandler(var Message); override; - { If this command handler does not have a method specifically for - a received message, the TObject.Dispatch method will pass the - message to this method. This method hands the message of to this - class' ancestor so that default handling may be applied (i.e., see - if the plugins or engine manager recognize the message. } - - procedure FFAddDependent(ADependent : TffComponent); override; {!!.11} - { This overridden method sets the OnAddclient and OnRemoveClient events - of the registering transport. } - - procedure Process(Msg : PffDataMessage); override; - { This method is called by the transport in order to process a message. - The message is first routed to the server engine. If the server engine - does not handle the message then it is forwarded to the plugin(s). If - a plugin does not handle the message, it is finally forwarded to the - engine manager(s).} - - end; - -implementation - -uses - ComObj, - ffsqlbas, - ffsrlock; - -const - { Logging constants } - csBlobNr = ' BLOBNr %d:%d'; - csClientID = ' ClientID %d'; - csCursorID = ' CursorID %d'; - csErr = '*ERROR* %x'; - -{===TffServerCommandHandler==========================================} -constructor TffServerCommandHandler.Create(aOwner : TComponent); -begin - inherited Create(aOwner); - schSavedAddClientEvents := TffThreadHash.Create(ffc_Size59); {!!.05} - schSavedAddClientEvents.OnDisposeData := schDisposeRecord; {!!.05} -end; -{--------} -destructor TffServerCommandHandler.Destroy; -begin - schSavedAddClientEvents.Clear; {!!.05} - schSavedAddClientEvents.Free; {!!.05} - schSavedAddClientEvents := nil; {!!.05} - inherited Destroy; -end; -{--------} -procedure TffServerCommandHandler.DefaultHandler(var Message); -begin - { The server engine does not handle this message. Hand it off to our - ancestor class for default handling. } - inherited Process(@Message); -end; -{--------} -procedure TffServerCommandHandler.Process(Msg : PffDataMessage); -begin - Dispatch(Msg^); - bchFreeMsg(Msg); -end; -{--------} -procedure TffServerCommandHandler.nmAcqTableLock(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmAcqTableLockReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['AcqTableLock', - Format(csClientID, [dmClientID]), - Format(csCursorID, [CursorID]), - Format(' LockType %d', [byte(LockType)])]); - - Error := FServerEngine.TableLockAcquire(CursorID, LockType); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - TffBaseTransport.Reply(ffnmAcqTableLock, Error, nil, 0); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmAddFileBLOB(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmAddFileBLOBRpy; -begin - with Msg, PffnmAddFileBLOBReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['AddFileBLOB', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' FileName %s', [FileName])]); - - Error := FServerEngine.FileBLOBAdd(CursorID, FileName, Reply.BLOBNr); - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(csBLOBNr, [Reply.BLOBNr.iHigh, Reply.BLOBNr.iLow]); {!!.03} - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmAddFileBLOB, Error, @Reply, sizeof(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmAddIndex(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmAddIndexReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['AddIndex', - format(csClientID, [dmClientID]), - format(' DBase ID %d', [DatabaseID]), - format(csCursorID, [CursorID]), - format(' TblName [%s]', [TableName])]); - - Error := FServerEngine.TableAddIndex(DatabaseID, CursorID, TableName, IndexDesc); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmAddIndex, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmBuildTable(var Msg : TffDataMessage); -{ Input stream is expected to be: - DatabaseId (longint) - OverWrite (Boolean) - TableName (TffTableName) - Dictionary (TffServerDataDict or TffDataDictionary) - FieldMap (one TffShStr for each field map entry; final entry - followed by a zero byte to signal end-of-list. If - no field map is given, then a single zero byte must be - present -} -var - Error : TffResult; - Stream : TMemoryStream; - DatabaseID : LongInt; - OverWrite : Boolean; - TableName : TffTableName; - Dictionary : TffServerDataDict; - DictionaryStart: LongInt; -begin - with Msg do begin - Stream := TMemoryStream.Create; - Stream.Write(dmData^, dmDataLen); - Stream.Position := 0; - Stream.Read(DatabaseID, SizeOf(DatabaseID)); - Stream.Read(OverWrite, SizeOf(OverWrite)); - Stream.Read(TableName, SizeOf(TableName)); - Dictionary := TffServerDataDict.Create(4096); - try - DictionaryStart := Stream.Position; - Dictionary.ReadFromStream(Stream); - - if FLogEnabled then begin - ichLogAll(['BuildTable', - format(csClientID, [dmClientID]), - format(' DBase ID %d', [DatabaseID]), - format(' OverWrite %d', [ord(OverWrite)]), - format(' TblName [%s]', [TableName])]); - ichLogBlock(' Dictionary', - Addr(PffByteArray(Stream.Memory)^[DictionaryStart]), - Stream.Size - DictionaryStart); - end; - - Error := FServerEngine.TableBuild(DatabaseID, - OverWrite, - TableName, - false, - Dictionary); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmBuildTable, Error, nil, 0); - finally - Dictionary.Free; - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmCheckSecureComms(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg do begin - if FLogEnabled then - ichLogAll(['CheckSecureComms', - format(csClientID, [dmClientID])]); - - {Note: If we get this message the client's password must have been - OK; the transport will hangup if the clientID is unknown.} - Error := DBIERR_NONE; - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmCheckSecureComms, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmClientSetTimeout(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmClientSetTimeoutReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['ClientSetTimeout', - format(csClientID, [dmClientID]), - format(' Timeout %d', [Timeout])]); - - Error := FServerEngine.ClientSetTimeout(dmClientID, Timeout); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmClientSetTimeout, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmCreateBLOB(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmCreateBLOBRpy; -begin - with Msg, PffnmCreateBLOBReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['CreateBLOB', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID])]); - - Error := FServerEngine.BLOBCreate(CursorID, Reply.BLOBNr); - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(csBLOBNr, [Reply.BLOBNr.iHigh, Reply.BLOBNr.iLow]); {!!.03} - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmCreateBLOB, Error, @Reply, sizeof(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmCursorClone(var Msg : TffDataMessage); -var - Error : TffResult; - aNewCursorID : TffCursorID; - Reply : TffnmCursorCloneRpy; -begin - with Msg, PffnmCursorCloneReq( dmData )^ do begin - if FLogEnabled then - ichLogAll(['CursorClone', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' OpenMode %d', [byte(OpenMode)])]); - - Error := FServerEngine.CursorClone(CursorID, OpenMode, aNewCursorID); - if (Error = 0) then - Reply.CursorID := aNewCursorID; - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(csCursorID, [Reply.CursorID]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmCursorClone, Error, @Reply, sizeof(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmCursorClose(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmCursorCloseReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['CursorClose', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID])]); - - Error := FServerEngine.CursorClose(CursorID); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmCursorClose, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmCursorCompareBMs(var Msg : TffDataMessage); -var - Error : TffResult; - BM2 : PffByteArray; - Reply : TffnmCursorCompareBMsRpy; -begin - with Msg, PffnmCursorCompareBMsReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['CompareBookmarks', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' BM Size %d', [BookmarkSize])]); - - BM2 := PffByteArray(PAnsiChar(@Bookmark1) + BookmarkSize); - if FLogEnabled then begin - ichLogBlock(' BM1', @Bookmark1, BookmarkSize); - ichLogBlock(' BM2', BM2, BookmarkSize); - end; - Error := FServerEngine.CursorCompareBookmarks(CursorID, @Bookmark1, BM2, Reply.CompareResult); - if (Reply.CompareResult < 0) then - Reply.CompareResult := -1 - else if (Reply.CompareResult > 0) then - Reply.CompareResult := 1; - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' Compare %d', [Reply.CompareResult]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmCursorCompareBMs, Error, @Reply, sizeof(Reply)); - end; -end; -{Begin !!.02} -{--------} -procedure TffServerCommandHandler.nmCursorCopyRecords(var Msg : TffDataMessage); -var - CopyBLOBsStr : string; - Error : TffResult; -begin - with Msg, PffnmCursorCopyRecordsReq(dmData)^ do begin - if FLogEnabled then begin - if CopyBLOBs then - CopyBLOBsStr := 'yes' - else - CopyBLOBsStr := 'no'; - ichLogAll(['CopyRecords', - format(csClientID, [dmClientID]), - format(' SrcCursorID %d', [SrcCursorID]), - format(' DestCursorID %d', [DestCursorID]), - format(' Copy blobs %s', [CopyBLOBsStr])]); - end; - - Error := FServerEngine.CursorCopyRecords(SrcCursorID, DestCursorID, CopyBLOBs); - TffBaseTransport.Reply(ffnmCursorCopyRecords, Error, nil, 0); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - end; -end; -{End !!.02} -{Begin !!.06 -{--------} -procedure TffServerCommandHandler.nmCursorDeleteRecords(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmCursorDeleteRecordsReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['DeleteRecords', - format(csClientID, [dmClientID]), - format(' CursorID %d', [CursorID])]); - - Error := FServerEngine.CursorDeleteRecords(CursorID); - TffBaseTransport.Reply(ffnmCursorDeleteRecords, Error, nil, 0); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - end; -end; -{End !!.06} -{Begin !!.03} -{--------} -procedure TffServerCommandHandler.nmCursorGetBLOBFreeSpace(var Msg : TffDataMessage); -var - aBuffer : pointer; - Error : TffResult; - aStream: TMemoryStream; - StreamSize : longInt; -begin - with Msg, PffnmGetBLOBFreeSpaceReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['CursorGetBLOBFreeSpace', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID])]); - - aStream := TMemoryStream.Create; - try - Error := FServerEngine.CursorListBLOBFreeSpace(CursorID, InMemory, - aStream); - StreamSize := aStream.Size; - FFGetMem(aBuffer, StreamSize); - aStream.Position := 0; - aStream.Read(aBuffer^, StreamSize); - - if FLogEnabled and (Error = 0) then - ichLogBlock(' List', aStream.Memory, StreamSize); - - TffBaseTransport.Reply(ffnmListBLOBFreeSpace, Error, aBuffer, - StreamSize); - FFFreeMem(aBuffer, StreamSize); - - finally - aStream.Free; - end;{try..finally} - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - end; -end; -{End !!.03} -{--------} -procedure TffServerCommandHandler.nmCursorGetBookmark(var Msg : TffDataMessage); -var - Error : TffResult; - BM : PffByteArray; -begin - with Msg, PffnmCursorGetBookmarkReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['GetBookmark', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' BM Size %d', [BookmarkSize])]); - - FFGetMem(BM, BookmarkSize); - try - Error := FServerEngine.CursorGetBookmark(CursorID, BM); - if FLogEnabled then - if (Error = 0) then - ichLogBlock(' Bookmark', BM, BookmarkSize); - TffBaseTransport.Reply(ffnmCursorGetBookmark, Error, BM, BookmarkSize); - finally - FFFreeMem(BM, BookmarkSize); - end;{try..finally} - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - end; -end; -{--------} -procedure TffServerCommandHandler.nmCursorOverrideFilter(var Msg : TffDataMessage); -var - Error : TffResult; - Expression : pCANExpr; -begin - with Msg, PffnmCursorOverrideFilterReq(dmData)^ do begin - Expression := pCANExpr(@ExprTree); - if FLogEnabled then begin - ichLogAll(['OverrideFilter', - format(' ClientID %d', [dmClientID]), - format(' CursorID %d', [CursorID]), - format(' Timeout %d', [Timeout])]); - ichLogBlock(' Data', Expression, Expression^.iTotalSize); - end; - - if Expression^.iTotalSize <= SizeOf(CANExpr) then - Expression:= nil; - - Error := FServerEngine.CursorOverrideFilter(CursorID, Expression, Timeout); - TffBaseTransport.Reply(ffnmCursorOverrideFilter, Error, nil, 0); - - if FLogEnabled then - ichLogFmt(' *ERROR* %x', [Error]); - end; -end; -{--------} - -procedure TffServerCommandHandler.nmCursorResetRange(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmCursorResetRangeReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['ResetRange', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID])]); - - Error := FServerEngine.CursorResetRange(CursorID); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmCursorResetRange, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmCursorRestoreFilter(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmCursorRestoreFilterReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['RestoreFilter', - format(' CursorID %d', [CursorID])]); - - Error := FServerEngine.CursorRestoreFilter(CursorID); - TffBaseTransport.Reply(ffnmCursorRestoreFilter, Error, nil, 0); - if FLogEnabled then - ichLogFmt(' *ERROR* %x', [Error]); - end; -end; -{-------} -procedure TffServerCommandHandler.nmCursorSetRange(var Msg : TffDataMessage); -var - Error : TffResult; - pKey1, pKey2 : Pointer; - MsgSize : longint; - MsgData : PffByteArray; - SubMsg : PffsmHeader; -begin - with Msg, PffnmCursorSetRangeReq(dmData)^ do begin - if KeyLen1 = 0 then - pKey1 := nil - else - pKey1 := @KeyData1; - if KeyLen2 = 0 then - pKey2 := nil - else - pKey2 := PffByteArray(PAnsiChar(@KeyData1) + KeyLen1); - if FLogEnabled then begin - ichLogAll(['SetRange', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' DirectKey %d', [Byte(DirectKey)]), - format(' KeyLen1 %d', [KeyLen1]), - format(' FieldCount1 %d', [FieldCount1]), - format(' PartialLen1 %d', [PartialLen1]), - format(' KeyIncl1 %d', [Byte(KeyIncl1)])]); - ichLogBlock(' Key1', pKey1, KeyLen1); - ichLogAll([format(' KeyLen2 %d', [KeyLen2]), - format(' FieldCount2 %d', [FieldCount2]), - format(' PartialLen2 %d', [PartialLen2]), - format(' KeyIncl2 %d', [Byte(KeyIncl2)])]); - ichLogBlock(' Key2', pKey2, KeyLen2); - end; - - MsgSize := (2 * ffc_SubMsgHeaderSize); - FFGetMem(MsgData, MsgSize); - try - { do the SetRange First } - SubMsg := PffsmHeader(MsgData); - Error := FServerEngine.CursorSetRange( CursorID, DirectKey, - FieldCount1, PartialLen1, - pKey1, KeyIncl1, - FieldCount2, PartialLen2, - pKey2, KeyIncl2 ); - - SubMsg := FFCreateSubMessage(SubMsg, - ffnmCursorSetRange, - Error, - nmdByteArray, - nil, - 0); - if FLogEnabled then - ichLogAll([format(csErr, [Error]), - 'SetToBegin (multipart)']); - - Error := FServerEngine.CursorSetToBegin(CursorID); - FFCreateSubMessage( SubMsg, - ffnmCursorSetToBegin, - Error, - nmdByteArray, - nil, - 0); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - TffBaseTransport.Reply(ffnmMultiPartMessage, 0, MsgData, MsgSize); - finally - FFFreeMem(MsgData, MsgSize); - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmCursorSetTimeout(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmCursorSetTimeoutReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['CursorSetTimeout', - format(csCursorID, [CursorID]), - format(' Timeout %d', [Timeout])]); - - Error := FServerEngine.CursorSetTimeout(CursorID, Timeout); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmCursorSetTimeout, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmCursorSetToBegin(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmCursorSetToBeginReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['SetToBegin', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID])]); - - Error := FServerEngine.CursorSetToBegin(CursorID); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmCursorSetToBegin, Error, nil, 0); - - end; -end; -{-------} -procedure TffServerCommandHandler.nmCursorSetToBookmark(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmCursorSetToBookmarkReq(dmData)^ do begin - if FLogEnabled then begin - ichLogAll(['SetToBookmark', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' BM Size %d', [BookmarkSize])]); - ichLogBlock(' Bookmark', @Bookmark, BookmarkSize); - end; - - Error := FServerEngine.CursorSetToBookmark(CursorID, @Bookmark); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmCursorSetToBookmark, Error, nil, 0); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmCursorSetToCursor(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmCursorSetToCursorReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['SetToCursor', - format(csClientID, [dmClientID]), - format(' DestCursor %d', [DestCursorID]), - format(' SrcCursor %d', [SrcCursorID])]); - - Error := FServerEngine.CursorSetToCursor(DestCursorID, SrcCursorID); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmCursorSetToCursor, Error, nil, 0); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmCursorSetToEnd(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmCursorSetToEndReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['SetToEnd', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID])]); - - Error := FServerEngine.CursorSetToEnd(CursorID); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmCursorSetToEnd, Error, nil, 0); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmCursorSetToKey(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmCursorSetToKeyReq(dmData)^ do begin - if FLogEnabled then begin - ichLogAll(['SetToKey', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' Action %d', [byte(Action)]), - format(' DrctKey %d', [byte(DirectKey)]), - format(' FldCount %d', [FieldCount]), - format(' PartLen %d', [PartialLen]), - format(' DataLen %d', [KeyDataLen])]); - ichLogBlock(' Data', @KeyData, KeyDataLen); - end; - - Error := FServerEngine.CursorSetToKey(CursorID, Action, DirectKey, - FieldCount, PartialLen, @KeyData); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmCursorSetToKey, Error, nil, 0); - - end; -end; -{--------} - -procedure TffServerCommandHandler.nmCursorSwitchToIndex(var Msg : TffDataMessage); -var - Error : TffResult; - MsgSize : longint; - MsgData : PffByteArray; - SubMsg : PffsmHeader; -begin - with Msg, PffnmCursorSwitchToIndexReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['SwitchToIndex', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' InxName [%s]', [IndexName]), - format(' InxNum %d', [IndexNumber]), - format(' PosnRec %d', [byte(PosnOnRec)])]); - - if byte(PosnOnRec) <> 0 then begin - Error := FServerEngine.CursorSwitchToIndex(CursorID, - IndexName, IndexNumber, - PosnOnRec); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - TffBaseTransport.Reply(ffnmCursorSwitchToIndex, Error, nil, 0); - - end else begin - MsgSize := (2 * ffc_SubMsgHeaderSize); - FFGetMem(MsgData, MsgSize); - try - { do the SwitchToIndex First } - SubMsg := PffsmHeader(MsgData); - Error := FServerEngine.CursorSwitchToIndex(CursorID, - IndexName, IndexNumber, - PosnOnRec); - SubMsg := FFCreateSubMessage(SubMsg, - ffnmCursorSwitchToIndex, - Error, - nmdByteArray, - nil, - 0); - if FLogEnabled then - ichLogAll([format(csErr, [Error]), - 'SetToBegin (multipart)']); - - Error := FServerEngine.CursorSetToBegin(CursorID); - FFCreateSubMessage( SubMsg, - ffnmCursorSetToBegin, - Error, - nmdByteArray, - nil, - 0); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - TffBaseTransport.Reply(ffnmMultiPartMessage, 0, MsgData, MsgSize); - finally - FFFreeMem(MsgData, MsgSize); - end; - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmCursorSetFilter(var Msg : TffDataMessage); -var - Error : TffResult; - Expression : pCANExpr; -begin - with Msg, PffnmCursorSetFilterReq(dmData)^ do begin - Expression := pCANExpr(@ExprTree); - - if FLogEnabled then begin - ichLogAll(['SetFilter', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' Timeout %d', [Timeout])]); - ichLogBlock(' Data', Expression, Expression^.iTotalSize); - end; - -// if Expression^.iTotalSize <= SizeOf(CANExpr) then {Deleted !!.01} -// Expression:= nil; {Deleted !!.01} - - Error := FServerEngine.CursorSetFilter(CursorID, Expression, Timeout); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmCursorSetFilter, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmDatabaseAddAlias(var Msg : TffDataMessage); -{ Rewritten !!.11} -var - Error : TffResult; -begin - if Msg.dmDataLen = SizeOf(TffnmOldDatabaseAddAliasReq) then - with Msg, PffnmOldDatabaseAddAliasReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['DatabaseAddAlias - Old', - format(csClientID, [dmClientID]), - format(' Alias [%s]', [Alias]), - format(' Path [%s]', [Path])]); - - Error := FServerEngine.DatabaseAddAlias(Alias, - Path, - False, - dmClientID); - end { with } - else - with Msg, PffnmDatabaseAddAliasReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['DatabaseAddAlias', - format(csClientID, [dmClientID]), - format(' Alias [%s]', [Alias]), - format(' Path [%s]', [Path]), - format(' Checkdisk [%d]', [Byte(CheckDisk)])]); {!!.13} - - Error := FServerEngine.DatabaseAddAlias(Alias, - Path, - CheckDisk, - dmClientID); - end; { with } - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmDatabaseAddAlias, Error, nil, 0); -end; -{--------} -procedure TffServerCommandHandler.nmDatabaseAliasList(var Msg : TffDataMessage); -var - aBuffer : pointer; - aList : TList; - anAlias : PffAliasDescriptor; - Error : TffResult; - index : longInt; - Stream: TMemoryStream; - StreamSize : longInt; -begin - with Msg do begin - - if FLogEnabled then - ichLogAll(['DatabaseAliasList', - format(csClientID, [dmClientID])]); - - Stream := TMemoryStream.Create; - aList := TList.Create; - try - Error := FServerEngine.DatabaseAliasList(aList, dmClientID); - {Write the list of alias information to the stream. } - for index := 0 to pred(aList.count) do begin - anAlias := PffAliasDescriptor(aList.items[index]); - Stream.WriteBuffer(anAlias^,sizeOf(TffAliasDescriptor)); - end; - - { Free the returned items. } - for index := pred(aList.Count) downto 0 do begin - anAlias := PffAliasDescriptor(aList.items[index]); - FFFreeMem(anAlias, sizeOf(TffAliasDescriptor)); - end; - - StreamSize := Stream.Size; - FFGetMem(aBuffer, StreamSize); - Stream.Position := 0; - Stream.Read(aBuffer^, StreamSize); - - if FLogEnabled and (Error = 0) then - ichLogBlock(' List', Stream.Memory, StreamSize); - - TffBaseTransport.Reply(ffnmDatabaseAliasList, Error, aBuffer, StreamSize); - FFFreeMem(aBuffer, StreamSize); - - finally - Stream.Free; - aList.Free; - end;{try..finally} - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - end; -end; -{--------} -procedure TffServerCommandHandler.nmDatabaseChgAliasPath(var Msg : TffDataMessage); -{Rewritten !!.11} -var - Error : TffResult; -begin - if Msg.dmDataLen = SizeOf(TffnmOldDatabaseChgAliasPathReq) then - with Msg, PffnmOldDatabaseChgAliasPathReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DatabaseChgAliasPath - Old', - format(csClientID, [dmClientID]), - format(' Alias [%s]', [Alias]), - format(' NewPath [%s]', [NewPath])]); - - Error := FServerEngine.DatabaseChgAliasPath(Alias, - NewPath, - False, - dmClientID); - end { with } - else - with Msg, PffnmDatabaseChgAliasPathReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DatabaseChgAliasPath', - format(csClientID, [dmClientID]), - format(' Alias [%s]', [Alias]), - format(' NewPath [%s]', [NewPath]), - format(' Checkdisk [%s]', [Byte(CheckDisk)])]); - - Error := FServerEngine.DatabaseChgAliasPath(Alias, - NewPath, - CheckDisk, - dmClientID); - end; { with } - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmDatabaseChgAliasPath, Error, nil, 0); - -end; -{--------} -procedure TffServerCommandHandler.nmDatabaseClose(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmDatabaseCloseReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DatabaseClose', - format(csClientID, [dmClientID]), - format(' DBaseID %d', [DatabaseID])]); - - Error := FServerEngine.DatabaseClose(DatabaseID); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmDatabaseClose, Error, nil, 0); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmDatabaseDeleteAlias(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmDatabaseDeleteAliasReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DatabaseDeleteAlias', - format(csClientID, [dmClientID]), - format(' Alias [%s]', [Alias])]); - - Error := FServerEngine.DatabaseDeleteAlias(Alias, dmClientID); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmDatabaseDeleteAlias, Error, nil, 0); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmDatabaseGetAliasPath(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmDatabaseGetAliasPathRpy; - Path : TffPath; -begin - with Msg, PffnmDatabaseGetAliasPathReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DatabaseGetAliasPath', {!!.10} - Format(csClientID, [dmClientID]), - Format(' Alias %s', [Alias])]); - - Error := FServerEngine.DatabaseGetAliasPath(Alias, Path, dmClientID); - - if (Error = 0) then - Reply.Path := Path; - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' Path %s', [Reply.Path]); {!!.02} - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmDatabaseGetAliasPath, Error, @Reply, SizeOf(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmDatabaseGetFreeSpace(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmDatabaseGetFreeSpaceRpy; - FreeSpace : Longint; -begin - with Msg, PffnmDatabaseGetFreeSpaceReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DatabaseGetFreespace', - Format(csClientID, [dmClientID]), - Format(' DBaseID %d', [DatabaseID])]); - - Error := FServerEngine.DatabaseGetFreeSpace(DatabaseID, FreeSpace); - - if (Error = 0) then - Reply.FreeSpace := FreeSpace; - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' Free Space %d', [Reply.FreeSpace]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmDatabaseGetFreeSpace, Error, @Reply, SizeOf(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmDatabaseModifyAlias(var Msg : TffDataMessage); -{Rewritten !!.11} -var - Error : TffResult; -begin - if Msg.dmDataLen = SizeOf(TffnmOldDatabaseModifyAliasReq) then - with Msg, PffnmOldDatabaseModifyAliasReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['DatabaseModifyAlias - Old', - format(csClientID, [ClientID]), - format(' Alias Name [%s]', [Alias]), - format(' New Name [%s]', [NewName]), - format(' New Path [%s]', [NewPath])]); - - Error := FServerEngine.DatabaseModifyAlias(ClientID, - Alias, - NewName, - NewPath, - False); - end { while } - else - with Msg, PffnmDatabaseModifyAliasReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['DatabaseModifyAlias', - format(csClientID, [ClientID]), - format(' Alias Name [%s]', [Alias]), - format(' New Name [%s]', [NewName]), - format(' New Path [%s]', [NewPath]), - format(' Check Disk [%s]', [Byte(CheckDisk)])]); - - Error := FServerEngine.DatabaseModifyAlias(ClientID, - Alias, - NewName, - NewPath, - CheckDisk); - end; { while } - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmDatabaseModifyAlias, Error, nil, 0); -end; -{--------} -procedure TffServerCommandHandler.nmDetachServerJIC(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg do begin - if FLogEnabled then - ichLogAll(['DetachServer - just in case', - format(csClientID, [dmClientID])]); - Error := FServerEngine.ClientRemove(dmClientID); - { No response necessary. } - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - end; -end; -{--------} -procedure TffServerCommandHandler.nmDatabaseOpen(var Msg : TffDataMessage); -var - Error : TffResult; - aDatabaseID : TffDatabaseID; - Reply : TffnmDatabaseOpenRpy; -begin - with Msg, PffnmDatabaseOpenReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DatabaseOpen', - format(csClientID, [dmClientID]), - format(' Alias [%s]', [Alias]), - format(' OpenMode %d', [byte(OpenMode)]), - format(' ShrMode %d', [byte(ShareMode)]), - format(' Timeout %d', [Timeout])]); - - Error := FServerEngine.DatabaseOpen(dmClientID, - Alias, - OpenMode, - ShareMode, - Timeout, - aDatabaseID); - if (Error = 0) then - Reply.DatabaseID := aDatabaseID; - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' DBase ID %d', [Reply.DatabaseID]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmDatabaseOpen, Error, @Reply, sizeof(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmDatabaseOpenNoAlias(var Msg : TffDataMessage); -var - Error : TffResult; - aDatabaseID : TffDatabaseID; - Reply : TffnmDatabaseOpenNoAliasRpy; -begin - with Msg, PffnmDatabaseOpenNoAliasReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DatabaseOpenNoAlias', - format(csClientID, [dmClientID]), - format(' Path [%s]', [Path]), - format(' OpenMode %d', [byte(OpenMode)]), - format(' ShrMode %d', [byte(ShareMode)]), - format(' Timeout %d', [Timeout])]); - - Error := FServerEngine.DatabaseOpenNoAlias(dmClientID, - Path, - OpenMode, - ShareMode, - Timeout, - aDatabaseID); - if (Error = 0) then - Reply.DatabaseID := aDatabaseID; - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' DBase ID %d', [Reply.DatabaseID]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmDatabaseOpenNoAlias, Error, @Reply, sizeof(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmDatabaseSetTimeout(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmDatabaseSetTimeoutReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DatabaseSetTimeout', - format(' DatabaseID %d', [DatabaseID]), - format(' Timeout %d', [Timeout])]); - - Error := FServerEngine.DatabaseSetTimeout(DatabaseID, Timeout); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - TffBaseTransport.Reply(ffnmDatabaseSetTimeout, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmDatabaseTableExists(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmDatabaseTableExistsRpy; -begin - with Msg, PffnmDatabaseTableExistsReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DatabaseTableExists', - format(' DatabaseID %d', [DatabaseID]), - format(' TblName %s', [TableName])]); {!!.01} - - Error := FServerEngine.DatabaseTableExists(DatabaseID, TableName, Reply.Exists); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - TffBaseTransport.Reply(ffnmDatabaseTableExists, Error, @Reply, sizeof(Reply)); {!!.01} - end; -end; -{--------} -procedure TffServerCommandHandler.nmDatabaseTableList(var Msg : TffDataMessage); -var - aBuffer : Pointer; - aList : TList; - aTable : PffTableDescriptor; - Error : TffResult; - index : longInt; - Stream: TMemoryStream; - StreamSize : longInt; -begin - with Msg, PffnmDatabaseTableListReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DatabaseTableList', - format(csClientID, [dmClientID]), - format(' DBaseID %d', [DatabaseID]), - format(' Mask [%s]', [Mask])]); - - aList := TList.Create; - Stream := TMemoryStream.Create; - try - Error := FServerEngine.DatabaseTableList(DatabaseID, Mask, aList); - { Write the table descriptions to the stream. } - for index := 0 to pred(aList.Count) do begin - aTable := PffTableDescriptor(aList.Items[index]); - Stream.WriteBuffer(aTable^, sizeOf(TffTableDescriptor)); - end; - - { Free the table descriptions. } - for index := pred(aList.Count) downto 0 do begin - aTable := PffTableDescriptor(aList.Items[index]); - FFFreeMem(aTable, sizeOf(TffTableDescriptor)); - end; - - StreamSize := Stream.Size; - FFGetMem(aBuffer, StreamSize); - Stream.Position := 0; - Stream.Read(aBuffer^, StreamSize); - - if FLogEnabled and(Error = 0) then - ichLogBlock(' List', Stream.Memory, StreamSize); - TffBaseTransport.Reply(ffnmDatabaseTableList, Error, aBuffer, StreamSize); - FFFreeMem(aBuffer, StreamSize); - - finally - aList.Free; - Stream.Free; - end; - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmDatabaseTableLockedExclusive(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmDatabaseTableLockedExclusiveRpy; -begin - with Msg, PffnmDatabaseTableLockedExclusiveReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DatabaseTableExists', - format(' DatabaseID %d', [DatabaseID]), - format(' TblName %d', [TableName])]); - - Error := FServerEngine.DatabaseTableLockedExclusive(DatabaseID, TableName, Reply.Locked); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - TffBaseTransport.Reply(ffnmDatabaseTableLockedExclusive, Error, nil, 0); - end; -end; - -{--------} -procedure TffServerCommandHandler.nmDeleteBLOB(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmDeleteBLOBReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DeleteBLOB', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(csBLOBNr, [BLOBNr.iHigh, BLOBNr.iLow])]); {!!.03} - - Error := FServerEngine.BLOBDelete(CursorID, BLOBNr); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmDeleteBLOB, Error, nil, 0); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmDeleteTable(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmDeleteTableReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DeleteTable', - format(csClientID, [dmClientID]), - format(' DBase ID %d', [DatabaseID]), - format(' TblName [%s]', [TableName])]); - - Error := FServerEngine.TableDelete(DatabaseID, TableName); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmDeleteTable, Error, nil, 0); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmDropIndex(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmDropIndexReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['DropIndex', - format(csClientID, [dmClientID]), - format(' DBase ID %d', [DatabaseID]), - format(csCursorID, [CursorID]), - format(' TblName [%s]', [TableName]), - format(' InxName [%s]', [IndexName]), - format(' IndexID [%d]', [IndexNumber])]); - - Error := FServerEngine.TableDropIndex(DatabaseID, CursorID, TableName, - IndexName, IndexNumber); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmDropIndex, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmEmptyTable(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmEmptyTableReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['EmptyTable', - format(csClientID, [dmClientID]), - format(' DBase ID %d', [DatabaseID]), - format(csCursorID, [CursorID]), - format(' TblName [%s]', [TableName])]); - - Error := FServerEngine.TableEmpty(DatabaseID, CursorID, TableName); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmEmptyTable, Error, nil, 0); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmEndTransaction(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmEndTransactionReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['EndTransaction', - format(' ClientID %d', [dmClientID]), - format(' Database ID %d', [DatabaseID]), - format(' Commit? %d', [byte(ToBeCommitted)])]); - - if ToBeCommitted then - Error := FServerEngine.TransactionCommit(DatabaseID) - else - Error := FServerEngine.TransactionRollback(DatabaseID); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmEndTransaction, Error, nil, 0); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmFreeBLOB(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmFreeBLOBReq( dmData )^ do begin - - if FLogEnabled then - ichLogAll(['FreeBLOB', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(csBlobNr, [BLOBNr.iHigh, BLOBNr.iLow]), {!!.03} - format(' Read-Only %d', [byte(readOnly)])]); - - Error := FServerEngine.BLOBFree(CursorID, BLOBNr, readOnly); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmFreeBLOB, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmGetTableAutoIncValue(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmGetTableAutoIncValueRpy; -begin - with Msg, PffnmGetTableAutoIncValueReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['GetTableAutoIncValue', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID])]); - Error := FServerEngine.TableGetAutoInc(CursorID, Reply.AutoIncValue); - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' AutoInc %d', [Reply.AutoIncValue]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmGetTableAutoIncValue, Error, @Reply, sizeof(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmGetBLOBLength(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmGetBLOBLengthRpy; -begin - with Msg, PffnmGetBLOBLengthReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['GetBLOBLength', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(csBLOBNr, [BLOBNr.iHigh, BLOBNr.iLow])]); {!!.03} - - Error := FServerEngine.BLOBGetLength(CursorID, BLOBNr, Reply.BLOBLength); - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' BLOBLen %d', [Reply.BLOBLength]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmGetBLOBLength, Error, @Reply, sizeof(Reply)); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmGetRebuildStatus(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmGetRebuildStatusRpy; -begin - with Msg, PffnmGetRebuildStatusReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['GetRebuildStatus', - format(csClientID, [dmClientID]), - format(' RebldID %d', [RebuildID])]); - - Error := FServerEngine.RebuildGetStatus(RebuildID, dmClientID, Reply.IsPresent, Reply.Status); - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' IsThere %d', [ord(Reply.IsPresent)]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmGetRebuildStatus, Error, @Reply, sizeof(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmGetServerDateTime(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmGetServerDateTimeRpy; -begin - with Msg do begin - - if FLogEnabled then - ichLog('GetServerDateTime'); - - Reply.ServerNow := Now; - Error := 0; - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' DateTime %s', [DateTimeToStr(Reply.ServerNow)]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmGetServerDateTime, Error, @Reply, sizeof(Reply)); - end; -end; -{--------} {begin !!.07} -procedure TffServerCommandHandler.nmGetServerSystemTime(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmGetServerSystemTimeRpy; -begin - with Msg do begin - - if FLogEnabled then - ichLog('GetServerSystemTime'); - - Error := FServerEngine.GetServerSystemTime(Reply.ServerNow); - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' SystemTime %s', [DateTimeToStr(SystemTimeToDateTime(Reply.ServerNow))]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmGetServerSystemTime, Error, @Reply, sizeof(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmGetServerGUID(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmGetServerGUIDRpy; -begin - with Msg do begin - - if FLogEnabled then - ichLog('GetServerGUID'); - - Error := FServerEngine.GetServerGUID(Reply.GUID); - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' GUID %s', [GuidToString(Reply.GUID)]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmGetServerGUID, Error, @Reply, sizeof(Reply)); - end; -end; -{--------} {end !!.07} -procedure TffServerCommandHandler.nmGetServerID(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmGetServerIDRpy; -begin - with Msg do begin - - if FLogEnabled then - ichLog('GetServerID'); - - Error := FServerEngine.GetServerID(Reply.UniqueID); - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' UniqueID %s', [GuidToString(Reply.UniqueID)]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmGetServerID, Error, @Reply, sizeof(Reply)); - end; -end; -{--------} {end !!.07} -procedure TffServerCommandHandler.nmGetTableDictionary(var Msg : TffDataMessage); -var - aBuffer : Pointer; - Error : TffResult; - Stream : TMemoryStream; - StreamSize : longInt; -begin - with Msg, PffnmGetTableDictionaryReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['GetTableDictionary', - format(csClientID, [dmClientID]), - format(' DBase ID %d', [DatabaseID]), - format(' TblName [%s]', [TableName])]); - - Stream := TMemoryStream.Create; - try - Error := FServerEngine.TableGetDictionary(DatabaseID, - TableName, - false, - Stream); - StreamSize := Stream.Size; - FFGetMem(aBuffer, StreamSize); - Stream.Position := 0; - Stream.Read(aBuffer^, StreamSize); - - if FLogEnabled and (Error = 0) then - ichLogBlock(' Dictionary', Stream.Memory, Stream.Size); - TffBaseTransport.Reply(ffnmGetTableDictionary, Error, aBuffer, StreamSize); - FFFreeMem(aBuffer, StreamSize); - - finally - Stream.Free; - end;{try..finally} - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmGetTableRecCount(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmGetTableRecCountRpy; -begin - with Msg, PffnmGetTableRecCountReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['GetTableRecCount', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID])]); - - Error := FServerEngine.TableGetRecCount(CursorID, Reply.RecCount); - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' Count %d', [byte(Reply.RecCount)]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmGetTableRecCount, Error, @Reply, sizeof(Reply)); - - end; -end; -{Begin !!.07} -{--------} -procedure TffServerCommandHandler.nmGetTableRecCountAsync(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmGetTableRecCountAsyncRpy; -begin - with Msg, PffnmGetTableRecCountAsyncReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['GetTableRecCountAsync', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID])]); - - Error := FServerEngine.TableGetRecCountAsync(CursorID, Reply.RebuildID); - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt('RebuildID %d', [Reply.RebuildID]); - ichLogFmt(csErr, [Error]); - end; { if } - - TffBaseTransport.Reply(ffnmGetTableRecCountAsync, Error, @Reply, - SizeOf(Reply)); - end; { with } -end; -{End !!.07} -{Begin !!.11} -{--------} -procedure TffServerCommandHandler.nmGetTableVersion(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmGetTableVersionRpy; -begin - with Msg, PffnmGetTableVersionReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['GetTableVersion', - format(csClientID, [dmClientID]), - format(' DBase ID %d', [DatabaseID]), - format(' TblName [%s]', [TableName])]); - - Error := FServerEngine.TableVersion(DatabaseID, TableName, Reply.Version); - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' Version %d', [Reply.Version]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmGetTableVersion, Error, @Reply, sizeof(Reply)); - - end; -end; -{End !!.11} -{--------} -procedure TffServerCommandHandler.nmIsTableLocked(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmIsTableLockedRpy; -begin - with Msg, PffnmIsTableLockedReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['IsTableLocked', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' LockType %d', [byte(LockType)])]); - - Error := FServerEngine.TableIsLocked(CursorID, LockType, Reply.IsLocked); - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' Locked? %d', [byte(Reply.IsLocked)]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmIsTableLocked, Error, @Reply, sizeof(Reply)); - - end; -end; -{Begin !!.03} -{--------} -procedure TffServerCommandHandler.nmListBLOBSegments(var Msg : TffDataMessage); -var - aBuffer : pointer; - Error : TffResult; - aStream: TMemoryStream; - StreamSize : longInt; -begin - with Msg, PffnmListBLOBSegmentsReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['ListBLOBSegments', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(csBLOBNr, [BLOBNr.iHigh, BLOBNr.iLow])]); - - aStream := TMemoryStream.Create; - try - Error := FServerEngine.BLOBListSegments(CursorID, BLOBNr, aStream); - StreamSize := aStream.Size; - FFGetMem(aBuffer, StreamSize); - aStream.Position := 0; - aStream.Read(aBuffer^, StreamSize); - - if FLogEnabled and (Error = 0) then - ichLogBlock(' List', aStream.Memory, StreamSize); - - TffBaseTransport.Reply(ffnmListBLOBSegments, Error, aBuffer, - StreamSize); - FFFreeMem(aBuffer, StreamSize); - - finally - aStream.Free; - end;{try..finally} - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - end; -end; -{End !!.03} -{--------} -procedure TffServerCommandHandler.nmOpenTable(var Msg : TffDataMessage); -var - aBuffer : pointer; - CursorID : TffCursorID; - Error : TffResult; - Stream : TMemoryStream; - StreamSize : longInt; -begin - with Msg, PffnmOpenTableReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['OpenTable', - format(csClientID, [dmClientID]), - format(' DBase ID %d', [DatabaseID]), - format(' TblName [%s]', [TableName]), - format(' InxName [%s]', [IndexName]), - format(' InxNum %d', [IndexNumber]), - format(' OpenMode %d', [byte(OpenMode)]), - format(' Timeout %d', [Timeout]), {!!.06} - format(' ShrMode %d', [byte(ShareMode)])]); - - Stream := TMemoryStream.Create; - try - Error := FServerEngine.TableOpen(DatabaseID, - TableName, - false, - IndexName, - IndexNumber, - OpenMode, - ShareMode, - Timeout, - CursorID, - Stream); - { Note that TffServerEngine.TableOpen writes the cursorID to the - stream. } - if Stream.Size > 0 then begin - StreamSize := Stream.Size; - FFGetMem(aBuffer, StreamSize); - Stream.Position := 0; - Stream.Read(aBuffer^, StreamSize); - end else begin - aBuffer := nil; - StreamSize := 0; - end; - - if FLogEnabled then begin - if (Error = 0) then - ichLogBlock(' Dictionary, etc', Stream.Memory, StreamSize); - ichLogFmt(csErr, [Error]); - end; - - TffBaseTransport.Reply(ffnmOpenTable, Error, aBuffer, StreamSize); - - if assigned(aBuffer) then - FFFreeMem(aBuffer, StreamSize); - - finally - Stream.Free; - end;{try..finally} - -// if FLogEnabled then {duplicated from a few lines above} {!!.06} -// ichLogFmt(csErr, [Error]); {!!.06} - - end; -end; -{--------} -procedure TffServerCommandHandler.nmPackTable(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmPackTableRpy; -begin - with Msg, PffnmPackTableReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['PackTable', - format(csClientID, [dmClientID]), - format(' DBase ID %d', [DatabaseID]), - format(' TblName [%s]', [TableName])]); - - Error := FServerEngine.TablePack(DatabaseID, TableName, Reply.RebuildID); - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' RbldID %d', [Reply.RebuildID]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmPackTable, Error, @Reply, sizeof(Reply)); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmReadBLOB( var Msg : TffDataMessage ); -var - Error : TffResult; - Reply : PffnmReadBLOBRpy; - RpyLen : longint; -begin - with Msg, PffnmReadBLOBReq( dmData )^ do begin - - if FLogEnabled then - ichLogAll(['ReadBLOB', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(csBlobNr, [BLOBNr.iLow, BLOBNr.iHigh]), - format(' Offset %d', [Offset]), - format(' Len %d', [Len])]); - - FFGetMem(Reply, Len + sizeof(longint)); - try - Error := FServerEngine.BLOBRead(CursorID, BLOBNr, Offset, Len, - Reply^.BLOB, Reply^.BytesRead ); - if Error = 0 then - RpyLen := Reply^.BytesRead + sizeof(longint) - else - RpyLen := 0; - - if FLogEnabled then begin - if (Error = 0) then begin - ichLogFmt(' BytesRead %d', [Reply^.BytesRead]); - ichLogBlock(' BLOB', @Reply^.BLOB, Reply^.BytesRead); - end; - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmReadBLOB, Error, Reply, RpyLen); - - finally - FFFreeMem(Reply, Len + sizeof(longint)); - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmRecordDelete(var Msg : TffDataMessage); -var - Error : TffResult; - pData : PffByteArray; -begin - with Msg, PffnmRecordDeleteReq( dmData )^ do begin - - if FLogEnabled then - ichLogAll(['RecordDelete', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' RecLen %d', [RecLen])]); - - if (RecLen <> 0) then - FFGetMem(pData, RecLen) - else - pData := nil; - try - Error := FServerEngine.RecordDelete(CursorID, pData); - - if FLogEnabled and (Error = 0) and (RecLen <> 0) then - ichLogBlock(' Record', pData, RecLen); - TffBaseTransport.Reply(ffnmRecordDelete, Error, pData, RecLen); - - finally - if (RecLen <> 0) then - FFFreeMem(pData, RecLen); - end;{try..finally} - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmRecordDeleteBatch(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : PffLongintArray; - DataSize : longint; -begin - with Msg, PffnmRecordDeleteBatchReq( dmData )^ do begin - - if FLogEnabled then - ichLogAll(['RecordDeleteBatch', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' BMCount %d', [BMCount]), - format(' BMLen %d', [BMLen])]); - - DataSize := BMCount * sizeof(longint); - FFGetMem(Reply, DataSize); - try - Error := FServerEngine.RecordDeleteBatch(CursorID, BMCount, BMLen, - PffByteArray(@BMArray), - Reply); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmRecordDeleteBatch, Error, Reply, DataSize); - - finally - FFFreeMem(Reply, DataSize); - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmRecordExtractKey(var Msg : TffDataMessage); -var - Error : TffResult; - pKey : PffByteArray; -begin - with Msg, PffnmRecordExtractKeyReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['RecordExtractKey', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' KeyLen %d', [KeyLen]), - format(' ForCurrRec %d', [ord(ForCurrentRecord)])]); - - if (KeyLen <> 0) then - FFGetMem(pKey, KeyLen) - else - pKey := nil; - try - if ForCurrentRecord then - Error := FServerEngine.RecordExtractKey(CursorID, nil, pKey) - else - Error := FServerEngine.RecordExtractKey(CursorID, @Data, pKey); - - if FLogEnabled and (Error = 0) then - ichLogBlock(' Key', pKey, KeyLen); - TffBaseTransport.Reply(ffnmRecordExtractKey, Error, pKey, KeyLen); - - finally - if (KeyLen <> 0) then - FFFreeMem(pKey, KeyLen); - end; - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmRecordGet(var Msg : TffDataMessage); -var - Error : TffResult; - MsgSize : longint; - MsgData : PffByteArray; - SubMsg : PffsmHeader; - Buffer : PffByteArray; -begin - with Msg, PffnmRecordGetReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['RecordGet', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' LockType %d', [byte(LockType)]), - format(' RecLen %d', [RecLen]), - format(' BMSize %d', [BookmarkSize])]); - - {we shall be sending back a multipart message: get record followed - by getbookmark} - MsgSize := (2 * ffc_SubMsgHeaderSize) + RecLen + BookmarkSize; - FFGetMem(MsgData, MsgSize); - try - SubMsg := PffsmHeader(MsgData); - if (RecLen = 0) then - Buffer := nil - else - Buffer := PffByteArray(@SubMsg^.smhData); - Error := FServerEngine.RecordGet(CursorID, LockType, Buffer); - if (Error <> 0) then begin - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmRecordGet, Error, nil, 0); - - Exit; - end; - - if FLogEnabled then begin - if (Error = 0) then - ichLogBlock(' Record', Buffer, RecLen); - ichLogFmt(csErr, [Error]); - end; - - - SubMsg := FFCreateSubMessage(SubMsg, - ffnmRecordGet, - Error, - nmdByteArray, - @SubMsg^.smhData, - RecLen); - - if FLogEnabled then - ichLog('CursorGetBookmark (multipart)'); - - - if (BookmarkSize <> 0) then begin - Buffer := PffByteArray(@SubMsg^.smhData); - Error := FServerEngine.CursorGetBookmark(CursorID, Buffer); - end else - Error := DBIERR_INVALIDBOOKMARK; - - - if FLogEnabled then begin - if (Error = 0) then - ichLogBlock(' Bookmark', Buffer, BookmarkSize); - ichLogFmt(csErr, [Error]); - end; - - - FFCreateSubMessage(SubMsg, - ffnmCursorGetBookmark, - Error, - nmdByteArray, - @SubMsg^.smhData, - BookmarkSize); - TffBaseTransport.Reply(ffnmMultiPartMessage, 0, MsgData, MsgSize); - - finally - FFFreeMem(MsgData, MsgSize); - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmRecordGetBatch(var Msg : TffDataMessage); -var - Error : TffResult; - pData : PffnmRecordGetBatchRpy; - DataSize : longint; -begin - with Msg, PffnmRecordGetBatchReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['RecordGetBatch', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' RecLen %d', [RecLen]), - format(' RecCount %d', [RecCount])]); - - DataSize := 2*sizeof(longint) + (RecLen * RecCount); - FFGetMem(pData, DataSize); - try - pData^.RecCount := 0; { just to be safe } - Error := FServerEngine.RecordGetBatch(CursorID, RecCount, - RecLen, - pData^.RecCount, - PffByteArray(@pData^.RecArray), - pData^.Error); - if FLogEnabled then - ichLogAll([format(' RecCount %d', [pData^.RecCount]), - format(' Error %x', [pData^.Error]), - format(csErr, [Error])]); - - TffBaseTransport.Reply(ffnmRecordGetBatch, Error, - pData, (pdata^.RecCount * RecLen) + 2*Sizeof(Longint)); - - finally - if (DataSize <> 0) then - FFFreeMem(pData, DataSize); - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmRecordGetForKey(var Msg : TffDataMessage); -var - Error : TffResult; - MsgSize : longint; - MsgData : PffByteArray; - SubMsg : PffsmHeader; - Buffer : PffByteArray; -begin - with Msg, PffnmRecordGetForKeyReq(dmData)^ do begin - - if FLogEnabled then begin - ichLogAll(['RecordGetForKey', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' DrctKey %d', [byte(DirectKey)]), - format(' FldCount %d', [FieldCount]), - format(' PartLen %d', [PartialLen]), - format(' RecLen %d', [RecLen]), - format(' DataLen %d', [KeyDataLen]), - format(' BMSize %d', [BookmarkSize])]); - ichLogBlock(' Data', @KeyData, KeyDataLen); - end; - - - {we shall be sending back a multipart message: RecordGetForKey} - {followed by getbookmark} - MsgSize := (2 * ffc_SubMsgHeaderSize) + RecLen + BookmarkSize; - FFGetMem(MsgData, MsgSize); - try - { do the RecordGetForKey First } - SubMsg := PffsmHeader(MsgData); - if (RecLen = 0) then - Buffer := nil - else - Buffer := PffByteArray(@SubMsg^.smhData); - Error := FServerEngine.RecordGetForKey(CursorID, DirectKey, FieldCount, - PartialLen, @KeyData, Buffer, True); - if (Error <> 0) then begin - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmRecordGetForKey, Error, nil, 0); - exit; - end; - - if FLogEnabled then begin - if Error = 0 then - ichLogBlock(' Record', Buffer, RecLen); - ichLogFmt(csErr, [Error]); - end; - - SubMsg := FFCreateSubMessage(SubMsg, - ffnmRecordGetForKey, - Error, - nmdByteArray, - @SubMsg^.smhData, - RecLen); - {Now do the GetBookmark } - - if FLogEnabled then - ichLog('CursorGetBookmark (multipart)'); - - if (BookmarkSize <> 0) then begin - Buffer := PffByteArray(@SubMsg^.smhData); - Error := FServerEngine.CursorGetBookmark(CursorID, Buffer); - end - else - Error := DBIERR_INVALIDBOOKMARK; - - if FLogEnabled then begin - if (Error = 0) then - ichLogBlock(' Bookmark', Buffer, BookmarkSize); - ichLogFmt(csErr, [Error]); - end; - - FFCreateSubMessage(SubMsg, - ffnmCursorGetBookmark, - Error, - nmdByteArray, - @SubMsg^.smhData, - BookmarkSize); - TffBaseTransport.Reply(ffnmMultiPartMessage, 0, MsgData, MsgSize); - finally - FFFreeMem(MsgData, MsgSize); - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmRecordGetForKey2(var Msg : TffDataMessage); -var - Error : TffResult; - MsgSize : longint; - MsgData : PffByteArray; - SubMsg : PffsmHeader; - Buffer : PffByteArray; -begin - with Msg, PffnmRecordGetForKeyReq2(dmData)^ do begin - - if FLogEnabled then begin - ichLogAll(['RecordGetForKey2', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' DrctKey %d', [byte(DirectKey)]), - format(' FldCount %d', [FieldCount]), - format(' PartLen %d', [PartialLen]), - format(' RecLen %d', [RecLen]), - format(' DataLen %d', [KeyDataLen]), - format(' BMSize %d', [BookmarkSize]), - format(' FirstCl %d', [Byte(FirstCall)])]); - ichLogBlock(' Data', @KeyData, KeyDataLen); - end; - - - {we shall be sending back a multipart message: RecordGetForKey2} - {followed by getbookmark} - MsgSize := (2 * ffc_SubMsgHeaderSize) + RecLen + BookmarkSize; - FFGetMem(MsgData, MsgSize); - try - { do the RecordGetForKey First } - SubMsg := PffsmHeader(MsgData); - if (RecLen = 0) then - Buffer := nil - else - Buffer := PffByteArray(@SubMsg^.smhData); - Error := FServerEngine.RecordGetForKey(CursorID, DirectKey, FieldCount, - PartialLen, @KeyData, Buffer, FirstCall); - if (Error <> 0) then begin - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmRecordGetForKey2, Error, nil, 0); - exit; - end; - - if FLogEnabled then begin - if Error = 0 then - ichLogBlock(' Record', Buffer, RecLen); - ichLogFmt(csErr, [Error]); - end; - - {we don't need a multipart message in case of a error...} - if Error <> DBIERR_NONE then begin - TffBaseTransport.Reply(ffnmRecordGetForKey2, Error, nil, 0); - Exit; - end; - SubMsg := FFCreateSubMessage(SubMsg, - ffnmRecordGetForKey2, - Error, - nmdByteArray, - @SubMsg^.smhData, - RecLen); - {Now do the GetBookmark } - - if FLogEnabled then - ichLog('CursorGetBookmark (multipart)'); - - if (BookmarkSize <> 0) then begin - Buffer := PffByteArray(@SubMsg^.smhData); - Error := FServerEngine.CursorGetBookmark(CursorID, Buffer); - end - else - Error := DBIERR_INVALIDBOOKMARK; - - if FLogEnabled then begin - if (Error = 0) then - ichLogBlock(' Bookmark', Buffer, BookmarkSize); - ichLogFmt(csErr, [Error]); - end; - - FFCreateSubMessage(SubMsg, - ffnmCursorGetBookmark, - Error, - nmdByteArray, - @SubMsg^.smhData, - BookmarkSize); - TffBaseTransport.Reply(ffnmMultiPartMessage, 0, MsgData, MsgSize); - finally - FFFreeMem(MsgData, MsgSize); - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmRecordGetNext(var Msg : TffDataMessage); -var - Error : TffResult; - MsgSize : longint; - MsgData : PffByteArray; - SubMsg : PffsmHeader; - Buffer : PffByteArray; -begin - with Msg, PffnmRecordGetNextReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['RecordGetNext', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' LockType %d', [byte(LockType)]), - format(' RecLen %d', [RecLen]), - format(' BMSize %d', [BookmarkSize])]); - - {check the rights} - - {we shall be sending back a multipart message: getnextrecord - followed by getbookmark} - MsgSize := (2 * ffc_SubMsgHeaderSize) + RecLen + BookmarkSize; - FFGetMem(MsgData, MsgSize); - try - SubMsg := PffsmHeader(MsgData); - if (RecLen = 0) then - Buffer := nil - else - Buffer := PffByteArray(@SubMsg^.smhData); - Error := FServerEngine.RecordGetNext(CursorID, LockType, Buffer); - if (Error <> 0) then begin - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmRecordGetNext, Error, nil, 0); - Exit; - end; - - if FLogEnabled then begin - if (Error = 0) then - ichLogBlock(' Record', Buffer, RecLen); - ichLogFmt(csErr, [Error]); - end; - - SubMsg := FFCreateSubMessage(SubMsg, - ffnmRecordGetNext, - Error, - nmdByteArray, - @SubMsg^.smhData, - RecLen); - - if FLogEnabled then - ichLog('CursorGetBookmark (multipart)'); - - if (BookmarkSize <> 0) then begin - Buffer := PffByteArray(@SubMsg^.smhData); - Error := FServerEngine.CursorGetBookmark(CursorID, Buffer); - end - else - Error := DBIERR_INVALIDBOOKMARK; - - if FLogEnabled then begin - if (Error = 0) then - ichLogBlock(' Bookmark', Buffer, BookmarkSize); - ichLogFmt(csErr, [Error]); - end; - - FFCreateSubMessage(SubMsg, - ffnmCursorGetBookmark, - Error, - nmdByteArray, - @SubMsg^.smhData, - BookmarkSize); - TffBaseTransport.Reply(ffnmMultiPartMessage, 0, MsgData, MsgSize); - finally - FFFreeMem(MsgData, MsgSize); - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmRecordGetPrev(var Msg : TffDataMessage); -var - Error : TffResult; - MsgSize : longint; - MsgData : PffByteArray; - SubMsg : PffsmHeader; - Buffer : PffByteArray; -begin - with Msg, PffnmRecordGetPrevReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['RecordGetPrev', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' LockType %d', [byte(LockType)]), - format(' RecLen %d', [RecLen]), - format(' BMSize %d', [BookmarkSize])]); - - {check the rights} - - {we shall be sending back a multipart message: getnextrecord - followed by getbookmark} - MsgSize := (2 * ffc_SubMsgHeaderSize) + RecLen + BookmarkSize; - FFGetMem(MsgData, MsgSize); - try - SubMsg := PffsmHeader(MsgData); - if (RecLen = 0) then - Buffer := nil - else - Buffer := PffByteArray(@SubMsg^.smhData); - Error := FServerEngine.RecordGetPrior(CursorID, LockType, Buffer); - if (Error <> 0) then begin - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmRecordGetPrev, Error, nil, 0); - Exit; - end; - - if FLogEnabled then begin - if (Error = 0) then - ichLogBlock(' Record', Buffer, RecLen); - ichLogFmt(csErr, [Error]); - end; - - SubMsg := FFCreateSubMessage(SubMsg, - ffnmRecordGetPrev, - Error, - nmdByteArray, - @SubMsg^.smhData, - RecLen); - - if FLogEnabled then - ichLog('CursorGetBookmark (multipart)'); - - if (BookmarkSize <> 0) then begin - Buffer := PffByteArray(@SubMsg^.smhData); - Error := FServerEngine.CursorGetBookmark(CursorID, Buffer); - end - else - Error := DBIERR_INVALIDBOOKMARK; - - if FLogEnabled then begin - if (Error = 0) then - ichLogBlock(' Bookmark', Buffer, BookmarkSize); - ichLogFmt(csErr, [Error]); - end; - - FFCreateSubMessage(SubMsg, - ffnmCursorGetBookmark, - Error, - nmdByteArray, - @SubMsg^.smhData, - BookmarkSize); - TffBaseTransport.Reply(ffnmMultiPartMessage, 0, MsgData, MsgSize); - finally - FFFreeMem(MsgData, MsgSize); - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmRecordInsert(var Msg : TffDataMessage); -var - Error : TffResult; - MsgSize : longint; - MsgData : PffByteArray; - SubMsg : PffsmHeader; - Buffer : PffByteArray; -begin - with Msg, PffnmRecordInsertReq( dmData )^ do begin - - if FLogEnabled then - ichLogAll(['RecordInsert', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' RecLen %d', [RecLen]), - format(' BMSize %d', [BookmarkSize]), - format(' LockType %d', [byte(LockType)])]); - - {try and insert record} - Error := FServerEngine.RecordInsert( CursorID, LockType, @Data ); - if (Error <> 0) then begin - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmRecordInsert, Error, nil, 0); - Exit; - end; - - {we shall be sending back a multipart message: insertrecord, - followed by getrecord, followed by getbookmark} - MsgSize := (3 * ffc_SubMsgHeaderSize) + RecLen + BookmarkSize; - FFGetMem(MsgData, MsgSize); - try - SubMsg := PffsmHeader(MsgData); - {write the results of the insertrecord} - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - SubMsg := FFCreateSubMessage(SubMsg, - ffnmRecordInsert, - Error, - nmdByteArray, - nil, - 0); - - if FLogEnabled then - ichLog('RecordGet (multipart)'); - - Buffer := PffByteArray(@SubMsg^.smhData); - Error := FServerEngine.RecordGet(CursorID, ffltNoLock, Buffer); - - if FLogEnabled then begin - if (Error = 0) then - ichLogBlock(' Record', Buffer, RecLen); - ichLogFmt(csErr, [Error]); - end; - - SubMsg := FFCreateSubMessage(SubMsg, - ffnmRecordGet, - Error, - nmdByteArray, - @SubMsg^.smhData, - RecLen); - - if FLogEnabled then - ichLog('CursorGetBookmark (multipart)'); - - Buffer := PffByteArray(@SubMsg^.smhData); - Error := FServerEngine.CursorGetBookmark(CursorID, Buffer); - - if FLogEnabled then begin - if (Error = 0) then - ichLogBlock(' Bookmark', Buffer, BookmarkSize); - ichLogFmt(csErr, [Error]); - end; - - FFCreateSubMessage(SubMsg, - ffnmCursorGetBookmark, - Error, - nmdByteArray, - @SubMsg^.smhData, - BookmarkSize); - TffBaseTransport.Reply(ffnmMultiPartMessage, 0, MsgData, MsgSize); - finally - FFFreeMem(MsgData, MsgSize); - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmRecordInsertBatch(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : PffLongintArray; - DataSize : longint; -begin - with Msg, PffnmRecordInsertBatchReq( dmData )^ do begin - - if FLogEnabled then - ichLogAll(['RecordInsertBatch', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' RecCount %d', [RecCount]), - format(' RecLen %d', [RecLen])]); - - DataSize := RecCount * sizeof(longint); - FFGetMem(Reply, DataSize); - try - Error := FServerEngine.RecordInsertBatch(CursorID, RecCount, RecLen, - PffByteArray(@RecArray), - Reply); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmRecordInsertBatch, Error, Reply, DataSize); - - finally - FFFreeMem(Reply, DataSize); - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmRecordIsLocked(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmRecordIsLockedRpy; -begin - with Msg, PffnmRecordIsLockedReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['RecordIsLocked', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' LockType %d', [Byte(LockType)])]); - - Error := FServerEngine.RecordIsLocked(CursorID, LockType, Reply.IsLocked); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - TffBaseTransport.Reply(ffnmRecordIsLocked, Error, @Reply, SizeOf(Reply)); {!!.03} - - end; -end; -{--------} -procedure TffServerCommandHandler.nmRecordModify(var Msg : TffDataMessage); -var - Error : TffResult; - MsgSize : longint; - MsgData : PffByteArray; - SubMsg : PffsmHeader; - Buffer : PffByteArray; -begin - with Msg, PffnmRecordModifyReq( dmData )^ do begin - - if FLogEnabled then - ichLogAll(['RecordModify', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' RecLen %d', [RecLen]), - format(' BMSize %d', [BookmarkSize]), - format(' RelLock %d', [byte(RelLock)])]); - - {try and modify record} - Error := FServerEngine.RecordModify( CursorID, @Data, RelLock ); - if (Error <> 0) then begin - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmRecordModify, Error, nil, 0); - Exit; - end; - - {we shall be sending back a multipart message: modifyrecord, - followed by getrecord, followed by getbookmark} - MsgSize := (3 * ffc_SubMsgHeaderSize) + RecLen + BookmarkSize; - FFGetMem(MsgData, MsgSize); - try - SubMsg := PffsmHeader(MsgData); - {write the results of the insertrecord} - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - SubMsg := FFCreateSubMessage(SubMsg, - ffnmRecordModify, - Error, - nmdByteArray, - nil, - 0); - - if FLogEnabled then - ichLog('RecordGet (multipart)'); - - Buffer := PffByteArray(@SubMsg^.smhData); - Error := FServerEngine.RecordGet(CursorID, ffltNoLock, Buffer); - - if FLogEnabled then begin - if (Error = 0) then - ichLogBlock(' Record', Buffer, RecLen); - ichLogFmt(csErr, [Error]); - end; - - SubMsg := FFCreateSubMessage(SubMsg, - ffnmRecordGet, - Error, - nmdByteArray, - @SubMsg^.smhData, - RecLen); - - if FLogEnabled then - ichLog('CursorGetBookmark (multipart)'); - - Buffer := PffByteArray(@SubMsg^.smhData); - Error := FServerEngine.CursorGetBookmark(CursorID, Buffer); - - if FLogEnabled then begin - if (Error = 0) then - ichLogBlock(' Bookmark', Buffer, BookmarkSize); - ichLogFmt(csErr, [Error]); - end; - - FFCreateSubMessage(SubMsg, - ffnmCursorGetBookmark, - Error, - nmdByteArray, - @SubMsg^.smhData, - BookmarkSize); - TffBaseTransport.Reply(ffnmMultiPartMessage, 0, MsgData, MsgSize); - finally - FFFreeMem(MsgData, MsgSize); - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmRecordRelLock(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmRecordRelLockReq( dmData )^ do begin - - if FLogEnabled then - ichLogAll(['RecordRelLock', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' AllLocks %d', [byte(AllLocks)])]); - - Error := FServerEngine.RecordRelLock( CursorID, AllLocks ); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - TffBaseTransport.Reply(ffnmRecordRelLock, Error, nil, 0); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmReindexTable(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmReindexTableRpy; -begin - with Msg, PffnmReindexTableReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['ReindexTable', - format(csClientID, [dmClientID]), - format(' DBase ID %d', [DatabaseID]), - format(' TblName [%s]', [TableName]), - format(' InxName [%s]', [IndexName]), - format(' InxNum %d', [IndexNumber])]); - - Error := FServerEngine.TableRebuildIndex(DatabaseID, - TableName, - IndexName, - IndexNumber, - Reply.RebuildID); - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' RbldID %d', [Reply.RebuildID]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmReindexTable, Error, @Reply, sizeof(Reply)); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmRelTableLock(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmRelTableLockReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['RelTableLock', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' AllLocks %d', [byte(AllLocks)]), - format(' LockType %d', [byte(LockType)])]); - - Error := FServerEngine.TableLockRelease(CursorID, AllLocks); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmRelTableLock, Error, nil, 0); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmRenameTable(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmRenameTableReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['RenameTable', - format(csClientID, [dmClientID]), - format(' DBase ID %d', [DatabaseID]), - format(' OldTblName [%s]', [OldTableName]), - format(' NewTblName [%s]', [NewTableName])]); - - Error := FServerEngine.TableRename(DatabaseID, OldTableName, NewTableName); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmRenameTable, Error, nil, 0); - - end; -end; -{--------} -procedure TffServerCommandHandler.nmRestructureTable(var Msg : TffDataMessage); -{ Input stream is expected to be: - DatabaseId (longint) - TableName (TffTableName) - Dictionary (TffServerDataDict or TffDataDictionary) - FieldMap (one TffShStr for each field map entry; final entry - followed by a zero byte to signal end-of-list. If - no field map is given, then a single zero byte must be - present -} -var - Reply : TffnmRestructureTableRpy; - Error : TffResult; - Stream : TMemoryStream; - DatabaseID : LongInt; - TableName : TffTableName; - Dictionary : TffServerDataDict; - - DictionaryStart : Integer; - DictionaryEnd : Integer; - I : Integer; - - FieldMap: TffStringList; - LenByte: Byte; - FieldMapEntry: TffShStr; -begin - with Msg do begin - Stream := TMemoryStream.Create; - Stream.Write(dmData^, dmDataLen); - Stream.Position := 0; - Stream.Read(DatabaseID, SizeOf(DatabaseID)); - Stream.Read(TableName, SizeOf(TableName)); - Dictionary := TffServerDataDict.Create(4096); - try - - DictionaryStart := Stream.Position; - - Dictionary.ReadFromStream(Stream); - - DictionaryEnd := Stream.Position; - - - FieldMap := nil; - Stream.Read(LenByte, SizeOf(LenByte)); - if LenByte <> 0 then begin - FieldMap := TffStringList.Create; - try - repeat - Stream.Position := Stream.Position - SizeOf(LenByte); - Stream.Read(FieldMapEntry, LenByte + 1); - FieldMap.Insert(FieldMapEntry); - Stream.Read(LenByte, SizeOf(LenByte)); - until LenByte = 0; - except - FieldMap.Free; - raise; - end; - end; - try - - - if FLogEnabled then begin - ichLogAll(['RestructureTable', - format(csClientID, [dmClientID]), - format(' DBase ID %d', [DatabaseID]), - format(' TblName [%s]', [TableName])]); - ichLogBlock(' Dictionary', - Addr(PffByteArray(Stream.Memory)^[DictionaryStart]), - DictionaryEnd - DictionaryStart); - if not Assigned(FieldMap) then - ichLog(' FieldMap nil') - else begin - ichLogFmt(' FieldMap [%s]', [FieldMap.Strings[0]]); - for I := 1 to FieldMap.Count - 1 do - ichLogFmt(' [%s]', [FieldMap.Strings[I]]); - end; - end; - - Error := FServerEngine.TableRestructure(DatabaseID, - TableName, - Dictionary, - FieldMap, - Reply.RebuildID); - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' ReBldID %d', [Reply.RebuildID]); - ichLogFmt(csErr, [Error]); - end; - - TffBaseTransport.Reply(ffnmRestructureTable, Error, @Reply, SizeOf(Reply)); - - finally - FieldMap.Free; - end; - finally - Dictionary.Free; - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmServerIsReadOnly(var Msg : TffDataMessage); -var - Reply : TffnmServerIsReadOnlyRpy; -begin - with Msg do begin - - if FLogEnabled then - ichLogAll(['ServerIsReadOnly', - format(csClientID, [dmClientID])]); - - Reply.IsReadOnly := FServerEngine.IsReadOnly; - if FLogEnabled then - ichLogFmt(csErr, [0]); - TffBaseTransport.Reply(ffnmServerIsReadOnly, 0, @Reply, SizeOf(Reply)); {!!.01} - - end; -end; -{--------} {begin !!.07} -procedure TffServerCommandHandler.nmServerStatistics(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmServerStatisticsRpy; -begin - with Msg do begin - - if FLogEnabled then - ichLogAll(['ServerStatistics', - format(csClientID, [dmClientID])]); - - Error := FServerEngine.GetServerStatistics(Reply.Stats); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - TffBaseTransport.Reply(ffnmServerStatistics, Error, @Reply, SizeOf(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmCmdHandlerStatistics(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmCmdHandlerStatisticsRpy; -begin - with Msg, PffnmCmdHandlerStatisticsReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['CmdHandlerStatistics', - Format(csClientID, [dmClientID]), - Format(' CmdHandlerIdx %d', [CmdHandlerIdx])]); - - Error := FServerEngine.GetCommandHandlerStatistics(CmdHandlerIdx, Reply.Stats); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - TffBaseTransport.Reply(ffnmCmdHandlerStatistics, Error, @Reply, SizeOf(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmTransportStatistics(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmTransportStatisticsRpy; -begin - with Msg, PffnmTransportStatisticsReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['TransportStatistics', - Format(csClientID, [dmClientID]), - Format(' CmdHandlerIdx %d', [CmdHandlerIdx]), - Format(' TramsportIdx %d', [TransportIdx])]); - - Error := FServerEngine.GetTransportStatistics(CmdHandlerIdx, - TransportIdx, - Reply.Stats); - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - - TffBaseTransport.Reply(ffnmTransportStatistics, Error, @Reply, SizeOf(Reply)); - end; -end; -{--------} {end !!.07} -procedure TffServerCommandHandler.nmSessionAdd(var Msg : TffDataMessage); -var - Error : TffResult; - SessionID : TffSessionID; - Reply : TffnmSessionAddRpy; -begin - with Msg, PffnmSessionAddReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['SessionAdd', - format(csClientID, [dmClientID]), - format(' Timeout %d', [Timeout])]); - - Error := FServerEngine.SessionAdd(dmClientID, Timeout, SessionID); - if (Error = 0) then - Reply.SessionID := SessionID; - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' Session %d', [Reply.SessionID]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmSessionAdd, Error, @Reply, sizeof(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmSessionClose(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmSessionCloseReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['SessionClose', - format(csClientID, [dmClientID]), - format(' Session %d', [SessionID])]); - - Error := FServerEngine.SessionRemove(dmClientID, SessionID); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmSessionClose, Error, nil, 0); - end; -end; -{Begin !!.06} -{--------} -procedure TffServerCommandHandler.nmSessionCloseInactiveTables(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmSessionCloseInactiveTblReq(dmData)^ do begin - if FLogEnabled then - ichLogAll(['SessionCloseInactiveTables', - format(csClientID, [dmClientID]), - format(' Session %d', [SessionID])]); - - Error := FServerEngine.SessionCloseInactiveTables(dmClientID); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmSessionCloseInactTbl, Error, nil, 0); - end; -end; -{End !!.06} -{--------} -procedure TffServerCommandHandler.nmSessionGetCurrent(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmSessionGetCurrentRpy; -begin - with Msg do begin - - if FLogEnabled then - ichLogAll(['SessionGetCurrent', - format(csClientID, [dmClientID])]); - - Error := FServerEngine.SessionGetCurrent(dmClientID, Reply.SessionID); - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(' Session %d', [Reply.SessionID]); - ichLogFmt(csErr, [Error]); - end; - TffBaseTransport.Reply(ffnmSessionGetCurrent, Error, @Reply, sizeof(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmSessionSetCurrent(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmSessionSetCurrentReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['SessionSetCurrent', - format(csClientID, [dmClientID]), - format(' Session %d', [SessionID])]); - - Error := FServerEngine.SessionSetCurrent(dmClientID, SessionID); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmSessionSetCurrent, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmSessionSetTimeout(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmSessionSetTimeoutReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['SessionSetTimeout', - format(csClientID, [dmClientID]), - format(' Session %d', [SessionID]), - format(' Timeout %d', [Timeout])]); - - Error := FServerEngine.SessionSetTimeout(dmClientID, SessionID, Timeout); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmSessionSetTimeout, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmSetTableAutoIncValue(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmSetTableAutoIncValueReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['SetTableAutoIncValue', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(' Value %d', [AutoIncValue])]); - - Error := FServerEngine.TableSetAutoInc(CursorID, AutoIncValue); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmSetTableAutoIncValue, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmStartTransaction(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmStartTransactionReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['StartTransaction', - format(csClientID, [dmClientID]), - format(' DBase ID %d', [DatabaseID]), - format(' FailSafe %d', [byte(FailSafe)])]); - - Error := FServerEngine.TransactionStart(DatabaseID, - FailSafe); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmStartTransaction, Error, nil, 0); - end; -end; -{Begin !!.10} -{--------} -procedure TffServerCommandHandler.nmStartTransactionWith(var Msg : TffDataMessage); -var - Error : TffResult; - Inx, - CursorCount : Integer; - Reader : TReader; - Stream : TMemoryStream; - DbID : TffDatabaseID; - FailSafe : Boolean; - CursorIDList : TffPointerList; - CursorIDStr : string; -begin - with Msg do begin - CursorIDList := TffPointerList.Create; - try - Stream := TMemoryStream.Create; - try - Stream.Write(dmData^, dmDataLen); - Stream.Position := 0; - Reader := TReader.Create(Stream, 4096); - try - DbID := Reader.ReadInteger; - FailSafe := Reader.ReadBoolean; - CursorCount := Reader.ReadInteger; - for Inx := 1 to CursorCount do - CursorIDList.Append(Pointer(Reader.ReadInteger)); - finally - Reader.Free; - end; - finally - Stream.Free; - end; - - if FLogEnabled then begin - CursorIDStr := ''; - for Inx := 0 to Pred(CursorIDList.Count) do begin - if CursorIDStr <> '' then - CursorIDStr := CursorIDStr + ','; - CursorIDStr := CursorIDStr + IntToStr(Integer(CursorIDList[Inx])); - end; { for } - ichLogAll(['StartTransactionWith', - format(csClientID, [dmClientID]), - format(' DBase ID %d', [DbID]), - format(' FailSafe %d', [byte(FailSafe)]), - format(' CursorIDs %s', [CursorIDStr])]); - end; - - Error := FServerEngine.TransactionStartWith(DbID, - FailSafe, - CursorIDList); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmStartTransactionWith, Error, nil, 0); - finally - CursorIDList.Free; - end; - end; { with } -end; -{End !!.10} -{--------} -procedure TffServerCommandHandler.nmSQLAlloc(var Msg : TffDataMessage); -var - Error : TffResult; - Reply : TffnmSQLAllocRpy; -begin - with Msg, PffnmSQLAllocReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['SQLAlloc', - format(csClientID, [dmClientID]), - format(' DBaseID %d', [DatabaseID]), {!!.01} - format(' Timeout %d', [Timeout])]); {!!.01} - - Error := FServerEngine.SQLAlloc(dmClientID, DatabaseID, Timeout, - Reply.StmtID); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmSQLAlloc, Error, @Reply, SizeOf(Reply)); - end; -end; -{--------} -procedure TffServerCommandHandler.nmSQLExec(var Msg : TffDataMessage); -var - aBuffer : pointer; - Error: TffResult; - CursorID: TffCursorID; - Stream : TMemoryStream; - StreamSize : longInt; -begin - with Msg, PffnmSQLExecReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['SQLExec', - format(csClientID, [dmClientID]), - format(' StmtID %d', [StmtID]), - format(' OpenMode %d', [Ord(OpenMode)])]); - - Stream := TMemoryStream.Create; - try - Error := FServerEngine.SQLExec(StmtID, OpenMode, CursorID, Stream); -// if CursorID = 0 then {!!.01} -// TffBaseTransport.Reply(ffnmSQLExec, Error, nil, 0) {!!.01} -// else begin {!!.01} - StreamSize := Stream.Size; - FFGetMem(aBuffer, StreamSize); - Stream.Position := 0; - Stream.Read(aBuffer^, StreamSize); - TffBaseTransport.Reply(ffnmSQLExec, Error, aBuffer, StreamSize); - FFFreeMem(aBuffer, StreamSize); -// end; {!!.01} - finally - Stream.Free; - end; - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(csCursorID, [CursorID]); - ichLogFmt(csErr, [Error]); - end; - - end; -end; -{--------} -procedure TffServerCommandHandler.nmSQLExecDirect(var Msg : TffDataMessage); -var - aBuffer : pointer; - Error : TffResult; - QueryText : PChar; - CursorID : TffCursorID; - Stream : TMemoryStream; - StreamSize : longInt; -begin - with Msg, PffnmSQLExecDirectReq(dmData)^ do begin - QueryText := @Query; - - if FLogEnabled then - ichLogAll(['SQLExecDirect', - format(csClientID, [dmClientID]), - format(' DBase ID [%d]', [DatabaseID]), - format(' Query [%s]', [StrPas(QueryText)]), - format(' Timeout %d', [Timeout]), - format(' OpenMode [%d]', [Ord(OpenMode)])]); - - - Stream := TMemoryStream.Create; - try - Error := FServerEngine.SQLExecDirect(dmClientID, DatabaseID, QueryText, - Timeout, OpenMode, CursorID, Stream); - StreamSize := Stream.Size; - FFGetMem(aBuffer, StreamSize); - Stream.Position := 0; - Stream.Read(aBuffer^, StreamSize); - - if FLogEnabled then begin - if (Error = 0) then - ichLogFmt(csCursorID, [CursorID]); - ichLogFmt(csErr, [Error]); - end; - - TffBaseTransport.Reply(ffnmSQLExecDirect, Error, aBuffer, StreamSize); - FFFreeMem(aBuffer, StreamSize); - finally - Stream.Free; - end; - - end; -end; -{--------} -procedure TffServerCommandHandler.nmSQLFree(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmSQLFreeReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['SQLFree', - format(csClientID, [dmClientID]), - format(' StmtID %d', [StmtID])]); - - Error := FServerEngine.SQLFree(StmtID); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmSQLFree, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmSQLPrepare(var Msg : TffDataMessage); -var - aBuffer : pointer; - Error : TffResult; - Stream : TMemoryStream; - StreamSize : longInt; -begin - with Msg, PffnmSQLPrepareReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['SQLPrepare', - format(csClientID, [dmClientID]), - format(' StmtID %d', [StmtID]), - format(' Query [%s]', [StrPas(@Query)])]); - - Stream := TMemoryStream.Create; - try - Error := FServerEngine.SQLPrepare(StmtID, @Query, Stream); - - StreamSize := Stream.Size; - aBuffer := nil; - if StreamSize > 0 then begin - FFGetMem(aBuffer, StreamSize); - Stream.Position := 0; - Stream.Read(aBuffer^, StreamSize); - end; - - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmSQLPrepare, Error, aBuffer, StreamSize); - if assigned(aBuffer) then - FFFreeMem(aBuffer, StreamSize); - finally - Stream.Free; - end; - end; -end; -{--------} -procedure TffServerCommandHandler.nmSQLSetParams(var Msg : TffDataMessage); -{ Input stream is expected to be: - StmtID (longint) - NumParams (word) - ParamList (array of TffSqlParamInfo) - BufLen (longint; size of DataBuffer) - DataBuffer (data buffer) -} -var - aBuffer : pointer; - Error : TffResult; - OutStream : TMemoryStream; - OutStreamSize : longInt; - Stream : TMemoryStream; - StmtID : longint; - NumParams : Word; - ParamDescs : PffSqlParamInfoList; - DataBuffer : PffByteArray; - BufLen: LongInt; -begin - with Msg do begin - Stream := TMemoryStream.Create; -{Begin !!.03} - try - Stream.Write(dmData^, dmDataLen); - Stream.Position := 0; - Stream.Read(StmtID, SizeOf(StmtID)); - Stream.Read(NumParams, SizeOf(NumParams)); - ParamDescs := Pointer(LongInt(Stream.Memory) + Stream.Position); - Stream.Position := Stream.Position + NumParams * SizeOf(TffSqlParamInfo); - Stream.Read(BufLen, SizeOf(BufLen)); - DataBuffer := Pointer(LongInt(Stream.Memory) + Stream.Position); - - - if FLogEnabled then begin - ichLogAll(['SQLSetParams', - format(csClientID, [dmClientID]), - format(' StmtID %d', [StmtID]), - format(' NumParams %d', [NumParams])]); - ichLogBlock(' ParamDescs ', ParamDescs, NumParams * SizeOf(TffSqlParamInfo)); - ichLogBlock(' DataBuf ', DataBuffer, BufLen); - end; - - - OutStream := TMemoryStream.Create; - try - Error := FServerEngine.SQLSetParams(StmtID, NumParams, ParamDescs, - DataBuffer, BufLen, OutStream); - OutStreamSize := Stream.Size; - aBuffer := nil; - if OutStreamSize > 0 then begin - FFGetMem(aBuffer, OutStreamSize); - Stream.Position := 0; - Stream.Read(aBuffer^, OutStreamSize); - end; - - if FLogEnabled and(Error <> 0) then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmSQLSetParams, Error, aBuffer, OutStreamSize); - if assigned(aBuffer) then - FFFreeMem(aBuffer, OutStreamSize); - finally - OutStream.Free; - end; - finally - Stream.Free; - end; -{End !!.03} - end; -end; -{--------} -procedure TffServerCommandHandler.nmTruncateBLOB(var Msg : TffDataMessage); -var - Error : TffResult; -begin - with Msg, PffnmTruncateBLOBReq(dmData)^ do begin - - if FLogEnabled then - ichLogAll(['TruncateBLOB', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(csBlobNr, [BLOBNr.iLow, BLOBNr.iHigh]), - format(' BLOBLen %d', [BLOBLength])]); - - Error := FServerEngine.BLOBTruncate(CursorID, BLOBNr, BLOBLength); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmTruncateBLOB, Error, nil, 0); - end; -end; -{--------} -procedure TffServerCommandHandler.nmWriteBLOB( var Msg : TffDataMessage ); -var - Error : TffResult; -begin - with Msg, PffnmWriteBLOBReq( dmData )^ do begin - - if FLogEnabled then begin - ichLogAll(['WriteBLOB', - format(csClientID, [dmClientID]), - format(csCursorID, [CursorID]), - format(csBlobNr, [BLOBNr.iLow, BLOBNr.iHigh]), - format(' Offset %d', [Offset]), - format(' Len %d', [Len])]); - ichLogBlock(' BLOB', @BLOB, Len); - end; - - Error := FServerEngine.BLOBWrite( CursorID, BLOBNr, Offset, Len, BLOB ); - if FLogEnabled then - ichLogFmt(csErr, [Error]); - TffBaseTransport.Reply(ffnmWriteBLOB, Error, nil, 0); - end; -end; -{--------} -{Rewritten !!.11} -procedure TffServerCommandHandler.FFAddDependent(ADependent : TffComponent); -var - Method : PffInt64; - aTransport : TffBaseTransport; -begin - inherited; - if (ADependent is TffBaseTransport) then begin - aTransport := TffBaseTransport(ADependent); - if Assigned(aTransport.OnAddClient) then begin - FFGetMem(Method, SizeOf(TffInt64)); - Method^ := TffInt64(aTransport.OnAddClient); - schSavedAddClientEvents.BeginWrite; - try - schSavedAddClientEvents.Add(Longint(aTransport), Method); - finally - schSavedAddClientEvents.EndWrite; - end; - end; - aTransport.OnAddClient := schOnAddClient; - aTransport.OnRemoveClient := schOnRemoveClient; - end; { if } -end; -{Begin !!.05} -{--------} -procedure TffServerCommandHandler.schDisposeRecord(Sender : TffBaseHashTable; - aData : Pointer); -begin - FFFreeMem(aData, SizeOf(TffInt64)); -end; -{End !!.05} -{--------} -procedure TffServerCommandHandler.schOnAddClient - (Listener : TffBaseTransport; - const userID : TffName; - const timeout : longInt; - const clientVersion : longInt; - var passwordHash : TffWord32; - var aClientID : TffClientID; - var errorCode : TffResult; - var isSecure : boolean; - var aVersion : longInt); -var {!!.05} - Method : PffInt64; {!!.05} -begin - if FLogEnabled then - ichLogAll(['AddClientEvent', - format(' UserID [%s]', [UserID]), - format(' timeout [%d]', [Timeout]), - format(' clientVersion [%d]', [ClientVersion])]); - -{Begin !!.05} - { See if there is a saved event for the listener. } - schSavedAddClientEvents.BeginRead; {begin !!.05} - try - Method := schSavedAddClientEvents.Get(Longint(Listener)); - finally - schSavedAddClientEvents.EndRead; - end; {end !!.05} - if Method <> nil then begin - errorCode := DBIERR_NONE; - TffAddClientEvent(Method^) - (Listener, userID, timeout, clientVersion, - passwordHash, aClientID, errorCode, isSecure, - aVersion); - if errorCode <> DBIERR_NONE then - Exit; - end; -{End !!.05} - - aClientID := ffc_NoClientID; - isSecure := False; - - { Is the client a compatible version? - 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). - } - if ((ffVersionNumber div 100) < (clientVersion div 100)) or - ((ffVersionNumber div 10000) > (clientVersion div 10000)) then {!!.11} -// (clientversion < 21000) then {!!.10}{Deleted !!.11} - errorCode := DBIERR_SERVERVERSION - else - errorCode := FServerEngine.ClientAddEx(aClientID, UserID, {!!.11} - UserID, timeout, {!!.11} - clientVersion, {!!.11} - passwordHash); {!!.11} - if (errorCode = DBIERR_NONE) then - isSecure := TffServerEngine(FServerEngine).Configuration.GeneralInfo^.giIsSecure; - aVersion := FFVersionNumber; - - if FLogEnabled then begin - if (Error = 0) then - ichLogAll([' Successful', - format(csClientID,[aClientID]), - format(' IsSecure %d', [ord(isSecure)])]); - ichLogFmt(csErr, [Error]); - end; -end; -{--------} -procedure TffServerCommandHandler.schOnRemoveClient - (Listener : TffBaseTransport; - const aClientID : TffClientID; - var errorCode : TffResult); -begin - if FLogEnabled then - ichLogAll(['RemoveClientEvent', - format(csClientID, [aClientID])]); - - errorCode := FServerEngine.ClientRemove(aClientID); - if FLogEnabled then - ichLogFmt(csErr, [Error]); -end; -{--------} -procedure TffServerCommandHandler.scInitialize; -begin - { do nothing } -end; -{--------} -procedure TffServerCommandHandler.scPrepareForShutdown; -begin - { do nothing } -end; -{--------} -procedure TffServerCommandHandler.scShutdown; -begin - { do nothing } -end; -{--------} -procedure TffServerCommandHandler.scStartup; -begin - { do nothing } -end; - -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/ffsrcnst.rc b/components/flashfiler/sourcelaz/ffsrcnst.rc deleted file mode 100644 index e5a6cc8f2..000000000 --- a/components/flashfiler/sourcelaz/ffsrcnst.rc +++ /dev/null @@ -1,31 +0,0 @@ -/********************************************************* - * FlashFiler: Server 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_SERVER_STRINGS RCDATA FFSRCNST.SRM - diff --git a/components/flashfiler/sourcelaz/ffsrcnst.res b/components/flashfiler/sourcelaz/ffsrcnst.res deleted file mode 100644 index a40510c9d..000000000 Binary files a/components/flashfiler/sourcelaz/ffsrcnst.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffsrcnst.srm b/components/flashfiler/sourcelaz/ffsrcnst.srm deleted file mode 100644 index 095462ab2..000000000 Binary files a/components/flashfiler/sourcelaz/ffsrcnst.srm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffsrcnst.str b/components/flashfiler/sourcelaz/ffsrcnst.str deleted file mode 100644 index 36166641d..000000000 --- a/components/flashfiler/sourcelaz/ffsrcnst.str +++ /dev/null @@ -1,129 +0,0 @@ -;********************************************************* -;* FlashFiler: Server 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" - -fferrBadStruct, "INTERNAL: TbtdFileInfo record contains invalid data" -fferrOpenFailed, "INTERNAL: File could not be opened [%s, error %d, %s]" -fferrOpenNoMem, "INTERNAL: Out of memory when opening a file" -fferrCloseFailed, "INTERNAL: File could not be closed [%s, error %d, %s]" -fferrReadFailed, "INTERNAL: Error when reading from file [%s, error %d, %s]" -fferrReadExact, "INTERNAL: Could not read exact number of bytes from file [%s, %d bytes]" -fferrWriteFailed, "INTERNAL: Error when writing to file [%s, error %d, %s]" -fferrWriteExact, "INTERNAL: Could not write exact number of bytes to file [%s, %d bytes]" -fferrSeekFailed, "INTERNAL: Error when seeking to position in file [%s, offset %d:%d, error %d, %s]" -fferrFlushFailed, "INTERNAL: Error when flushing file [%s, error %d, %s]" -fferrSetEOFFailed, "INTERNAL: Error when setting end-of-file [%s, error %d, %s]" - -fferrNotAnFFFile, "[%s] is not a FlashFiler formatted file, or its file header is corrupt" -fferrBadBlockNr, "Block number is either < 0, or >= number of blocks in file [%s, block %d]" -fferrEncrypted, "[%s] is an encrypted FlashFiler file and the Server cannot read it (it is not secure)" - -fferrRecDeleted, "Record has been deleted, cannot read/delete/update it [%s, ref %d]" -fferrBadRefNr, "Number is not a valid FlashFiler record reference number [%s, ref %d]" -fferrBadDataBlock, "Block just read from file is not a valid data block [%s, block %d]" - -fferrBlobDeleted, "BLOB has been deleted, cannot read/delete it [%s, (%d, %d)]" -fferrBadBlobNr, "Number is not a valid FlashFiler BLOB number [%s, (%d, %d)]" -fferrBadBlobBlock, "Block just read from file is not a valid BLOB data block [%s, %d]" -fferrBadBlobSeg, "Internal link to BLOB segment has been corrupted [%s, (%d, %d)]%s" -fferrLenMismatch, "Truncate length is greater than length of BLOB [%s, (%d, %d), offset %d, length %d]" -fferrOfsNotInBlob, "Offset value is greater than the length of the BLOB [%s, (%d, %d), offset %d, length %d]" -fferrFileBlobWrite, "Cannot write to a file BLOB [%s, (%d, %d)]" - -fferrBadStreamBlock, "Block just read from file is not a valid stream block [%s, block %d]" -fferrBadStreamOrigin, "An invalid stream origin has been specified" -fferrStreamSeekError, "Stream could not seek requested position" - -fferrBadInxBlock, "Block just read from file is not a valid index block [%s, block %d]" -fferrBadIndex, "Index number passed to routine is out of range [%d]" -fferrMaxIndexes, "The maximum number of indexes have already been added [%s]" -fferrBadMergeCall, "INTERNAL: MergeChildren called with pages not half-filled, suspect corruption [%s, left %d, right %d]" -fferrKeyNotFound, "Key was not found in index when attempting to delete it" -fferrKeyPresent, "Key was found in index when attempting to add it" -fferrNoKeys, "There are no keys in the index, cannot calculate an approximate position/key" -fferrNoSeqAccess, "Cannot create sequential cursor (index 0) as the group has no sequential access path" -fferrBadApproxPos, "The approximate position must be between 0 and 100 [%s, index %d, pos %d]" - -fferrBadServerName, "The server name is invalid: can only have a-z, A-Z, 0-9 characters" -fferrFFV1File, "File %s (signature %d) could not be opened because it is a FlashFiler 1.0 file." - -fferrUnknownClient, "The client ID passed to the server is unknown" -fferrUnknownSession, "Either the client ID is unknown or the session does not exist for the given client" -fferrUnknownAlias, "The Alias name has not been defined: it cannot be found" -fferrUnknownPath, "Path [%s] does not exist" -fferrUnknownDB, "The database ID does not exist" -fferrUnknownTable, "Table %s does not exist within database %s" -fferrUnknownIndex, "The index for table %s could not be identified from the given index name (%s) or index number %d" -fferrUnknownCursor, "The passed cursor ID does not exist" -fferrUnknownTrans, "Transaction ID %d is unknown" -fferrUnknownMsg, "Message %d is not recognized by this server" - -fferrDBExclusive, "The database is already open: either already in exclusive mode or it is now opened in exclusive mode" -fferrDBReadOnly, "The table cannot be opened in read/write mode because the database has been opened in readonly mode" -fferrTableExclusive, "The table is already open in a non-shared (exclusive) mode, it cannot be opened by any other session" -fferrCursorReadOnly, "Cannot delete or modify current record or insert new record because the cursor (table %s) was opened in read-only mode" -fferrWriteLocked, "The table has been write-locked by another workstation, no other read-locks or write-locks allowed" -fferrReadLocked, "The table has been read-locked by another workstation, no write-lock allowed" -fferrCannotUnlock, "The lock could not be removed: it does not exist" -fferrTableLocked, "The table is locked preventing the update operation" -fferrRecLocked, "Record is locked by another user" -fferrNoCurrentRec, "The cursor has no current record (either it's positioned on BOF, EOF or on a crack)" -fferrDynamicLink, "The server could not find a DLL, or a routine within a DLL [Index(%s/%s:%d) DLL(%s) Routines(%s, %s)]" -fferrResolveTableLinks, "A table needed some user defined routines but they were not found in the server configuration" -fferrTableMismatch, "SetToCursor failed because the given cursor was not for the same table" -fferrNoNextRecord, "There is no next record in this index; the cursor is positioned at EOF" -fferrNoPriorRecord, "There is no prior record in this index; the cursor is positioned at BOF" -fferrTableExists, "Table %s already exists" -fferrDBInTrans, "Database [%s] is already in a transaction" -fferrAliasExists, "Alias [%s] already exists" -fferrCannotCompare, "Cannot compare BLOB fields in a table" -fferrBadFieldXform, "Cannot copy field [%s to %s], incompatible field types" -fferrNoTransaction, "No transaction has been started for the database, hence no updates can take place" -fferrBadBookmark, "The bookmark is corrupt or was not created for the current index" -fferrTransactionFailed, "A transaction failed during commit, probably due to running out of disk space, or other disk problem" -fferrDiskFull, "The disk is out of free space" -fferrTableFull, "This table has grown to its maximum size: pack the table or remove unneeded data" -fferrInvalidSqlStmtHandle, "Invalid statement handle" -fferrBLOBTooBig, "BLOB size exceeds maximum size. [size: %d]" -fferrDeadlock, "A lock request (type %s, %s) resulted in a deadlock. Transaction %d was chosen as the victim." -fferrLockTimeout, "A lock request (type %s, %s, file %s) timed out." -fferrLockRejected, "A lock request (type %s, %s, file %s) was rejected." -fferrTableLockTimeout, "A lock request (type %s, %s) timed out." -fferrGeneralTimeout, "The operation could not be completed within the allotted time." -fferrNoSQLEngine, "Server engine [%s] is not attached to a SQL engine." -fferrIndexNotSupported, "Indexes are not supported by this table [table %s, class %s]." -fferrInvalidTableName, "'%s' is not a valid table name, most likely because it contains a file extension. Be sure to omit the file extension." -fferrRangeNotSupported, "Ranges are not supported by this table [table %s, class %s]." -fferrTableOpen, "Table %s is already open." -fferrSameTable, "The cursors may not reference the same table for this operation." -fferrSortFail, "Sort failure in method %s" -fferrBadDistinctField, "BLOB or ByteArray fields not allowed with DISTINCT key word: %s." -fferrTableVersion, "Cannot open table %s. It was created with version %5.4f of FlashFiler, which is newer than this server's version (%5.4f)." - diff --git a/components/flashfiler/sourcelaz/ffsrcur.pas b/components/flashfiler/sourcelaz/ffsrcur.pas deleted file mode 100644 index e1f44b877..000000000 --- a/components/flashfiler/sourcelaz/ffsrcur.pas +++ /dev/null @@ -1,1068 +0,0 @@ -{*********************************************************} -{* FlashFiler: Server cursor 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 ffsrcur; - -interface - -uses - ffllbase, - fflldict, - fflltemp, - ffsrbase, - ffsrbde, - ffsreng, - ffsrfltr, - ffsrfold, - ffsrlock, - fftbdict, - fftbindx; - -type - - { This class manages a set of data stored in a logical table. It is very - similar to TffSrTable. However, the data is not indexed. - To create a new simple table, you must do the following: - - 1. Call TffSrSimpleTable.Create. - 2. Have the table build its files by calling its BuildFiles method. - 3. Have the table open its fils by calling its OpenFiles method. } - TffSrSimpleTable = class(TffSrBaseTable) - public - procedure AddIndex(const aIndexDesc : TffIndexDescriptor; - aTI : PffTransInfo); override; - procedure BuildFiles(aTI : PffTransInfo; - aForServer : boolean; - aDictionary : TffDataDictionary; - aAttribs : TffFileAttributes; - aStore : TffBaseTempStorage); override; - function BuildKeyForRecord(aIndexID : integer; - aData : PffByteArray; - aKey : PffByteArray; - aFieldCount : integer; - aPartialLen : integer) : TffResult; override; - function CompareKeysForCursor(var aKID : TffKeyIndexData; - aKey1 : PffByteArray; - aKey2 : PffByteArray) : integer; override; - function DeleteRecord(aTI : PffTransInfo; - const aCursorID : TffCursorID; - const aRefNr : TffInt64; - const aLockObtained : Boolean; - var aBTreeChanged : Boolean) {!!.05} - : TffResult; override; - procedure DropIndex(aTI : PffTransInfo; aIndexID : Longint); override; - function FindKey(var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aAction : TffSearchKeyAction) : boolean; override; - function GetNextKey(var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath) : TffResult; override; - function GetNextRecord(aTI : PffTransInfo; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.10} - var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aData : PffByteArray; - const aLockType : TffSrLockType) : TffResult; override; {!!.10} - function GetPriorRecord(aTI : PffTransInfo; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.10} - var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aData : PffByteArray; - const aLockType : TffSrLockType) : TffResult; override; {!!.10} - function InsertRecord(aTI : PffTransInfo; - aCursorID : TffCursorID; - aData : PffByteArray; - aLockType : TffSrLockType; - var aNewRefNr : TffInt64) : TffResult; override; - function InsertRecordNoDefault(aTI : PffTransInfo; {!!.10} - aCursorID : TffCursorID; - aData : PffByteArray; - aLockType : TffSrLockType; - var aNewRefNr : TffInt64) : TffResult; override; - procedure MakeKIDForCursor(aIndexID : integer; var aKID : TffKeyIndexData); override; - procedure OpenFiles(aTI : PffTransInfo; aForServer : boolean; - aAttribs : TffFileAttributes); override; - function PutRecord(aTI : PffTransInfo; - aCursorID : TffCursorID; - aRefNr : TffInt64; - aData : PffByteArray; - aRelLock : boolean; {!!.05} - var aKeyChanged : Boolean) : TffResult; override; {!!.05} - - end; - - { Use this cursor class to manage sets of data that do not require indices. } - TffSrSimpleCursor = class(TffSrBaseCursor) - protected - procedure bcTableOpenPreconditions(aTable : TffSrBaseTable; - const aIndexName : string; - var aIndexID : Longint; - const aOpenMode : TffOpenMode); override; - { Used by Create method to verify a thread may open a table. } - - public - constructor Create(anEngine : TffServerEngine; - aDatabase : TffSrDatabase; - const aTimeout : Longint); override; - - destructor Destroy; override; - function AddIndexToTable(const aIndexDesc : TffIndexDescriptor) : TffResult; override; - function CheckBookmark(aBookmark : PffByteArray) : TffResult; override; - procedure ClearIndex; override; - function CloneCursor(aOpenMode : TffOpenMode) : TffSrBaseCursor; override; - function CompareBookmarks(aBookmark1, aBookmark2 : PffByteArray; - var CmpResult : Longint) : TffResult; override; - function DropIndexFromTable(const aIndexName : TffDictItemName; - aIndexID : Longint) : TffResult; override; - function ExtractKey(aData : PffByteArray; aKey : PffByteArray) : TffResult; override; - function GetBookmark(aBookmark : PffByteArray) : TffResult; override; - function GetBookmarkSize : integer; override; - function GetNextRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; override; - function GetPriorRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; override; - function GetRecordCount(var aRecCount : Longint) : TffResult; override; - function GetRecordForKey(aDirectKey : boolean; - aFieldCount : integer; - aPartialLen : integer; - aKeyData : PffByteArray; - aData : PffByteArray; - aFirstCall : Boolean) : TffResult; override; - function InsertRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; override; - function InsertRecordNoDefault(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; override;{!!.10} - function IsInRange(aKey : PffByteArray) : integer; override; - function ModifyRecord(aData : PffByteArray; aRelLock : boolean) : TffResult; override; - procedure Open(const aTableName : TffTableName; - const aIndexName : TffName; - const aIndexID : Longint; - const aOpenMode : TffOpenMode; - aShareMode : TffShareMode; - aForServer : boolean; - const aExclContLock : Boolean; {!!.10} - aAttribs : TffFileAttributes); override; - procedure ResetRange; override; - function SetRange(aDirectKey : boolean; - aFieldCount1 : integer; - aPartialLen1 : integer; - aKeyData1 : PffByteArray; - aKeyIncl1 : boolean; - aFieldCount2 : integer; - aPartialLen2 : integer; - aKeyData2 : PffByteArray; - aKeyIncl2 : boolean) : TffResult; override; - procedure SetToBegin; override; - function SetToBookmark(aBookmark : PffByteArray) : TffResult; override; - function SetToCursor(aCursor : TffSrBaseCursor) : TffResult; override; - procedure SetToEnd; override; - function SetToKey(aSearchAction : TffSearchKeyAction; - aDirectKey : boolean; - aFieldCount : integer; - aPartialLen : integer; - aKeyData : PffByteArray) : TffResult; override; - function SwitchToIndex(aIndexID : integer; - aPosnOnRec : boolean) : TffResult; override; - end; - - { Use this class to create a cursor representing a query's result set. - Do not directly create TffSrSimpleCursor. } - TffSrSQLResultSet = class(TffSrSimpleCursor); - -implementation - -uses - ffconst, - ffhash, - fflleng, - ffllexcp, - fftbbase, - fftbBLOB, {!!.11} - fftbdata; - -{===TffSrSQLTable====================================================} -procedure TffSrSimpleTable.AddIndex(const aIndexDesc : TffIndexDescriptor; - aTI : PffTransInfo); -begin - FFRaiseException(EffException, ffStrResServer, fferrIndexNotSupported, - [btBaseName^, Self.ClassName]); -end; -{--------} -procedure TffSrSimpleTable.BuildFiles(aTI : PffTransInfo; - aForServer : boolean; - aDictionary : TffDataDictionary; - aAttribs : TffFileAttributes; - aStore : TffBaseTempStorage); -var - FileInx : integer; - DataFile : PffFileInfo; - FileCnt : integer; {dup for speed} -begin - { Create the data file. } - btFiles.Count := 1; - btFiles[0] := FFAllocFileInfo(FFMakeFullFileName(Folder.Path, BaseName), - ffc_ExtForData, btBufMgr); - - { Validate the dictionary. } - aDictionary.CheckValid; - - { Assimilate the dictionary. } - btDictionary.ForceOffReadOnly; - btDictionary.Assign(aDictionary); - btDictionary.BindIndexHelpers; - - with PffFileInfo(btFiles[0])^ do begin - fiAttributes := aAttribs; - fiForServer := aForServer; - fiEncrypted := btEngine.Configuration.GeneralInfo^.giAllowEncrypt and - aDictionary.IsEncrypted; - fiRecLenPlusTrailer := btDictionary.RecordLength + SizeOf(Byte); - fiRecordLength := btDictionary.RecordLength; - fiTempStore := aStore; - end; - - { Get the file count for this table (for speed reasons, etc). } - FileCnt := Dictionary.FileCount; - FileCount := FileCnt; - - { Get the data file for speed reasons. } - DataFile := Files[0]; - - { Scan through the secondary files. This table supports separate BLOB - files but not separate index files. } - for FileInx := 0 to pred(FileCnt) do begin - if Dictionary.FileType[FileInx] = ftIndexFile then - FFRaiseException(EffException, ffStrResServer, fferrIndexNotSupported, - [btBaseName^, Self.ClassName]); - btCreateFile(FileInx, aTI, btDictionary.FileExt[FileInx], aForServer, - aAttribs, aStore); - end; - - { Write the dictionary to the data file. } - Dictionary.WriteToFile(DataFile, aTI); -{Begin !!.11} - Files[Dictionary.BLOBFileNumber].fiBLOBrscMgr := - TffBaseBLOBResourceMgr.GetMgr(Files[Dictionary.BLOBFileNumber]); - btBLOBEngine := TffBaseBLOBEngine.GetEngine(Files[Dictionary.BLOBFileNumber]); -{End !!.11} - Files[Dictionary.BLOBFileNumber].fiMaxSegSize := - FFCalcMaxBLOBSegSize(Files[Dictionary.BLOBFileNumber]); - -end; -{--------} -function TffSrSimpleTable.BuildKeyForRecord(aIndexID : integer; - aData : PffByteArray; - aKey : PffByteArray; - aFieldCount : integer; - aPartialLen : integer) : TffResult; -begin - Result := DBIERR_INVALIDINDEXCREATE; -end; -{--------} -function TffSrSimpleTable.CompareKeysForCursor(var aKID : TffKeyIndexData; - aKey1 : PffByteArray; - aKey2 : PffByteArray) : integer; -begin - Result := DBIERR_INVALIDINDEXCREATE; -end; -{--------} -function TffSrSimpleTable.DeleteRecord(aTI : PffTransInfo; - const aCursorID : TffCursorID; - const aRefNr : TffInt64; - const aLockObtained : Boolean; - var aBTreeChanged : Boolean) {!!.05} - : TffResult; -var - OldData : PffByteArray; - RecLen : integer; -begin - RecLen := btDictionary.RecordLength; - FFGetMem(OldData, RecLen); - Result := DBIERR_NONE; - - { If we have yet to lock the record then do so. } - if (not aLockObtained) then - FFAcqRecordLock(Files[0], aTI, aRefNr, ffsltExclusive, {!!.10} - aTI^.tirTrans.DatabaseID, {!!.10} - aCursorID, false); {!!.02}{!!.10} - { Note: We leave all such locks active until the transaction is committed. } - - try - FFTblReadRecord(Files[0], aTI, aRefNr, OldData); - btDeleteBLOBsForRecord(aTI, OldData); - FFTblDeleteRecord(Files[0], aTI, aRefNr); - finally - btInformCursors(aCursorID, roDelete, aRefNr, 0); - FFFreeMem(OldData, RecLen); - end;{try..finally} -end; -{--------} -procedure TffSrSimpleTable.DropIndex(aTI : PffTransInfo; - aIndexID : Longint); -begin - FFRaiseException(EffException, ffStrResServer, fferrIndexNotSupported, - [btBaseName^, Self.ClassName]); -end; -{--------} -function TffSrSimpleTable.FindKey(var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aAction : TffSearchKeyAction) : boolean; -begin - ffInitI64(aRefNr); - Result := False; -end; -{--------} -function TffSrSimpleTable.GetNextKey(var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath) : TffResult; -begin - Result := DBIERR_INVALIDINDEXCREATE; -end; -{--------} -function TffSrSimpleTable.GetNextRecord(aTI : PffTransInfo; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.10} - var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aData : PffByteArray; - const aLockType : TffSrLockType) : TffResult; -begin - Result := DBIERR_NONE; - GetNextRecordSeq(aTI, aRefNr, aData); -end; -{--------} -function TffSrSimpleTable.GetPriorRecord(aTI : PffTransInfo; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.10} - var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aData : PffByteArray; - const aLockType : TffSrLockType) : TffResult; {!!.10} -begin - Result := DBIERR_NONE; - GetPrevRecordSeq(aTI, aRefNr, aData); -end; -{--------} -function TffSrSimpleTable.InsertRecord(aTI : PffTransInfo; - aCursorID : TffCursorID; - aData : PffByteArray; - aLockType : TffSrLockType; - var aNewRefNr : TffInt64) : TffResult; -var - RefNr : TffInt64; -begin - RefNr.iLow := 0; - RefNr.iHigh := 0; - Result := DBIERR_NONE; - if not Dictionary.CheckRequiredRecordFields(aData) then - Result := DBIERR_REQDERR - else begin - {we need to add the default field values} - if Dictionary.DefaultFieldCount > 0 then - Dictionary.SetDefaultFieldValues(aData); - - { Updating the autoinc value obtains an exclusive lock on block 0 which - prevents other cursors from inserting the same or additional records - until we are done. } - btUpdateAutoInc(aTI, aData); - FFTblAddRecord(Files[0], aTI, RefNr, aData); - aNewRefNr := RefNr; - FFAcqRecordLock(Files[0], aTI, aNewRefNr, aLockType, {!!.10} - aTI^.tirTrans.DatabaseID, {!!.10} - aCursorID, false); {!!.02}{!!.10} - end; -end; -{--------} -function TffSrSimpleTable.InsertRecordNoDefault(aTI : PffTransInfo;{!!.10} - aCursorID : TffCursorID; - aData : PffByteArray; - aLockType : TffSrLockType; - var aNewRefNr : TffInt64) : TffResult; -var - RefNr : TffInt64; -begin - RefNr.iLow := 0; - RefNr.iHigh := 0; - Result := DBIERR_NONE; - if not Dictionary.CheckRequiredRecordFields(aData) then - Result := DBIERR_REQDERR - else begin - { Updating the autoinc value obtains an exclusive lock on block 0 which - prevents other cursors from inserting the same or additional records - until we are done. } - btUpdateAutoInc(aTI, aData); - FFTblAddRecord(Files[0], aTI, RefNr, aData); - aNewRefNr := RefNr; - FFAcqRecordLock(Files[0], aTI, aNewRefNr, aLockType, {!!.10} - aTI^.tirTrans.DatabaseID, {!!.10} - aCursorID, false); {!!.02}{!!.10} - end; -end; -{--------} -procedure TffSrSimpleTable.MakeKIDForCursor(aIndexID : integer; var aKID : TffKeyIndexData); -begin - FFRaiseException(EffException, ffStrResServer, fferrIndexNotSupported, - [btBaseName^, Self.ClassName]); -end; -{--------} -procedure TffSrSimpleTable.OpenFiles(aTI : PffTransInfo; aForServer : boolean; - aAttribs : TffFileAttributes); -var - FileInx : integer; -begin - { Are any of the files marked as index files? If so then raise an exception - because this class does not support indexes. Assume that file 0 is the - data file. } - for FileInx := 1 to pred(Dictionary.FileCount) do - if Dictionary.FileType[FileInx] = ftIndexFile then - FFRaiseException(EffException, ffStrResServer, fferrIndexNotSupported, - [btBaseName^, Self.ClassName]); - - { If we've made it this far then open the files. } - inherited OpenFiles(aTI, aForServer, aAttribs); -end; -{--------} -function TffSrSimpleTable.PutRecord(aTI : PffTransInfo; - aCursorID : TffCursorID; - aRefNr : TffInt64; - aData : PffByteArray; - aRelLock : boolean; {!!.05} - var aKeyChanged : Boolean) : TffResult; {!!.05} -var - RecLen : integer; - OldData: PffByteArray; -begin - - { Assumption: By the time we have reached this point, the transaction has - acquired a content lock on the table and we are the only ones who are - going to be modifying the record. } - - aKeyChanged := False; {!!.05} - RecLen := 0; - if not Dictionary.CheckRequiredRecordFields(aData) then begin - Result := DBIERR_REQDERR; - Exit; - end; - - Result := DBIERR_NONE; - try - try - RecLen := Dictionary.RecordLength; - FFGetMem(OldData, RecLen); - - FFTblReadRecord(Files[0], aTI, aRefNr, OldData); - - { Acquire an exclusive lock. } - FFAcqRecordLock(Files[0], aTI, aRefNr, ffsltExclusive, {!!.10} - aTI^.tirTrans.DatabaseID, {!!.10} - aCursorID, false); {!!.02}{!!.10} - - FFTblUpdateRecord(Files[0], aTI, aRefNr, aData); - except - FFRelRecordLock(Files[0], aTI, aRefNr, aTI^.tirTrans.DatabaseID, {!!.10} - aCursorID); {!!.10} - end; - finally - FFFreeMem(OldData, RecLen); - end;{try..finally} -end; -{====================================================================} - -{===TffSrSimpleCursor================================================} -constructor TffSrSimpleCursor.Create(anEngine : TffServerEngine; - aDatabase : TffSrDatabase; - const aTimeout : Longint); -begin - bcTableClass := TffSrSimpleTable; - inherited Create(anEngine, aDatabase, aTimeout); -end; -{--------} -destructor TffSrSimpleCursor.Destroy; -begin - { Free the table locks held by the cursor. } - if Assigned(bcTable) then - bcTable.RelLock(CursorID, True); - - inherited Destroy; -end; -{--------} -function TffSrSimpleCursor.AddIndexToTable(const aIndexDesc : TffIndexDescriptor) : TffResult; -begin - Result := DBIERR_INVALIDINDEXCREATE; - FFRaiseException(EffException, ffStrResServer, fferrIndexNotSupported, - [bcTable.BaseName, Self.ClassName]); -end; -{--------} -procedure TffSrSimpleCursor.bcTableOpenPreconditions(aTable : TffSrBaseTable; - const aIndexName : string; - var aIndexID : Longint; - const aOpenMode : TffOpenMode); -begin - { Ignore the index information. } - - { If the table's data file is open in read-only mode it means the - physical file is read-only: hence this call's openmode must be - read-only as well. } - if (aTable.Files[0]^.fiOpenMode = omReadOnly) and - (aOpenMode <> omReadOnly) then - FFRaiseException(EffException, ffStrResServer, fferrCursorReadOnly, - [aTable.BaseName]); -end; -{--------} -function TffSrSimpleCursor.CheckBookmark(aBookmark : PffByteArray) : TffResult; -var - CheckHash : Longint; -begin - Result := DBIERR_INVALIDBOOKMARK; - if (aBookmark = nil) then - Exit; - with PffSrBookmark(aBookmark)^ do begin - CheckHash := FFCalcElfHash(sbIndexID, - ffcl_FixedBookmarkSize - SizeOf(sbHash)); - if (sbHash <> CheckHash) then - Exit; - end; - Result := DBIERR_NONE; -end; -{--------} -procedure TffSrSimpleCursor.ClearIndex; -begin - FFRaiseException(EffException, ffStrResServer, fferrIndexNotSupported, - [bcTable.BaseName, Self.ClassName]); -end; -{--------} -function TffSrSimpleCursor.CloneCursor(aOpenMode : TffOpenMode) : TffSrBaseCursor; -begin - {NOTE: we are not checking rights for this action because the client - had the rights to open the cursor} - - { Resolve the open mode. } - if (bcOpenMode = omReadOnly) then - aOpenMode := omReadOnly; - - AcqContentLock(ffclmRead); - try - { Create the cursor. } - Result := TffSrSimpleCursor.Create(bcEngine, bcDatabase, soTimeout); - Result.Open(bcTable.BaseName, '', bcIndexID, aOpenMode, smShared, - bcTable.IsServerTable, False, bcTable.Files[0]^.fiAttributes); - - { Set up all of the misc fields. } - Result.CursorInfo := bcInfo; - if Assigned(bcFilter) then - Result.SetFilter(bcFilter.Expression,bcFilter.Timeout); - finally - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrSimpleCursor.CompareBookmarks(aBookmark1, aBookmark2 : PffByteArray; - var CmpResult : Longint) : TffResult; -var - BM1 : PffSrBookmark absolute aBookmark1; - BM2 : PffSrBookmark absolute aBookmark2; -begin - Result := CheckBookmark(aBookmark1); - if (Result = DBIERR_NONE) then - Result := CheckBookmark(aBookmark2); - if (Result <> DBIERR_NONE) then - Exit; - case BM1^.sbPos of - cpUnknown : CmpResult := -1; - cpBOF : if (BM2^.sbPos = cpBOF) then - CmpResult := 0 - else - CmpResult := -1; - cpEOF : if (BM2^.sbPos = cpEOF) then - CmpResult := 0 - else - CmpResult := 1; - else - { Bookmark 1 is on a crack or on a record. } - case BM2^.sbPos of - cpUnknown : CmpResult := 1; - cpBOF : CmpResult := 1; - cpEOF : CmpResult := -1; - else - { Bookmark 2 is also on a crack or on a record. Check the reference - numbers.} - CmpResult := ffCmpI64(BM1^.sbRefNr, BM2^.sbRefNr); - end; {case} - end; {case} -end; -{--------} -function TffSrSimpleCursor.DropIndexFromTable(const aIndexName : TffDictItemName; - aIndexID : Longint) : TffResult; -begin - Result := DBIERR_INVALIDINDEXCREATE; - FFRaiseException(EffException, ffStrResServer, fferrIndexNotSupported, - [bcTable.BaseName, Self.ClassName]); -end; -{--------} -function TffSrSimpleCursor.ExtractKey(aData : PffByteArray; aKey : PffByteArray) : TffResult; -begin - Result := DBIERR_INVALIDINDEXCREATE; - FFRaiseException(EffException, ffStrResServer, fferrIndexNotSupported, - [bcTable.BaseName, Self.ClassName]); -end; -{--------} -function TffSrSimpleCursor.GetBookmark(aBookmark : PffByteArray) : TffResult; -begin - Result := DBIERR_NONE; - AcqContentLock(ffclmRead); - try - FillChar(PffSrBookmark(aBookmark)^, ffcl_FixedBookmarkSize, 0); - with PffSrBookmark(aBookmark)^ do begin - sbRefNr := bcInfo.RefNr; - sbPos := bcInfo.Pos; - sbKeyValid := bcInfo.KeyValid; - sbHash := FFCalcElfHash(sbIndexID, ffcl_FixedBookmarkSize - sizeof(sbHash)); - end; - finally - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrSimpleCursor.GetBookmarkSize : integer; -begin - Result := ffcl_FixedBookmarkSize; -end; -{--------} -function TffSrSimpleCursor.GetNextRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; -begin - - { If we are at EOF, then obviously there's no next record. } - if (bcInfo.pos = cpEOF) then begin - Result := DBIERR_EOF; - Exit; - end; - - AcqContentLock(ffclmRead); - try - - { Make sure that we have somewhere to read the record into. } - if (aData = nil) then - aData := bcRecordData; - - if Assigned(bcFilter) then - bcFilter.BeginTimeout; - - Result := DBIERR_NONE; - repeat - bcTable.GetNextRecordSeq(bcDatabase.TransactionInfo, bcInfo.RefNr, aData); - - if ffI64IsZero(bcInfo.RefNr) then begin - Result := DBIERR_EOF; - SetToEnd; - Exit; - end; - - { In theory we're on a record. } - bcInfo.Deleted := false; - bcInfo.KeyValid := true; - bcInfo.Pos := cpOnRecord; - until (Result <> DBIERR_NONE) or not Assigned(bcFilter) or - bcFilter.MatchesRecord(aData) or bcFilter.CheckTimeout(Result); - - { Place the lock if needed... record will not be read again. } - if (Result = DBIERR_NONE) and (aLockType <> ffsltNone) then - Result := Table.GetRecord(bcDatabase.TransactionInfo, - bcDatabase.DatabaseID, CursorID, {!!.10} - bcInfo.RefNr, nil, aLockType, false, false); {!!.02} - finally - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrSimpleCursor.GetPriorRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; -begin - - { If we are at BOF, then obviously there's no prior record. } - if (bcInfo.pos = cpBOF) then begin - Result := DBIERR_BOF; - Exit; - end; - - AcqContentLock(ffclmRead); - try - - { Make sure that we have somewhere to read the record into. } - if (aData = nil) then - aData := bcRecordData; - - { Get the previous record. } - if Assigned(bcFilter) then - bcFilter.BeginTimeout; - - Result := DBIERR_NONE; - repeat - bcTable.GetPrevRecordSeq(bcDatabase.TransactionInfo, bcInfo.RefNr, - aData); - if FFI64IsZero(bcInfo.RefNr) then begin - Result := DBIERR_BOF; - SetToBegin; - Exit; - end; - - { In theory we're on a record. } - bcInfo.Deleted := false; - bcInfo.KeyValid := true; - bcInfo.Pos := cpOnRecord; - - until (Result <> DBIERR_NONE) or not Assigned(bcFilter) or - bcFilter.MatchesRecord(aData) or bcFilter.CheckTimeout(Result); - - { Place the lock if needed... record will not be read again. } - if (Result = DBIERR_NONE) and (aLockType <> ffsltNone) then - Result := bcTable.GetRecord(bcDatabase.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, {!!.10} - bcInfo.refNr, nil, aLockType, false, false); {!!.02} - finally - RelContentLock(ffclmRead); - end; - -end; -{--------} -function TffSrSimpleCursor.GetRecordCount(var aRecCount : Longint) : TffResult; -var - aData : PffByteArray; - Info : TffRecordInfo; -begin - Result := DBIERR_NONE; - AcqContentLock(ffclmRead); - try - { Is a filter active? } - if Assigned(bcFilter) then begin - { Yes. Set count to zero. We are going to scan through the records. } - aRecCount := 0; - { Save the current position. } - bcSaveCurInfo; - FFGetZeroMem(aData, bcRecordLen); - try - {BOF} - SetToBegin; - - { While not EOF or other error do. } - while (Result = DBIERR_NONE) do begin - Result := GetNextRecord(aData, ffsltNone); - if (Result = DBIERR_NONE) then - inc(aRecCount); - end; - Result := DBIERR_NONE; - finally - FFFreeMem(aData, bcRecordLen); - { Reset current position. } - bcRestoreCurInfo; - end; - end - else begin - FFTblGetRecordInfo(bcTable.Files[0], bcDatabase.TransactionInfo, Info); - aRecCount := Info.riRecCount; - end; - finally - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrSimpleCursor.GetRecordForKey(aDirectKey : boolean; - aFieldCount : integer; - aPartialLen : integer; - aKeyData : PffByteArray; - aData : PffByteArray; - aFirstCall : Boolean) : TffResult; -begin - Result := DBIERR_INVALIDINDEXCREATE; - FFRaiseException(EffException, ffStrResServer, fferrIndexNotSupported, - [bcTable.BaseName, Self.ClassName]); -end; -{--------} -function TffSrSimpleCursor.InsertRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; -var - NewRefNr : TffInt64; -begin - { Notify extenders. } - Result := NotifyExtenders(ffeaBeforeRecInsert, ffeaInsertRecFail); - - if Result = DBIERR_NONE then begin - AcqContentLock(ffclmWrite); - Result := bcTable.InsertRecord(bcDatabase.TransactionInfo, - CursorID, aData, aLockType, NewRefNr); - if (Result = DBIERR_NONE) then begin - bcInfo.pos := cpOnRecord; - bcInfo.refNr := NewRefNr; - bcInfo.Deleted := false; - bcInfo.KeyValid := True; - { Notify extenders of successful insert. } - NotifyExtenders(ffeaAfterRecInsert, ffeaNoAction); - end else - { Notify extenders of failed insert. } - NotifyExtenders(ffeaInsertRecFail, ffeaNoAction); - end; -end; -{--------} -function TffSrSimpleCursor.InsertRecordNoDefault(aData : PffByteArray;{!!.10} - aLockType : TffSrLockType) : TffResult; -var - NewRefNr : TffInt64; -begin - { Notify extenders. } - Result := NotifyExtenders(ffeaBeforeRecInsert, ffeaInsertRecFail); - - if Result = DBIERR_NONE then begin - AcqContentLock(ffclmWrite); - Result := bcTable.InsertRecordNoDefault(bcDatabase.TransactionInfo,{!!.10} - CursorID, aData, aLockType, NewRefNr); - if (Result = DBIERR_NONE) then begin - bcInfo.pos := cpOnRecord; - bcInfo.refNr := NewRefNr; - bcInfo.Deleted := false; - bcInfo.KeyValid := True; - { Notify extenders of successful insert. } - NotifyExtenders(ffeaAfterRecInsert, ffeaNoAction); - end else - { Notify extenders of failed insert. } - NotifyExtenders(ffeaInsertRecFail, ffeaNoAction); - end; -end; -{--------} -function TffSrSimpleCursor.IsInRange(aKey : PffByteArray) : integer; -begin - { This class does not support ranges. } - Result := 0; - FFRaiseException(EffException, ffStrResServer, fferrRangeNotSupported, - [bcTable.BaseName, Self.ClassName]); -end; -{--------} -function TffSrSimpleCursor.ModifyRecord(aData : PffByteArray; aRelLock : boolean) : TffResult; -var {!!.05} - aKeyChanged: Boolean; {!!.05} -begin - - { Note: By this time, any other cursor deleting or modifying the record ahead - of us has completed and has set bcInfo.Deleted. We can be assured of this - because TffServerEngine.RecordDelete calls Cursor.EnsureWritable(true) which - obtains a lock on the record to be deleted. We won't get that lock until - the other cursor has finished. } - - { Has this record already been deleted? } - if bcInfo.Deleted then begin - { Yes. } - Result := DBIERR_KEYORRECDELETED; - Exit; - end; - - { Are we on a record? } - if (bcInfo.Pos <> cpOnRecord) then begin - { No. } - case bcInfo.Pos of - cpBOF : Result := DBIERR_BOF; - cpEOF : Result := DBIERR_EOF; - else - Result := DBIERR_NOCURRREC; - end; - Exit; - end; - - { Notify extenders. } - Result := NotifyExtenders(ffeaBeforeRecUpdate, ffeaUpdateRecFail); - if Result = DBIERR_NONE then begin - AcqContentLock(ffclmWrite); - Result := bcTable.PutRecord(bcDatabase.TransactionInfo, CursorID, bcInfo.refNr, - aData, aRelLock, aKeyChanged); {!!.05} - if (Result = DBIERR_NONE) then begin - bcInfo.KeyValid := True; - bcInfo.pos := cpOnRecord; - { Notify extenders of successful update. } - NotifyExtenders(ffeaAfterRecUpdate, ffeaNoAction); - end else - { Notify extenders of failed update. } - NotifyExtenders(ffeaUpdateRecFail, ffeaNoAction); - end; -end; -{--------} -procedure TffSrSimpleCursor.Open(const aTableName : TffTableName; - const aIndexName : TffName; - const aIndexID : Longint; - const aOpenMode : TffOpenMode; - aShareMode : TffShareMode; - aForServer : boolean; - const aExclContLock : Boolean; {!!.10} - aAttribs : TffFileAttributes); -begin - inherited Open(aTableName, aIndexName, aIndexID, aOpenMode, aShareMode, - aForServer, aExclContLock, aAttribs); {!!.10} - SetToBegin; -end; -{--------} -procedure TffSrSimpleCursor.ResetRange; -begin - FFRaiseException(EffException, ffStrResServer, fferrRangeNotSupported, - [bcTable.BaseName, Self.ClassName]); -end; -{--------} -function TffSrSimpleCursor.SetRange(aDirectKey : boolean; - aFieldCount1 : integer; - aPartialLen1 : integer; - aKeyData1 : PffByteArray; - aKeyIncl1 : boolean; - aFieldCount2 : integer; - aPartialLen2 : integer; - aKeyData2 : PffByteArray; - aKeyIncl2 : boolean) : TffResult; -begin - Result := DBIERR_FF_RangeNotSupported; - FFRaiseException(EffException, ffStrResServer, fferrRangeNotSupported, - [bcTable.BaseName, Self.ClassName]); -end; -{--------} -procedure TffSrSimpleCursor.SetToBegin; -begin - AcqContentLock(ffclmRead); - try - bcInfo.Deleted := False; - bcInfo.KeyValid := False; - bcInfo.Pos := cpBOF; - FFInitI64(bcInfo.RefNr); - finally - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrSimpleCursor.SetToBookmark(aBookmark : PffByteArray) : TffResult; -begin - Result := CheckBookmark(aBookmark); - if (Result = DBIERR_NONE) then begin - AcqContentLock(ffclmRead); - try - { Initialize the key path. } - FFInitKeyPath(bcInfo.KeyPath); - with PffSrBookmark(aBookmark)^ do begin - bcInfo.Pos := sbPos; - bcInfo.RefNr := sbRefNr; - bcInfo.KeyValid := sbKeyValid; - bcInfo.Deleted := false; - - { Does the record still exist? } - try - bcTable.GetRecord(bcDatabase.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, sbRefNr, {!!.10} - bcRecordData, ffsltNone, false, false); {!!.02} - except - on E:EffException do begin - if E.ErrorCode = fferrRecDeleted then begin - bcInfo.Pos := cpOnCrack; - bcInfo.Deleted := True; - end - else begin - SetToBegin; - Result := DBIERR_INVALIDBOOKMARK; - end; - end - else begin - SetToBegin; - Result := DBIERR_INVALIDBOOKMARK; - end; - end; - end; { with } - finally - RelContentLock(ffclmRead); - end; - end; -end; -{--------} -function TffSrSimpleCursor.SetToCursor(aCursor : TffSrBaseCursor) : TffResult; -begin - Result := DBIERR_NONE; - if (aCursor.Table <> Table) then begin - Result := DBIERR_DIFFERENTTABLES; - Exit; - end; - - AcqContentLock(ffclmRead); - try - bcInfo := aCursor.CursorInfo; - finally - RelContentLock(ffclmRead); - end; -end; -{--------} -procedure TffSrSimpleCursor.SetToEnd; -begin - AcqContentLock(ffclmRead); - try - bcInfo.Pos := cpEOF; - bcInfo.KeyValid := False; - FFInitI64(bcInfo.refNr); - bcInfo.Deleted := false; - finally - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrSimpleCursor.SetToKey(aSearchAction : TffSearchKeyAction; - aDirectKey : boolean; - aFieldCount : integer; - aPartialLen : integer; - aKeyData : PffByteArray) : TffResult; -begin - { To set to a specific record, specify a value for the RefNr property. } - Result := DBIERR_INVALIDINDEXCREATE; - FFRaiseException(EffException, ffStrResServer, fferrIndexNotSupported, - [bcTable.BaseName, Self.ClassName]); -end; -{--------} -function TffSrSimpleCursor.SwitchToIndex(aIndexID : integer; - aPosnOnRec : boolean) : TffResult; -begin - Result := DBIERR_INVALIDINDEXCREATE; - FFRaiseException(EffException, ffStrResServer, fferrIndexNotSupported, - [bcTable.BaseName, Self.ClassName]); -end; -{====================================================================} -end. diff --git a/components/flashfiler/sourcelaz/ffsrcvex.pas b/components/flashfiler/sourcelaz/ffsrcvex.pas deleted file mode 100644 index 8add06e57..000000000 --- a/components/flashfiler/sourcelaz/ffsrcvex.pas +++ /dev/null @@ -1,182 +0,0 @@ -{*********************************************************} -{* FlashFiler: Server exception conversion to dbiResult *} -{*********************************************************} - -(* ***** 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 ffsrcvex; - -interface - -uses - Classes, - Windows, - SysUtils, - ffconst, - ffllbase, - fflllog, - ffsrmgr, - ffllexcp, - ffsrbase, - ffsrbde; - -function ConvertServerExceptionEx(E : Exception; - aLog : TffBaseLog; - const aReadOnly : Boolean) : TffResult; - -function ConvertServerException(E : Exception; aLog : TffBaseLog) : TffResult; - -implementation - -function ConvertServerExceptionEx(E : Exception; - aLog : TffBaseLog; - const aReadOnly : Boolean) : TffResult; - -var - ErrorCode : integer; -begin - {log it} - if assigned(aLog) and (not aReadOnly) then - aLog.WriteString(Format('Exception Cvt: %s', [E.Message])); - - {convert the FlashFiler-specific exceptions} - if E is EffException then begin - ErrorCode := EffException(E).ErrorCode; - case ErrorCode of - fferrBadStruct : Result := DBIERR_FF_BadStruct; - fferrOpenFailed : Result := DBIERR_FF_OpenFailed; - fferrOpenNoMem : Result := DBIERR_FF_OpenNoMem; - fferrCloseFailed : Result := DBIERR_FF_CloseFailed; - fferrReadFailed : Result := DBIERR_FF_ReadFailed; - fferrReadExact : Result := DBIERR_FF_ReadExact; - fferrWriteFailed : Result := DBIERR_FF_WriteFailed; - fferrWriteExact : Result := DBIERR_FF_WriteExact; - fferrSeekFailed : Result := DBIERR_FF_SeekFailed; - fferrFlushFailed : Result := DBIERR_FF_FlushFailed; - fferrSetEOFFailed : Result := DBIERR_FF_SetEOFFailed; - fferrCopyFile : Result := DBIERR_FF_CopyFile; - fferrDeleteFile : Result := DBIERR_FF_DeleteFile; - fferrRenameFile : Result := DBIERR_FF_RenameFile; - fferrNotAnFFFile : Result := DBIERR_UNKNOWNFILE; - fferrBadBlockNr : Result := DBIERR_FF_BadBlockNr; - fferrEncrypted : Result := DBIERR_TBLENCRYPTED; - fferrRecDeleted : Result := DBIERR_FF_RecDeleted; - fferrBadRefNr : Result := DBIERR_FF_BadRefNr; - fferrBadDataBlock : Result := DBIERR_FF_BadDataBlock; - fferrBlobDeleted : Result := DBIERR_BLOBERR; - fferrBadBlobNr : Result := DBIERR_INVALIDBLOBHANDLE; - fferrBadBlobBlock, - fferrBadBlobSeg : Result := DBIERR_BLOBERR; - fferrLenMismatch : Result := DBIERR_INVALIDBLOBLEN; - fferrOfsNotInBlob : Result := DBIERR_INVALIDBLOBOFFSET; - fferrFileBlobWrite : Result := DBIERR_READONLYFLD; - fferrBadStreamBlock : Result := DBIERR_FF_BadStreamBlock; - fferrBadStreamOrigin: Result := DBIERR_FF_BadStreamOrigin; - fferrStreamSeekError: Result := DBIERR_FF_StreamSeekError; - fferrBadInxBlock : Result := DBIERR_FF_BadInxBlock; - fferrBadIndex : Result := DBIERR_FF_BadIndex; - fferrMaxIndexes : Result := DBIERR_FF_MaxIndexes; - fferrBadMergeCall : Result := DBIERR_FF_BadMergeCall; - fferrKeyNotFound : Result := DBIERR_FF_KeyNotFound; - fferrKeyPresent : Result := DBIERR_FF_KeyPresent; - fferrNoKeys : Result := DBIERR_FF_NoKeys; - fferrNoSeqAccess : Result := DBIERR_FF_NoSeqAccess; - fferrBadApproxPos : Result := DBIERR_FF_BadApproxPos; - fferrBadServerName : Result := DBIERR_FF_BadServerName; - fferrFFV1File : Result := DBIERR_FF_V1File; - fferrCommsNoWinRes, - fferrCommsCannotCall, - fferrCommsCantListen, - fferrWinsock, - fferrWSNoSocket, - fferrWSNoLocalAddr : Result := DBIERR_NETUNKNOWN; - fferrUnknownClient, - fferrUnknownSession : Result := DBIERR_INVALIDHNDL; - fferrUnknownAlias : Result := DBIERR_UNKNOWNDB; - fferrUnknownPath : Result := DBIERR_INVALIDDIR; - fferrUnknownDB : Result := DBIERR_INVALIDHNDL; - fferrUnknownTable : Result := DBIERR_NOSUCHTABLE; - fferrUnknownIndex : Result := DBIERR_NOSUCHINDEX; - fferrUnknownCursor, - fferrUnknownTrans : Result := DBIERR_INVALIDHNDL; - fferrUnknownMsg : Result := DBIERR_FF_UnknownMsg; - fferrTmpStoreFull : Result := DBIERR_FF_TempStorageFull; - fferrDBExclusive : Result := DBIERR_NEEDEXCLACCESS; - fferrDBReadOnly : Result := DBIERR_READONLYDB; - fferrTableExclusive : Result := DBIERR_NEEDEXCLACCESS; - fferrCursorReadOnly : Result := DBIERR_TABLEREADONLY; - fferrWriteLocked : Result := DBIERR_LOCKED; - fferrReadLocked : Result := DBIERR_LOCKED; - fferrCannotUnlock : Result := DBIERR_UNLOCKFAILED; - fferrTableLocked : Result := DBIERR_FILELOCKED; - fferrRecLocked : Result := DBIERR_LOCKED; - fferrNoCurrentRec : Result := DBIERR_NOCURRREC; - fferrTableMismatch : Result := DBIERR_DIFFERENTTABLES; - fferrNoNextRecord : Result := DBIERR_EOF; - fferrNoPriorRecord : Result := DBIERR_BOF; - fferrTableExists : Result := DBIERR_TABLEEXISTS; - fferrBadFieldXform : Result := DBIERR_INVALIDXLATION; - fferrBadBookmark : Result := DBIERR_INVALIDBOOKMARK; - fferrTransactionFailed : Result := DBIERR_WRITEERR; - fferrTableFull : Result := DBIERR_TABLEFULL; - fferrDiskFull : Result := DBIERR_NODISKSPACE; {!!.11} - fferrTableVersion : Result := DBIERR_FF_TABLEVERSION; {!!.11} - fferrInvalidSqlStmtHandle : Result := DBIERR_INVALIDHNDL; - fferrBLOBTooBig : Result := DBIERR_FF_BLOBTooBig; - fferrDeadlock : Result := DBIERR_FF_Deadlock; - fferrLockTimeout : Result := DBIERR_LOCKED; - fferrLockRejected : Result := DBIERR_LOCKED; {!!.02} - fferrTableLockTimeout : Result := DBIERR_FILELOCKED; - fferrGeneralTimeout : Result := DBIERR_FF_GeneralTimeout; - fferrNoSQLEngine : Result := DBIERR_FF_NoSQLEngine; - fferrIndexNotSupported : Result := DBIERR_INVALIDINDEXCREATE; - fferrInvalidTableName : Result := DBIERR_INVALIDTABLENAME; - fferrRangeNotSupported : Result := DBIERR_FF_RangeNotSupported; - fferrTableOpen : Result := DBIERR_TABLEOPEN; - DBIERR_TABLEREADONLY : Result := ErrorCode; {!!.06} - fferrIncompatDict : Result := DBIERR_FF_IncompatDict; {!!.06} - fferrSameTable : Result := DBIERR_FF_SameTable; {!!.06} - else - Result := DBIERR_FF_Unknown; - end;{case} - end - {convert out of memory errors} - else if E is EOutOfMemory then begin - Result := DBIERR_NOMEMORY; - end - {convert all other exceptions to fatal error code} - else - Result := DBIERR_FF_UnknownExcp; -end; -{--------} -function ConvertServerException(E : Exception; aLog : TffBaseLog) : TffResult; -begin - Result := ConvertServerExceptionEx(E, aLog, False); -end; - -end. diff --git a/components/flashfiler/sourcelaz/ffsreng.pas b/components/flashfiler/sourcelaz/ffsreng.pas deleted file mode 100644 index 895855e90..000000000 --- a/components/flashfiler/sourcelaz/ffsreng.pas +++ /dev/null @@ -1,15747 +0,0 @@ -{Notes: - 1. The perform dynamic link call has been commented out in the - server engine create. - - 2. Server-side objects are freed when a client requests the object be closed - (e.g., SessionRemove) & all of its dependent objects report they be - closed. For example, a TffSrDatabase can be closed only if no other - thread is using the TffSrDatabase and its associated cursors report they - are inactive. - - If a server-side object cannot be freed when the close request is received - from the client then the server's garbage collection thread will - eventually free the object. - - 3. When adding new TffServerEngine methods, please follow these guidelines: - - a. All steps should be wrapped with a Try..Except block. At a minimum, - the Try..Except block must do the following: - - try - ... - except - on E : Exception do begin - Result := ConvertServerException(E, btEngine.EventLog); - end; - end; - - This ensures the client is returned an error code that it - understands. - - b. If you call any of the CheckxxxIDAndGet methods, the remaining - code should be wrapped with a try..finally block. The Finally - section should call "xxxx.Deactivate". Why? Because the - CheckxxxxIDAndGet methods mark the relevant object as Active to make - sure it is not freed by another thread. Once the operation has - completed, the object must be marked as Inactive so that it may - be closed and freed at a later time. - -} - -{*********************************************************} -{* FlashFiler: Server Engine 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 define to debug RAM pages. } -{.$DEFINE RAMPageCheck} - -{ Enable the following to debug the deleted record count. } -{.$DEFINE DebugDelCount} - -{ Diasable the following to retrieve files using DatabaseTableList that - are not FlashFiler 2 Tables. } -{$DEFINE OnlyRetrieveTables} {!!.01} - -unit ffsreng; - -interface - -uses - Windows, - SysUtils, - Classes, - Forms, - FFStDate, - FFConst, - FFLLBase, - FFLLEng, - FFLLDict, - FFLLThrd, - FFSrMgr, - FFLLExcp, - FFLLLog, - FFLLProt, - FFLLTemp, - FFLLUNC, - FFHash, - FFNetMsg, - FFSrBase, - FFFile, - FFSqlBas, - FFSrIntf, - FFSrBDE, - FFSrCfg, - FFSrFMap, - FFSrIntm, - FFSrStat, - FFSrCvEx, - FFSrFold, - FFSrIxhl, - FFSrLock, - FFSrTran, - FFSrFltr, - FFConvFF, - FFTbBase, - FFTbData, - FFTbBLOB, - FFTbDict, - FFTbIndx; - -{===Read/Write alias data from table=================================} -const - ffc_SavPrefix = 'SAV'; - ffc_StdPrefix = 'FFS'; - ffc_TmpPrefix = 'XXS'; - - ffc_AliasSuffix = 'ALIAS'; - ffc_IndexSuffix = 'INDEX'; - ffc_InfoSuffix = 'INFO'; - ffc_UserSuffix = 'USER'; - - ffc_AliasTableName = 'FFSALIAS'; - ffc_SavedAliasTableName = 'SAVALIAS'; - ffc_TempAliasTableName = 'XXSALIAS'; - - ffc_IndexTableName = 'FFSINDEX'; - ffc_SavedIndexTableName = 'SAVINDEX'; - ffc_TempIndexTableName = 'XXSINDEX'; - - ffc_GenInfoTableName = 'FFSINFO'; - ffc_SavedGenInfoTableName = 'SAVINFO'; - ffc_TempGenInfoTableName = 'XXSINFO'; - - ffc_UserTableName = 'FFSUSER'; - ffc_SavedUserTableName = 'SAVUSER'; - ffc_TempUserTableName = 'XXSUSER'; - - ffc_AliasScript = 'FFAlias.sc$'; - - ffc_ClientShutdownTime : TffWord32 = 10000; {!!.05} - - ffc_StartTranWithDelay : DWORD = 10; {!!.10} - { Used with TransactionStartWith. If a lock cannot be immediately obtained - then the operation will be retried every ffc_StartTranWithDelay - milliseconds. } - -type - TffCursorPosition = ( {Positions of a cursor in an index} - cpUnknown, {..unknown: must be resolved asap} - cpBOF, {..prior to first record} - cpEOF, {..after last record} - cpOnCrack, {..in between two records} - cpOnRecord); {..on a record somewhere} - - TffRecOp = ( {Record update operations} - roInsert, {..insertion} - roDelete, {..deletion} - roModify); {..modification} - -type - PffSrBookmark = ^TffSrBookmark; - TffSrBookmark = packed record - sbHash : Longint; {validity check} - sbIndexID : Longint; - sbPos : TffCursorPosition; - sbKeyValid : boolean; - sbFill1 : array [0..1] of byte; {to DWORD align} - sbRefNr : TffInt64; - sbKeyLen : Longint; - sbKey : array [0..1] of byte; - end; - -type - TffServerEngine = class; {forward declaration} - TffSrTableClass = class of TffSrBaseTable; {forward declaration} - TffSrBaseTable = class; {forward declaration} - TffSrDatabase = class; {forward declaration} - TffSrSession = class; {forward declaration} - TffSrClient = class; {forward declaration} - TffSrStmtList = class; {forward declaration} {!!.10} - - { This type identifies the state of a TffServerObject. Given the - multi-threaded nature of the server engine, it is possible for thread A - to be using an object while thread B processes a command that would result - in the closing and freeing of the object. For example, in thread A a - cursor is waiting to obtain an exclusive page lock. While the cursor - is waiting, the client times out and issues a CloseCursor command to - the server. Thread B processes the CloseCursor command. Thread B - must see that the cursor is active and thread B must not free the cursor. - Doing so would cause an access violation as soon as thread A tries to - use the cursor once more. } - TffServerObjectState = (ffosInactive, ffosActive, ffosClosePending, - ffosClosing); - { ffosInactive - The object is not being used by a thread. - ffosActive - The object is being used by a thread. - ffosClosePending - Thread A is using the object but thread B wants - to free the object. Thread A is responsible for freeing the object - once it has finished its operation. - ffosClosing - The object is being freed by a thread. } - - { Contains the essential properties and methods for a server object (e.g., - client, session, database, cursor). Before a thread can use a server object - it must call the Activate method. If the object can be used then the - Activate method returns True. - - When a thread has finished using a server object, it must call the - Deactivate method. - - When a thread wants to close and free an object, it must call the - Close method. If the Close method returns True then the thread must - call TffServerObject.Free. } - TffServerObject = class(TffSelfListItem) - protected - soClient : TffSrClient; {!!.10} - { This is a reference to the server object's parent TffSrClient. - It is instantiated for TffSrDatabase, TffSrBaseTable, - and TffSrBaseCursor. } - soLock : TffPadlock; - { Padlock used to prevent re-entrancy on a per-client basis. - This lock is instantiated only for TffServerObjects of type - TffSrClient. } - soState : TffServerObjectState; - soTimeout : Longint; - public - constructor Create(const aTimeout : Longint); - destructor Destroy; override; - - function Activate : boolean; - { This method must be called before a thread can use a server object. - If State is ffosInactive then sets State to ffosActive and returns - True. Otherwise returns False. } - - function CanClose(const Mark : boolean) : boolean; virtual; - { When a server object is to be freed, call this method. If the - object can be freed this method returns True otherwise it returns - False. If the Mark parameter is True then the object's state is - set to ffosClosing. } - - procedure Deactivate; - { When a thread has finished using a server object, it must call this - method. - If State is ffosShutdownPending then the object frees itself. - If State is ffosActive then switches to ffosInactive. - If State is ffosShuttingDown then does nothing with the assumption - that another thread will finish the object's shutdown. } - - procedure ForceClose; virtual; - { Sets the client's state to ffosClosing so that it will free itself - when the server next requests the client to be removed. } - - procedure RequestClose; virtual; {!!.03} - { If an object cannot be closed (i.e., CanClose returns False) then - call this method to submit a request to close the object. } - - function ShouldClose : boolean; virtual; - { When a server object is ready to be freed (i.e., State = ffosClosing), - this method returns True. } - - { Properties } - - property Client : TffSrClient read soClient; {!!.10} - { The object's parent client object. } - - property State : TffServerObjectState read soState write soState; - { The current state of the object. } - - property Timeout : Longint read soTimeout write soTimeout; - { The object's timeout value. } - end; - - { This is the base class for lists of TffServerObjects. } - TffServerObjectList = class(TffObject) - protected {private} - solList : TffThreadList; - protected - public - - constructor Create; virtual; {!!.01} - - destructor Destroy; override; - - procedure BeginRead; - { A thread must call this method to gain read access to the list. } - - procedure BeginWrite; - { A thread must call this method to gain write access to the list. } - - function CanClose(const Mark : boolean) : boolean; virtual; - { Used to determine if all the server objects in the list can be - closed. Returns True if all can be closed otherwise returns False. } - - 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. } - - procedure ForceClose; virtual; - { Use this method to force all objects within the list to set themselves - to a ffosClosing state. } - -{Begin !!.06} - function HasClosableState(const Mark : Boolean) : boolean; - { Use this method to determine if objects have a closable state. Ignores - all other facets of the object. If the Mark parameter is True and all - objects in the list can be closed then sets all objects with state - ffosInactive to ffosClosing. } -{End !!.06} - - procedure RemoveUnused; virtual; - { Use this method to free objects that could not be freed at the time - they were closed. } - -{Begin !!.03} - procedure RequestClose; virtual; - { Use this method to request a close on all objects contained in the - list. } -{End !!.03} - - function ShouldClose : boolean; virtual; - { Use this method to determine if all the objects in the list should - be closed. } - - end; - - TffSrCursorInfo = packed record - Deleted : boolean; - { If true then the record referenced by this information has been - deleted. } - KeyPath : TffKeyPath; - {This is a trail into the current index that leads us to a - specific record, crack between two records, EOF, or BOF} - KeyValid : boolean; - {This variable is set to True when we position to the - next or previous record, reposition to an existing record, - retrieve a record for a key, or position to a bookmark that is on a - valid record. - - When this variable is True, we can rely upon the key stored in - variable bcCurKey. - - This variable is set to False when we insert a record, modify a - record, or otherwise need to force a recalculation of the key - path to a record (e.g., TffSrCursor.SetToBegin, - TffSrCursor.SwitchToIndex). } - Pos : TffCursorPosition; - { This tells us whether the cursor is on a specific record, at BOF, - at EOF, or on a crack between two records. } - RefNr : TffInt64; - { Reference number of the current record. This is its physical position - within the file. For example, if RefNr = 128,556 then the record - starts at position 128,556 within the data file. } - end; - - TffContentLockMode = (ffclmCommit, ffclmRead, ffclmWrite); - { Used by cursor to indicate what type of content lock is needed. } - - TffSrBaseCursor = class; {forward declaration} - TffSrCursorClass = class of TffSrBaseCursor; {forward declaration} {!!.06} - - TffSrCopyRecordsProc = procedure(aSrcCursor : TffSrBaseCursor; - aSrcRecord : PffByteArray; - aCookie1, aCookie2 : Longint; - var include : boolean) of object; - { Defines the event handler for the CopyRecords method. - SrcCursor is the cursor from which the record is being copied. - aSrcRecord is the record to be copied. - Set include to True if the record is to be copied, otherwise set it to - False. } - - { Use the following type to describe how columns within a simple table should - be sorted. } - TffOrderByDirection = (ffobAscending, ffobDescending); - - PffOrderByArray = ^TffOrderByArray; - TffOrderByArray = array[0..ffcl_MaxIndexFlds] of TffOrderByDirection; - - { Defines the standard interface for a cursor. Note that once you create a - cursor, you must call its Open method to open a cursor for an existing - table. If the table does not yet exist, use the Build method to create - the table and open the cursor on the new table. } - TffSrBaseCursor = class(TffServerObject) - protected {private} - bcTableClass : TffSrTableClass; - { The type of table to be created by the cursor. - Be sure to initialize it to the appropriate value in the - inherited constructors before calling one of the TffSrBaseCursor - constructors. } - - bcBLOBCursors : TffList; { List of cursors for which we have - dereferenced BLOB links. } - bcCloseTable : Boolean; { Set to True if the cursor is to close - its table when the cursor is freed. - Standard cursors leave the table open - because other clients may need to access - the same table. SQL cursors close the - table right away because the result set - is typically for only one client. } - bcCloseWTrans : Boolean; {!!.05} - bcDatabase : TffSrDatabase; - bcEngine : TffServerEngine; {the engine with which this cursor is - associated } - bcExclOwner : Boolean; {If True then cursor has exclusively - opened the table. } - bcExtenders : TffList; - {-List of engine extenders associated with this cursor. } - - bcIndexID : Longint; -{Begin !!.03} - bcLockedRefNum : TffInt64; { Last record locked via GetRecord - method. The cursor tracks this to - ensure that a record lock obtained - via TffTable.Edit, while an implicit - transaction is in effect, will be - unlocked if the client abruptly - terminates. } -{End !!.03} - bcNumReadLocks : Integer; { Number of open read locks.} {!!.05} - bcTable : TffSrBaseTable; - bcTempStore : TffBaseTempStorage; - - bcKID : TffKeyIndexData; {work field for index access} - bcCompareData: TffCompareData; {ditto} - bcCurKey : PffByteArray; {current key} - bcFilter : TffSrFilter; {filter object} - bcFilterSav : TffSrFilter; {overridden filter} - bcHasRange : Boolean; {whether range is active} - bcInfo : TffSrCursorInfo; {the cursor's current position, key path, - reference number, etc. } -{Begin !!.06} - bcInfoLock : TffPadlock; {Used to prevent transaction from - clearing a cursor's key path while the - cursor is navigating to next or prev - record. } -{End !!.06} - bcOpenMode : TffOpenMode; - bcRecordData : PffByteArray; {work record data area} - bcRecordLen : Integer; {record length} - bcRng1Valid : Boolean; {is low range point valid?} - bcRng2Valid : Boolean; {is high range point valid?} - bcRng1Key : PffByteArray; {range start key} - bcRng2Key : PffByteArray; {range end key} - bcRng1FldCnt : Integer; {range start field count} - bcRng2FldCnt : Integer; {range end field count} - bcRng1PtlLen : Integer; {range start partial length} - bcRng2PtlLen : Integer; {range end partial length} - bcRng1Incl : Boolean; {range includes start key} - bcRng2Incl : Boolean; {range includes end key} - bcSavedInfo : TffSrCursorInfo; {temporary work area for bcSaveCurInfo & - bcRestoreCurInfo } - - bcNewRecBuff : PffByteArray; { exclusively used by extenders } - bcOldRecBuff : PffByteArray; { exclusively used by extenders } - - bcNeedNestedTransaction : Boolean; {If set to true all operations on the - cursor use a nested transaction if needed} - - procedure bcAddExtender(anExtender : TffBaseEngineExtender); - {-Use this method to add an extender to the list of extenders - interested in a cursor. } - - function bcBLOBCopy(aSrcCursor : TffSrBaseCursor; - const aBLOBNr : TffInt64; - var aDestBLOBNr : TffInt64) : TffResult; - { Used to copy a BLOB from one cursor to another. } - - function bcBLOBLinkGetLength(const aTableName : TffTableName; - const aBLOBNr : TffInt64; - var aLength : Longint) : TffResult; virtual; - {-Used to obtain the length of a BLOB referenced by a BLOB link within - a record of this cursor's result set. } - - function bcBLOBLinkRead(const aTableName : TffTableName; - const aBLOBNr : TffInt64; - const aOffset : TffWord32; {!!.06} - const aLen : TffWord32; {!!.06} - var aBLOB; - var aBytesRead : TffWord32) {!!.06} - : TffResult; - {-Used to read a BLOB referenced by a BLOB link within a record of this - cursor's result set. } - - function bcCheckExclusiveReadWrite : TffResult; virtual; - {-Verifies the cursor has exclusive read-write access to the table. } - - function bcFindBLOBCursor(const aTableName : TffTableName) : TffSrBaseCursor; virtual; - {-Finds a BLOB cursor based upon a table name. } - - function bcGetAttribs : TffFileAttributes; virtual; - - function bcGetCursorID : TffCursorID; virtual; - - function bcGetPosition : TffCursorPosition; - - function bcGetRefNr : TffInt64; - - procedure bcInit(const aOpenMode : TffOpenMode; - const aShareMode : TffShareMode; - const aExclContLock : Boolean); virtual; {!!.10} - {-Called from a cursor constructor. Performs misc. initializations. } - - procedure bcInvalidateCurKey; - function bcIsCurKeyPathValid : boolean; - function bcIsCurKeyValid: boolean; - procedure bcRebuildKeyPath; {!!.05 - Moved from TffSrCursor.scRebuildKeyPath} - { If the cursor has a valid key, this method rebuilds the cursor's key - path. } - - procedure bcTableOpenPreconditions(aTable : TffSrBaseTable; - const aIndexName : string; - var aIndexID : Longint; - const aOpenMode : TffOpenMode); virtual; abstract; - { Used by Create method to verify a thread may open a table. } - - procedure bcTableOpenPrim(aDatabase : TffSrDatabase; - const aTableName : TffTableName; - const aOpenMode : TffOpenMode; - const aShareMode : TffShareMode; - const aForServer : boolean; - const aAttribs : TffFileAttributes); virtual; - { Primitive engine method for opening a table. } - - procedure bcRecordUpdated(aOp : TffRecOp; - aRefNr : TffInt64; - aIndexID : integer); virtual; - { Called when another cursor has updated a record in the same - table. Gives this cursor a chance to update its internal - information (e.g., whether or not the current record has been - deleted, key path status). } - - procedure bcRestoreCurInfo; virtual; - { Restore the cursor's position, reference number, key, etc. - as saved via scSaveCurValues. } - - procedure bcSaveCurInfo; virtual; - { Save the cursor's current position, reference number, key, etc. } - - function bcGetDictionary: TffDataDictionary; virtual; - - public - constructor Create(anEngine : TffServerEngine; - aDatabase : TffSrDatabase; - const aTimeout : Longint); virtual; - - destructor Destroy; override; - -{Begin !!.10} - procedure AcqContentLock(const aMode : TffContentLockMode); virtual; - { Acquire unconditional content lock. } - function AcqExclContentLock : TffResult; virtual; - { Acquire conditional content lock (i.e., the lock is obtained only if - it can be immediately granted). } -{End !!.10} - - { Used by threads to obtain a content lock. } - function AddIndexToTable(const aIndexDesc : TffIndexDescriptor) : TffResult; virtual; abstract; - procedure AppendNewRecord(aData : PffByteArray); virtual; - - { BLOB methods } - function BLOBAdd(var aBLOBNr : TffInt64) : TffResult; virtual; - - function BLOBLinkAdd(const aTableName : TffTableName; - const aTableBLOBNr : TffInt64; - var aBLOBNr : TffInt64) : TffResult; virtual; - { Adds a link to a BLOB in another table to the cursor's table. } - - procedure Build(const aTableName : TffTableName; - aDict : TffDataDictionary; - const aOpenMode : TffOpenMode; - aShareMode : TffShareMode; - aForServer : boolean; - aOverWrite : boolean; - aAttribs : TffFileAttributes; - aStoreSize : TffWord32); virtual; - { Use this method to open a cursor for a table that does not - yet exist. This method uses aDict to create the table. This method - then opens the cursor and positions to the Sequential Access Index - (i.e., index 0). } - - function CanClose(const Mark : boolean) : boolean; override; {New !!.01} - { A cursor can close if it is not active & is not involved in a - transaction. } - - function FileBLOBAdd(const aFileName : TffFullFileName; - var aBLOBNr : TffInt64) : TffResult; virtual; - - function BLOBDelete(const aBLOBNr : TffInt64) : TffResult; virtual; - - function BLOBFree(aBLOBNr : TffInt64) : TffResult; virtual; - - function BLOBGetLength(aBLOBNr : TffInt64; - var aFBError: TffResult) : Longint; virtual; - - function BLOBIsLink(aBLOBNr : TffInt64; {!!.11 - New} - var aSrcTableName : TffTableName; - var aSrcTableBLOBNr : TffInt64) - : Boolean; - -{Begin !!.03} - function BLOBListSegments(aBLOBNr : TffInt64; - aStream : TStream) : TffResult; virtual; -{End !!.03} - function BLOBRead(aBLOBNr : TffInt64; - aOffset : TffWord32; {!!.06} - aLen : TffWord32; {!!.06} - var aBLOB; - var aBytesRead : TffWord32) {!!.06} - : TffResult; virtual; - - function BLOBTruncate(aBLOBNr : TffInt64; - aLen : TffWord32) : TffResult; virtual; - - function BLOBWrite(const aBLOBNr : TffInt64; - aOffset : TffWord32; - aLen : TffWord32; - var aBLOB) : TffResult; virtual; - - function CheckBookmark(aBookmark : PffByteArray) : TffResult; virtual; abstract; - procedure ClearIndex; virtual; abstract; - function CloneCursor(aOpenMode : TffOpenMode) : TffSrBaseCursor; virtual; abstract; - function CompareBookmarks(aBookmark1, aBookmark2 : PffByteArray; - var CmpResult : Longint) : TffResult; virtual; abstract; - function CopyRecords(aSrcCursor : TffSrBaseCursor; aBLOBCopyMode : TffBLOBCopyMode; - aCallback : TffSrCopyRecordsProc; - aCookie1, aCookie2 : Longint) : TffResult; virtual; - { Use this method to copy all records from a source cursor to this - cursor. Copies only those records matching the range and/or filter - applied to the source cursor. - - Requirement: The source and destination cursors must have compatible - dictionaries. The dictionaries must have the same field order, field - type, length, units, and decimal places. - - If a record contains BLOBs, they are handled based upon the - aBLOBCopyMode parameter. If mode is ffbcmNoCopy then the BLOB fields - are set to NULL in the destination record. If mode is ffbcmCopyFull - then the BLOBs are copied wholesale to the destination cursor. - If mode is ffbcmCreateLink then the destination cursor is given a - link to the BLOB in the source cursor. - - Use aCallback to have a validation routine called for each r4ecord - that is copied. The validation routine has the opportunity to - inspect the record and tell this routine whether or not to copy the - record. } - - function CopyRecordParts(aSrcCursor : TffSrBaseCursor; - aFields : PffLongintArray; - aNumFields : integer; - aBLOBCopyMode : TffBLOBCopyMode; - aCallback : TffSrCopyRecordsProc; - aCookie1, aCookie2 : Longint) : TffResult; virtual; - { Similar to the CopyRecords method except this method allows you to - copy specific fields from the source cursor. aFields identifies the - fields to be copied. Each element of aFields is a field number in - the source cursor's dictionary (base zero). The fields are copied in - the order specified. - - The destination cursor's dictionary must have fields that match the - specified fields in the source dictionary except that they must be - in the order specified by aFields. - } - function DeleteRecord(aData : PffByteArray) : TffResult; virtual; -{Begin !!.06} - function DeleteRecords : TffResult; virtual; - { Delete all records in the cursor's result set, taking into account - the active filter and/or range. } -{End !!.06} - function DropIndexFromTable(const aIndexName : TffDictItemName; - aIndexID : Longint) : TffResult; virtual; abstract; - function Empty : TffResult; virtual; - function EnsureWritable(aCheckCurRec, aConditionalLock : boolean) : TffResult; virtual; - { Ensures the cursor is writable. If aCheckCurRec is true, this method - attempts to obtain an Exclusive, Commit duration lock on the - record. If aConditionalLock is also True then the method succeeds only - if it is able to immediately obtain the Exclusive lock. } - function ExtractKey(aData : PffByteArray; aKey : PffByteArray) : TffResult; virtual; abstract; - function GetBookmark(aBookmark : PffByteArray) : TffResult; virtual; abstract; - function GetBookmarkSize : integer; virtual; abstract; - function GetRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; virtual; - function GetRecordCount(var aRecCount : Longint) : TffResult; virtual; abstract; - function GetNextRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; virtual; abstract; - function GetPriorRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; virtual; abstract; - function GetRecordField(aField : integer; - aRecordBuffer : PffByteArray; - var isNull: boolean; - aFieldBuffer : pointer) : TffResult; virtual; - { Obtain the value of a field. } - function GetRecordForKey(aDirectKey : boolean; - aFieldCount : integer; - aPartialLen : integer; - aKeyData : PffByteArray; - aData : PffByteArray; - aFirstCall : Boolean) : TffResult; virtual; abstract; - function InsertRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; virtual; abstract; - function InsertRecordNoDefault(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; virtual; abstract;{!!.10} - function IsInRange(aKey : PffByteArray) : integer; virtual; abstract; - function IsRecordLocked(aLockType : TffSrLockType) : Boolean; virtual; -{Begin !!.03} - procedure ListBLOBFreeSpace(aTI : PffTransInfo; - const aInMemory : Boolean; - aStream : TStream); -{End !!.03} - function OverrideFilter(aExpression : pCANExpr; - aTimeout : TffWord32) : TffResult; virtual; - function ModifyRecord(aData : PffByteArray; aRelLock : Boolean) - : TffResult; virtual; abstract; - function NotifyExtenders(const anAction : TffEngineAction; - const aFailAction : TffEngineAction) - : TffResult; - {-Notifies all extenders associated with the cursor about the - specified action. If ignoreErrCode is True then error codes - returned by extenders are ignored. If failures occur it will - be taken care of before going back to the calling method.} - procedure Open(const aTableName : TffTableName; - const aIndexName : TffName; - const aIndexID : Longint; - const aOpenMode : TffOpenMode; - aShareMode : TffShareMode; - aForServer : Boolean; - const aExclContLock : Boolean; {!!.10} - aAttribs : TffFileAttributes); virtual; - { Use this method to open a cursor for a table that exists. } - - procedure ReadAutoIncValue(var aValue: TffWord32); virtual; - procedure RelContentLock(aMode : TffContentLockMode); virtual; - procedure RelRecordLock(aAllLocks : Boolean); virtual; - procedure RelTableLock(aAllLocks : Boolean); virtual; - procedure RemoveIfUnused; virtual; {!!.05} - procedure ResetRange; virtual; abstract; - function RestoreFilter : TffResult; virtual; - procedure SetAutoIncValue(aValue: TffWord32); virtual; - function SetFilter(aExpression : pCANExpr; - aTimeout : TffWord32) : TffResult; virtual; - function SetRange(aDirectKey : Boolean; - aFieldCount1 : Integer; - aPartialLen1 : Integer; - aKeyData1 : PffByteArray; - aKeyIncl1 : Boolean; - aFieldCount2 : Integer; - aPartialLen2 : Integer; - aKeyData2 : PffByteArray; - aKeyIncl2 : Boolean) : TffResult; virtual; abstract; - procedure SetToBegin; virtual; abstract; - function SetToBookmark(aBookmark : PffByteArray) : TffResult; virtual; abstract; - function SetToCursor(aCursor : TffSrBaseCursor) : TffResult; virtual; abstract; - procedure SetToEnd; virtual; abstract; - function SetToKey(aSearchAction : TffSearchKeyAction; - aDirectKey : boolean; - aFieldCount : integer; - aPartialLen : integer; - aKeyData : PffByteArray) : TffResult; virtual; abstract; - function ShouldClose : boolean; override; {New !!.01} - { A cursor can close if it is not involved in a transaction. } - function SortRecords(aFieldsArray : TffFieldList; - const aOrderByArray : TffOrderByArray; - const aNumFields : integer) : TffResult; virtual; - { Use this method to physically sort the records within a table. - Parameters: - aFieldsArray - Array of field numbers on which the table is being - sorted. Field numbers correspond to the fields in - the table's dictionary. Each element in this array - must have a corresponding element in aOrderByArray. - aOrderByArray - Array of order by indicators, one for each field on - which the table is being sorted. Each element in - this array has a corresponding element in - aFieldsArray. - aNumFields - The number of fields on which the table is being - sorted. - } - function SwitchToIndex(aIndexID : integer; - aPosnOnRec : boolean) : TffResult; virtual; abstract; - - { Properties } - property Attribs : TffFileAttributes read bcGetAttribs; - { Returns the file attributes attached to the table's data file. } - property CloseTable : boolean read bcCloseTable write bcCloseTable; - { Set this property to True if the cursor is to close its table when - the cursor is freed. This is useful for SQL cursors which generate - temporary tables applicable to only one client. } - property CursorID : TffCursorID read bcGetCursorID; - property CursorInfo : TffSrCursorInfo read bcInfo write bcInfo; - property Database : TffSrDatabase read bcDatabase; - property Dictionary : TffDataDictionary read bcGetDictionary; - property Engine : TffServerEngine read bcEngine; - property ExclOwner : boolean read bcExclOwner write bcExclOwner; - property Extenders : TffList read bcExtenders; {!!.02} - property Filter: TffSrFilter read bcFilter; - property IndexID : Longint read bcIndexID; - property Position : TffCursorPosition read bcGetPosition; - property RefNr : TffInt64 read bcGetRefNr; - { Returns the reference number of the current record. } -// property ServerEngine : TFFServerEngine read bcEngine; {Deleted !!.03} - property Table : TffSrBaseTable read bcTable; - - { Used exclusively by extenders, these might not reflect actual values } - property NewRecordBuffer : PffByteArray read bcNewRecBuff; - property OldRecordBuffer : PffByteArray read bcOldRecBuff; - - property NeedNestedTransaction : Boolean {!!.03} - read bcNeedNestedTransaction {!!.03} - write bcNeedNestedTransaction; {!!.03} - end; - - TffSrCursor = class(TffSrBaseCursor) - protected {private} - scKeyLen : integer; {key length for cursor's index} - protected - - procedure bcInit(const aOpenMode : TffOpenMode; - const aShareMode : TffShareMode; - const aExclContLock : Boolean); override; {!!.10} - procedure bcTableOpenPreconditions(aTable : TffSrBaseTable; - const aIndexName : string; - var aIndexID : Longint; - const aOpenMode : TffOpenMode); override; - { Used by Create method to verify a thread may open a table. } - - procedure scRebuildCurKey(aRecData : PffByteArray; - aLockObtained : boolean); - { Rebuilds the cursor's key from the specified record buffer. If - aRecData is nil then this method reads the record from the data file - & rebuilds the key from the retrieved record. - If you have already obtained a lock on the current record, set - aLockObtained := True. Doing so skips an unnecessary lock request. } -// procedure scRebuildKeyPath; {!!.05 - moved to TffSrBaseCursor.bcRebuildKeyPath} -// { If the cursor has a valid key, this method rebuilds the cursor's key -// path. } - public - constructor Create(anEngine : TffServerEngine; - aDatabase : TffSrDatabase; - const aTimeout : Longint); override; - - destructor Destroy; override; - function AddIndexToTable(const aIndexDesc : TffIndexDescriptor) : TffResult; override; - function CheckBookmark(aBookmark : PffByteArray) : TffResult; override; - procedure ClearIndex; override; - function CloneCursor(aOpenMode : TffOpenMode) : TffSrBaseCursor; override; - function CompareBookmarks(aBookmark1, aBookmark2 : PffByteArray; - var CmpResult : Longint) : TffResult; override; - function DropIndexFromTable(const aIndexName : TffDictItemName; - aIndexID : Longint) : TffResult; override; - function ExtractKey(aData : PffByteArray; aKey : PffByteArray) : TffResult; override; - function GetBookmark(aBookmark : PffByteArray) : TffResult; override; - function GetBookmarkSize : integer; override; - function GetNextRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; override; - function GetPriorRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; override; - function GetRecordCount(var aRecCount : Longint) : TffResult; override; - function GetRecordForKey(aDirectKey : boolean; - aFieldCount : integer; - aPartialLen : integer; - aKeyData : PffByteArray; - aData : PffByteArray; - aFirstCall : Boolean) : TffResult; override; - function InsertRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; override; - function InsertRecordNoDefault(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; override;{!!.10} - function IsInRange(aKey : PffByteArray) : integer; override; - function ModifyRecord(aData : PffByteArray; aRelLock : boolean) : TffResult; override; - procedure ResetRange; override; - function SetRange(aDirectKey : boolean; - aFieldCount1 : integer; - aPartialLen1 : integer; - aKeyData1 : PffByteArray; - aKeyIncl1 : boolean; - aFieldCount2 : integer; - aPartialLen2 : integer; - aKeyData2 : PffByteArray; - aKeyIncl2 : boolean) : TffResult; override; - procedure SetToBegin; override; - function SetToBookmark(aBookmark : PffByteArray) : TffResult; override; - function SetToCursor(aCursor : TffSrBaseCursor) : TffResult; override; - procedure SetToEnd; override; - function SetToKey(aSearchAction : TffSearchKeyAction; - aDirectKey : boolean; - aFieldCount : integer; - aPartialLen : integer; - aKeyData : PffByteArray) : TffResult; override; - function SwitchToIndex(aIndexID : integer; - aPosnOnRec : boolean) : TffResult; override; - end; - - TffSrCursorList = class(TffServerObjectList) - protected {private} - protected - function GetCursorItem(Find : TffListFindType; Value : Longint) : TffSrBaseCursor; - public - procedure AddCursor(aCursor : TffSrBaseCursor); - - function CursorCount : integer; - { Returns the number of cursors in the list. } - - procedure DeleteCursor(aCursorID : TffCursorID); - { Removes a cursor from the list and frees the cursor. } - - procedure RemoveCursor(aCursorID : TffCursorID); - { Removes a cursor from the list but does not free the cursor. } - - property Cursor [Find : TffListFindType; Value : Longint] : TffSrBaseCursor - read GetCursorItem; default; - - end; - - { Describes the interface for the representation of a physical table. } - TffSrBaseTable = class(TffSelfListItem) - protected - btBaseName : PffShStr; - btBLOBEngine : TffBaseBLOBEngine; {!!.11} - btBufMgr : TffBufferManager; - btCursorList : TffSrCursorList; - btDictionary : TffServerDataDict; - btEngine : TffServerEngine; - btFiles : TffVCLList; - btFolder : TffSrFolder; - btForServer : Boolean; - btContentLocks : TffLockContainer; - btClientLocks : TffLockContainer; - btOpenIntents : Longint; - btPortal : TffReadWritePortal; -// btUseInternalRollback : boolean; {!!.03}{Deleted !!.11} - -{Begin !!.03} - procedure btCommitBLOBMgr; - { Commits the changes made by the BLOB resource manager to its - in-memory list. } -{End !!.03} - procedure btCreateFile(aFileInx : integer; - aTI : PffTransInfo; - const aExtension : TffExtension; - aForServer : boolean; - aAttribs : TffFileAttributes; - aStore : TffBaseTempStorage); virtual; - procedure btDeleteBLOBsForRecord(aTI : PffTransInfo; - aData : PffByteArray); virtual; - function btGetBaseName : TffTableName; virtual; - function btGetCursorList : TffSrCursorList; virtual; - function btGetDictionary : TffServerDataDict; virtual; - function btGetFile(Inx : integer) : PffFileInfo; virtual; - function btGetFileCount : integer; virtual; - function btGetFolder : TffSrFolder; virtual; - procedure btInformCursors(aSrcCursorID : TffCursorID; - aOp : TffRecOp; - aRefNr : TffInt64; - aIndexID : integer); virtual; - function btGetOpenIntents : Longint; virtual; -{Begin !!.03} - procedure btRollbackBLOBMgr; - { Rolls back the changes made by the BLOB resource manager to its - in-memory list. } -{End !!.03} - procedure btSetFile(Inx : integer; FI : PffFileInfo); virtual; - procedure btSetFileCount(FC : integer); virtual; - procedure btTableUpdated(aDatabaseID : TffDatabaseID); virtual; - procedure btUpdateAutoInc(aTI : PffTransInfo; aData : PffByteArray); virtual; - public - constructor Create(anEngine : TffServerEngine; - const aBaseName : TffTableName; - aFolder : TffSrFolder; - aBufMgr : TffBufferManager; - const aOpenMode : TffOpenMode); virtual; - destructor Destroy; override; - - procedure AcqClientLock(aCursorID : Longint; - const aLockType : TffSrLockType; - const aConditional : Boolean); virtual; - - procedure AcqContentLock(aTrans : TffSrTransaction; - const aLockType : TffSrLockType; - const aConditional : boolean); virtual; -{Begin !!.10} - function AcqExclContentLock(aTrans : TffSrTransaction) : TffResult; virtual; -{End !!.10} - procedure AcqLock(const aCursorID : TffCursorID; - const aLockType : TffSrLockType); virtual; -{Begin !!.03} - procedure AddAttribute(const anAttrib : TffFileAttribute); - { Add an attribute to the table's FF-specific file attributes. } -{End !!.03} - procedure AddIndex(const aIndexDesc : TffIndexDescriptor; - aTI : PffTransInfo); virtual; abstract; - procedure BeginCommit; virtual; - { Before a transaction commits, a thread must call this method. - This ensures that all readers have finished with the table before - the table is updated. When done committing, the thread must call - TffSrTable.EndCommit. } - procedure BeginRead; virtual; - { Threads that are not in a transaction & needing to read data from - the table must call this method prior to reading. When done - reading the thread must call TffSrTable.EndRead. } - procedure BuildFiles(aTI : PffTransInfo; - aForServer : boolean; - aDictionary : TffDataDictionary; - aAttribs : TffFileAttributes; - aStore : TffBaseTempStorage); virtual; abstract; - function BuildKeyForRecord(aIndexID : integer; - aData : PffByteArray; - aKey : PffByteArray; - aFieldCount : integer; - aPartialLen : integer) : TffResult; virtual; abstract; - procedure CloseFiles(commitChanges : boolean; aTI : PffTransInfo); virtual; - procedure CommitChanges(aTI : PffTransInfo); virtual; - function CompareKeysForCursor(var aKID : TffKeyIndexData; - aKey1 : PffByteArray; - aKey2 : PffByteArray) - : Integer; virtual; abstract; - function DeleteRecord(aTI : PffTransInfo; - const aCursorID : TffCursorID; - const aRefNr : TffInt64; - const aLockObtained : Boolean; - var aBTreeChanged : Boolean) {!!.05} - : TffResult; virtual; abstract; - procedure DeregisterOpenIntent; virtual; - { Use this function to deregister intent to open. Should only be - called if RegisterIntentOpen was previously called. } - - procedure DropIndex(aTI : PffTransInfo; aIndexID : Longint); virtual; abstract; - function EmptyFiles(aTI : PffTransInfo) : TffResult; virtual; - procedure EndCommit(aDatabaseID : TffDatabaseID); virtual; - { Call this method after calling BeginCommit and finishing the commit - operation. } - procedure EndRead; virtual; - { Call this method after calling BeginRead and finishing the read - operation. } - function FindKey(var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aAction : TffSearchKeyAction) : boolean; virtual; abstract; - function GetNextKey(var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath) : TffResult; virtual; abstract; - function GetNextRecord(aTI : PffTransInfo; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.10} - var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aData : PffByteArray; - const aLockType : TffSrLockType) : TffResult; virtual; abstract; - procedure GetNextRecordSeq(aTI : PffTransInfo; - var aRefNr : TffInt64; - aData : PffByteArray); virtual; - procedure GetPrevRecordSeq(aTI : PffTransInfo; - var aRefNr : TffInt64; - aData : PffByteArray); virtual; - function GetPriorRecord(aTI : PffTransInfo; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.10} - var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aData : PffByteArray; - const aLockType : TffSrLockType) : TffResult; virtual; abstract; {!!.10} - function GetRecord(aTI : PffTransInfo; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.10} - aRefNr : TffInt64; - aData : PffByteArray; - const aLockType : TffSrLockType; {!!.10} - const aLockObtained : boolean; {!!.10} - const aConditional : boolean) : TffResult; virtual; {!!.10} - { Use this method to retrieve a record from the data file. - If a lock has already been obtained via TffSrTable.GetRecordLock - then set aLockObtained := True. Doing so skips an unnecessary - lock request. } - procedure GetRecordLock(aTI : PffTransInfo; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.10} - const aRefNr : TffInt64; {!!.10} - const aLockType : TffSrLockType); virtual; {!!.10} -{Begin !!.10} - procedure GetRecordNoLock(aTI : PffTransInfo; - aRefNr : TffInt64; - aData : PffByteArray); - { Retrieve a record without obtaining any type of lock. } -{End !!.10} - function HasClientLock(const aCursorID : TffCursorID) : boolean; virtual; - { Returns True if the specified cursor has a client lock (i.e., - TffTable.LockTable). } - function HasLock(const aCursorID : TffCursorID; - const aLockType : TffSrLockType) : boolean; virtual; - { Returns True if the specified cursor has an open lock of the specified - type on the table. } -{Begin !!.06} - function HasRecordLocks : Boolean; - { Returns True if there are any record locks on the table. } -{End !!.06} - function InsertRecord(aTI : PffTransInfo; - aCursorID : TffCursorID; - aData : PffByteArray; - aLockType : TffSrLockType; - var aNewRefNr : TffInt64) : TffResult; virtual; abstract; - function InsertRecordNoDefault(aTI : PffTransInfo; {!!.10} - aCursorID : TffCursorID; - aData : PffByteArray; - aLockType : TffSrLockType; - var aNewRefNr : TffInt64) : TffResult; virtual; abstract; - function IsContentLockedBy(aTrans : TffSrTransaction) : boolean; virtual; - { Returns True if the table's contents are locked by the specified - transaction. This returns True whether the lock is a read lock or - a write lock. } - function IsRecordLocked(aTI : PffTransInfo; - aCursorID : TffCursorID; - aRefNr : TffInt64; - aLockType : TffSrLockType) : Boolean; virtual; - function IsServerTable : boolean; virtual; - { Returns True if this table is a server table. } - procedure MakeKIDForCursor(aIndexID : integer; var aKID : TffKeyIndexData); virtual; abstract; - procedure OpenFiles(aTI : PffTransInfo; aForServer : boolean; - aAttribs : TffFileAttributes); virtual; - function PutRecord(aTI : PffTransInfo; - aCursorID : TffCursorID; - aRefNr : TffInt64; - aData : PffByteArray; - aRelLock : boolean; {!!.05} - var aKeyChanged : Boolean) : TffResult; virtual; abstract; {!!.05} - procedure RegisterOpenIntent; virtual; - { Use this method to register intent to open a table. } -{Begin !!.10} - procedure RelaxRecordLock(aTI : PffTransInfo; - aCursorID : TffCursorID; - aRefNr : TffInt64); virtual; -{End !!.10} - procedure RelClientLock(aCursorID : Longint; aRemoveAll : Boolean); virtual; - procedure RelContentLock(aTrans : TffSrTransaction); virtual; - procedure RelLock(const aCursorID : TffCursorID; - const aAllLocks : boolean); virtual; - procedure RelRecordLock(aTI : PffTransInfo; - aDatabaseID : TffDatabaseID; {!!.10} - aCursorID : TffCursorID; - aRefNr : TffInt64); virtual; - procedure RemoveLocksForCursor(const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; - const aRefNr : TffInt64; - aTI : PffTransInfo); virtual; - -{Begin !!.03} - procedure ListBLOBFreeSpace(aTI : PffTransInfo; - const aInMemory : Boolean; - aStream : TStream); -{End !!.03} - - procedure SetAttributes(const fileAttribs : TffFileAttributes); virtual; - { Sets the file attributes on all files of a table instance. This - should only be called when the table is first opened. } - - procedure SetExclOwner(const aCursorID : TffCursorID); virtual; - { Marks each file managed by a table as exclusively owned by the - specified cursor. Only call this method when the table has been - exclusively opened by the cursor. } - - property BaseName : TffTableName read btGetBaseName; - property ClientLocks : TffLockContainer read btClientLocks; {!!.11} - property CursorList : TffSrCursorList read btGetCursorList; - property Dictionary : TffServerDataDict read btGetDictionary; - property FileCount : Integer read btGetFileCount write btSetFileCount; - property Files [Inx : integer] : PffFileInfo read btGetFile write btSetFile; - property Folder : TffSrFolder read btGetFolder; - property OpenIntents : Longint read btGetOpenIntents; - { The number of threads that have registered their intent to open this - table. } - property TableID : Longint read KeyAsInt; -{Begin !!.03} -// property UseInternalRollback : boolean {Deleted !!.11} -// read btUseInternalRollback {Deleted !!.11} -// write btUseInternalRollback; {Deleted !!.11} - { This property is set to True when the server is attempting to - insert or modify a record. When set to True and the operation fails, - the server undoes any modifications made up to the point of failure. - For example, a record is inserted into a table having four indexes. - The record is stored in the data file and keys are added to two of - the indexes. However, a key violation occurs when adding a key to - the third index. The server removes the keys from the first two - indexes and removes the record from the data file. } -{End !!.03} - end; - - { Represents a table opened by one or more cursors. Only one - instance of this class is created and the instance is freed when all - cursors have closed the table. - - Table locks are acquired using the parent folder's lock manager. This - means that each client opening a table obtains some kind of lock on the - table. The following types of locks are used: - - ffsltExclusive - Used to obtain exclusive read-write access to a table. - ffsltShare - Used to obtain read-only access to a table. - ffsltIntentS - Used to obtain read-write access to a table. - - Since client A may open a table in read-only mode while clients B, C, & D - may open a table in non-exclusive read-write mode, we use the ffsltShare - & ffsltIntentS locks to represent non-exclusive read-write and read-only - modes. ffsltShare and ffsltIntentS are compatible locks so any number - of clients may concurrently access the table. - - If a client wants to open the table exclusively, their request for a - ffsltExclusive lock will wait until all non-exclusive read-write and - read-only clients have released their locks. - - Conversely, a client wanting to open the table in read-only or - non-exclusive read-write mode must wait until a client granted Exclusive - access to the table has released its lock. - - Notes on LockTable and UnlockTable: - Just as in the BDE, a client may lock a table for reading or writing. - Pertinent rules: - 1. Table locking is as described in the previous paragraphs. - 2. If a table is read-locked then no client may edit a record. - 3. If a table is write-locked then only the client obtaining the lock - may edit records. - } - TffSrTable = class(TffSrBaseTable) - protected -// stUseInternalRollback : boolean; {!!.03} - - stUserBuildKey : TffVCLList; - stUserCompareKey : TffVCLList; - - function stGetBuiltCompositeKey(aIndexID : integer; - aData : PffByteArray; - aKeyLen : Longint; - var aKey : PffByteArray) : TffResult; - function stBuildCompositeKey(aIndexID : integer; - aData : PffByteArray; - aKey : PffByteArray; - aFieldCount : integer; - aLastFldLen : integer) : TffResult; - function stDeleteKeyPrim(aInxFile : Integer; - aTI : PffTransInfo; - aRefNr : TffInt64; - aKey : PffByteArray; - aCompare : TffKeyCompareFunc; - aCmpData : PffCompareData; - var aBTreeChanged : Boolean) : Boolean; {!!.05} - function stDeleteKeysForRecord(aTI : PffTransInfo; - aRefNr : TffInt64; - aData : PffByteArray; - var aBTreeChanged : Boolean) {!!.05} - : TffResult; - function stGetUserBuildKey(aIndexID : Integer) : TffKeyBuildFunc; - function stGetUserCompareKey(aIndexID : Integer) : TffKeyCompareFunc; - function stInsertKeyPrim(aInxFile: integer; - aTI : PffTransInfo; - aRefNr : TffInt64; - aKey : PffByteArray; - aCompare: TffKeyCompareFunc; - aCmpData: PffCompareData) : boolean; - function stInsertKeysForRecord(aTI : PffTransInfo; - aRefNr : TffInt64; - aData : PffByteArray) : TffResult; - function stUpdateKeysForRecord(aCursorID : TffCursorID; - aTI : PffTransInfo; - aRefNr : TffInt64; - aData, - aOldData : PffByteArray; {!!.05} - var aKeyChanged : Boolean) : TffResult; {!!.05} - public - constructor Create(anEngine : TffServerEngine; - const aBaseName : TffTableName; - aFolder : TffSrFolder; - aBufMgr : TffBufferManager; - const aOpenMode : TffOpenMode); override; - destructor Destroy; override; - - procedure AddIndex(const aIndexDesc : TffIndexDescriptor; - aTI : PffTransInfo); override; - procedure BuildFiles(aTI : PffTransInfo; - aForServer : boolean; - aDictionary : TffDataDictionary; - aAttribs : TffFileAttributes; - aStore : TffBaseTempStorage); override; - function BuildKeyForRecord(aIndexID : integer; - aData : PffByteArray; - aKey : PffByteArray; - aFieldCount : integer; - aPartialLen : integer) : TffResult; override; - function CompareKeysForCursor(var aKID : TffKeyIndexData; - aKey1 : PffByteArray; - aKey2 : PffByteArray) : integer; override; - function DeleteRecord(aTI : PffTransInfo; - const aCursorID : TffCursorID; - const aRefNr : TffInt64; - const aLockObtained : Boolean; - var aBTreeChanged : Boolean) {!!.05} - : TffResult; override; - - procedure DropIndex(aTI : PffTransInfo; aIndexID : Longint); override; - function FindKey(var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aAction : TffSearchKeyAction) : boolean; override; - function GetNextKey(var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath) : TffResult; override; - function GetNextRecord(aTI : PffTransInfo; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.10} - var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aData : PffByteArray; - const aLockType : TffSrLockType) : TffResult; override; {!!.10} - function GetPriorRecord(aTI : PffTransInfo; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.10} - var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aData : PffByteArray; - const aLockType : TffSrLockType) : TffResult; override; {!!.10} - function InsertRecord(aTI : PffTransInfo; - aCursorID : TffCursorID; - aData : PffByteArray; - aLockType : TffSrLockType; - var aNewRefNr : TffInt64) : TffResult; override; - function InsertRecordNoDefault(aTI : PffTransInfo; {!!.10} - aCursorID : TffCursorID; - aData : PffByteArray; - aLockType : TffSrLockType; - var aNewRefNr : TffInt64) : TffResult; override; - procedure MakeKIDForCursor(aIndexID : integer; var aKID : TffKeyIndexData); override; - function PutRecord(aTI : PffTransInfo; - aCursorID : TffCursorID; - aRefNr : TffInt64; - aData : PffByteArray; - aRelLock : boolean; {!!.05} - var aKeyChanged : Boolean) : TffResult; override; {!!.05} - procedure RemoveDynamicLinks; - procedure ResolveDynamicLinks; - - property BaseName : TffTableName read btGetBaseName; - property CursorList : TffSrCursorList read btGetCursorList; - property Dictionary : TffServerDataDict read btGetDictionary; - property FileCount : integer read btGetFileCount write btSetFileCount; - property Files [Inx : integer] : PffFileInfo read btGetFile write btSetFile; - property Folder : TffSrFolder read btGetFolder; - property OpenIntents : Longint read btOpenIntents; - { The number of threads that have registered their intent to open this - table. } - property TableID : Longint read KeyAsInt; - -// property UseInternalRollback : boolean read stUseInternalRollback write stUseInternalRollback; {!!.03} - - end; - - { The following class may be used to access system tables (e.g., FFSALIAS, - FFSUSER, etc.). } - TffSrSystemTable = class(TffSrTable) - public - function IsServerTable : boolean; override; - end; - - TffSrTableList = class(TffObject) - protected {private} - tlList : TffThreadList; - FOwner : TffServerEngine; {!!.06} - protected - function GetTableItem(Find : TffListFindType; Value : Longint) : TffSrBaseTable; - public - constructor Create; - destructor Destroy; override; - procedure AddTable(aTable : TffSrBaseTable); - - function BeginRead : TffSrTableList; - {-A thread must call this method to gain read access to the list. - Returns the instance of this object as a convenience. } - - function BeginWrite : TffSrTableList; - {-A thread must call this method to gain write access to the list. - Returns the instance of this object as a convenience.} - - procedure DeleteTable(aTableID : Longint); - - 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 GetTableFromName(const aTableName : TffTableName) : TffSrBaseTable; - procedure RemoveIfUnused(aTable : TffSrBaseTable); - procedure RemoveUnusedTables; - function TableCount : integer; - - property Owner : TffServerEngine {!!.06} - read FOwner write FOwner; {!!.06} - property Table[Find : TffListFindType; Value : Longint] : TffSrBaseTable - read GetTableItem; default; - end; - - { An instance of this class mirrors an instance of TffDatabase in the client - application. If multiple clients open the same database, there will be - one instance of TffSrDatabase per client. - - A TffSrDatabase may have one active transaction however there may be - multiple concurrent transactions on a physical database. } - TffSrDatabase = class(TffServerObject) - protected {private} - dbAlias : PffShStr; - dbCheckSpace : Boolean; {!!.11} - dbCursorList : TffSrCursorList; - dbEngine : TffServerEngine; - dbExtenders : TffThreadList; - dbFolder : TffSrFolder; - dbOpenMode : TffOpenMode; - dbSession : TffSrSession; - dbShareMode : TffShareMode; - dbStmtList : TffSrStmtList; {!!.10} - dbTI : PffTransInfo; - {-Transaction-specific information used for locking. } - dbTrans : TffSrTransaction; - {-The active transaction for this database. } - protected - procedure dbAddExtender(anExtender : TffBaseEngineExtender); - function dbGetAlias : TffName; - function dbGetDatabaseID : TffDatabaseID; - function dbGetTransID : TffTransID; - {-Returns the ID of the transaction associated with the cursor. } - - function dbGetTransLSN : TffWord32; - {-Returns the LSN of the cursor's transaction. } - -{Begin !!.11} - procedure dbSetExistingTableVersion(const Version : Longint); - { *** WARNING: This procedure is provided for testing & utility - purposes only. Do not use it unless you really know what you're - doing. That means you! ***} - procedure dbSetNewTableVersion(const Version : Longint); - { *** WARNING: This procedure is provided for testing & utility - purposes only. Do not use it unless you really know what you're - doing. That means you! ***} - procedure dbSetPackSrcTableVersion(const Version : Longint); - { *** WARNING: This procedure is provided for testing & utility - purposes only. Do not use it unless you really know what you're - doing. That means you! ***} -{End !!.11} - - procedure dbSetTrans(aTransaction : TffSrTransaction); virtual; - - public - constructor Create(anEngine : TffServerEngine; - aSession : TffSrSession; - aFolder : TffSrFolder; - anAlias : TffName; - aOpenMode : TffOpenMode; - aShareMode : TffShareMode; - aTimeout : Longint; - aCheckSpace : Boolean); {!!.11} - destructor Destroy; override; - - function CanClose(const Mark : boolean) : boolean; override; - - procedure ForceClose; override; - - function NotifyExtenders(const anAction : TffEngineAction; - const aFailAction : TffEngineAction) : TffResult; - {-Notifies all extenders associated with the cursor about the - specified action. If ignoreErrCode is True then error codes - returned by extenders are ignored. If failures occur it will - be taken care of before going back to the calling method.} - - procedure RequestClose; override; {!!.03} - - function ShouldClose : boolean; override; - - property Alias : TffName read dbGetAlias; - {-The alias for which this database was opened. } - property CheckSpace : Boolean {!!.11} - read dbCheckSpace; {!!.11} - property CursorList : TffSrCursorList read dbCursorList; - property DatabaseID : TffDatabaseID read dbGetDatabaseID; - property Engine : TffServerEngine read dbEngine; - property Folder : TffSrFolder read dbFolder; - property OpenMode : TffOpenMode read dbOpenMode; - property Session : TffSrSession read dbSession; - property ShareMode : TffShareMode read dbShareMode; - property StmtList : TffSrStmtList read dbStmtList; {!!.10} - property Transaction : TffSrTransaction read dbTrans write dbSetTrans; - { The transaction associated with the cursor. } - property TransactionID : TffTransID read dbGetTransID; - { The transaction active for this cursor. If no transaction is - active then returns zero. } - property TransactionInfo : PffTransInfo read dbTI; - { Returns a pointer to the cursor's transaction information. } - property TransactionLSN : TffWord32 read dbGetTransLSN; - { Returns the LSN of the transaction associated with the cursor. } -// property ServerEngine : TffServerEngine read dbEngine; {Deleted !!.03} - end; - - TffSrDatabaseList = class(TffServerObjectList) - protected {private} - protected - function GetDatabaseItem(Find : TffListFindType; Value : Longint) : TffSrDatabase; - public - procedure AddDatabase(aDatabase : TffSrDatabase); - - function DatabaseCount : integer; - procedure DeleteDatabase(aDatabaseID : Longint); - - function GetDatabaseForFolder(aFolder : TffSrFolder) : TffSrDatabase; - - property Database [Find : TffListFindType; Value : Longint] : TffSrDatabase read GetDatabaseItem; default; - end; - - TffSrSession = class(TffServerObject) - protected {private} - ssDatabaseList : TffSrDatabaseList; - ssIsDefault : boolean; - protected - function ssGetSessionID : TffSessionID; - public - constructor Create(aClient : TffSrClient; const aIsDef : boolean; - const aTimeout : Longint); - destructor Destroy; override; - - function CanClose(const Mark : boolean) : boolean; override; - - procedure ForceClose; override; - - procedure RequestClose; override; {!!.03} - - function ShouldClose : boolean; override; - - property DatabaseList : TffSrDatabaseList read ssDatabaseList; - property IsDefault : boolean read ssIsDefault; - property SessionID : TffSessionID read ssGetSessionID; - end; - - TffSrSessionList = class(TffServerObjectList) - protected {private} - slDefSess : TffSrSession; - slCurSess : TffSrSession; - protected - function slGetCurSess : TffSrSession; - function slGetSessionItem(Find : TffListFindType; Value : Longint) : TffSrSession; - procedure slSetCurSess(CS : TffSrSession); - public - procedure AddSession(aSession : TffSrSession); - - procedure DeleteSession(aSessionID : Longint); - - function SessionCount : integer; - procedure SetDefaultSession(aSession : TffSrSession); - property CurrentSession : TffSrSession read slGetCurSess write slSetCurSess; - property Session [Find : TffListFindType; Value : Longint] : TffSrSession read slGetSessionItem; - end; - -{Begin !!.10} - TffBasePreparedStmt = class(TffServerObject) - protected - bpsClientID : TffClientID; - bpsDatabaseID: TffDatabaseID; - bpsEngine : TffServerEngine; - public - procedure Bind; virtual; abstract; {!!.11} - function Execute(var aLiveResult: Boolean; - var aCursorID: TffCursorID; - var aRowsAffected: Integer; - var aRecordsRead: Integer): TffResult; virtual; abstract; - - function Parse(aQuery: PChar): Boolean; virtual; abstract; - - property ClientID : TffClientID - read bpsClientID; - { ID of owning client. } - - property DatabaseID : TffDatabaseID - read bpsDatabaseID; - { ID of owning database. } - - property Engine : TffServerEngine - read bpsEngine; - - property Handle: LongInt - read KeyAsInt; - { Statement handle. } - end; - - TffSrStmtList = class(TffServerObjectList) - protected - function GetStmt(Find : TffListFindType; Value : Longint) : TffBasePreparedStmt; - public - procedure AddStmt(aStmt : TffBasePreparedStmt); - - procedure DeleteStmt(aStmtID : TffSQLStmtID); - - procedure RemoveForClient(const aClientID : TffClientID); - {-Removes all prepared statements associated with a particular client. } - - function StmtCount : integer; - - property Stmt [Find : TffListFindType; Value : Longint] : TffBasePreparedStmt - read GetStmt; default; - end; -{End !!.10} - - TffSrClient = class(TffServerObject) - protected {private} - clAccepted : boolean; - clClientName : PffShStr; - clEngine : TffServerEngine; - clExtenders : TffThreadList; - clSessionList : TffSrSessionList; - clUserID : TffName; - clFirst : TffName; - clLast : TffName; - clRights : TffUserRights; - clFirstSession: TffSrSession; {!!.03} - clClientVersion : Longint; {!!.11} - protected - function clGetClientID : TffClientID; - function clGetClientName : TffNetName; - public - constructor Create(aClientID : Longint; - const aClientName : TffNetName; - const aTimeout : Longint; - const aClientVersion : Longint; {!!.11} - aUser : TffUserItem; - anEngine : TffServerEngine); - destructor Destroy; override; - - procedure AddClientExtender(anExtender : TffBaseEngineExtender); - {-Use this method to add an extender to the list of extenders - interested in clients. } - - function CanClose(const Mark : boolean) : boolean; override; - - procedure ForceClose; override; - - function NotifyExtenders(const anAction : TffEngineAction; - const aFailAction : TffEngineAction) : TffResult; - {-Use this method to notify client extenders about a client-related - action. } - - procedure RequestClose; override; {!!.03} - - function ShouldClose : boolean; override; - - property Accepted : boolean read clAccepted write clAccepted; - { Returns True if the client was accepted by the client extender(s). } - property ClientID : TffClientID read clGetClientID; - property ClientVersion : Longint read clClientVersion; {!!.11} - property ClientName : TffNetName read clGetClientName; - property Rights : TffUserRights read clRights; - property SessionList : TffSrSessionList read clSessionList; - end; - - TffSrClientList = class(TffServerObjectList) - protected {private} - protected - function GetClientItem(Find : TffListFindType; Value : Longint) : TffSrClient; - procedure SetClientItem(Inx : integer; CI : TffSrClient); - public - procedure AddClient(aClient : TffSrClient); - - function ClientCount : integer; - procedure DeleteClient(aClientID : Longint); - - property Client [Find : TffListFindType; Value : Longint] : TffSrClient read GetClientItem; - end; - - PffSrRebuildParams = ^TffSrRebuildParams; - TffSrRebuildParams = record - rpDB : TffSrDatabase; - rpTableName : TffTableName; - rpIndexName : TffName; - rpIndexID : Longint; - rpRebuildStatus : TffSrRebuildStatus; - rpCursor : TffSrCursor; - rpTargetCursor : TffSrCursor; - rpFieldMap : TffSrFieldMapList; - end; - - TffServerEngine = class(TffIntermediateServerEngine) - private - protected {public} - seCursorClass : TffSrCursorClass; {!!.06} - seBufMgr : TffBufferManager; - seCanLog : Boolean; { If True then can write to event log. } - seClientHash : TffHash; {!!.02} - seConfig : TffServerConfiguration; - seConfigLoaded : Boolean; { True if config tables have been loaded. } - seGarbageThread : TffTimerThread; - seLastFlush : DWORD; {!!.01} - seRebuildList : TffSrRebuildStatusList; - seStartTime : DWORD; {!!.10} - seUniqueID : TGUID; {!!.10} - - seClientList : TffSrClientList; - seConfigDir : TffPath; - { The location of the server tables for this server engine. - IMPORTANT NOTE: When retrieving this value, use the ConfigDir property - or the seGetConfigDir method directly as this method determines the - correct config dir for the server if the config dir has not been - specified (i.e., is set to ''). } - seCursorList : TffSrCursorList; - seDatabaseList : TffSrDatabaseList; - seFolderList : TffSrFolderList; - seOnRecoveryCheck : TNotifyEvent; - { Handler called when it is time to check for recovery. } - seScriptFile : TffFullFileName; - seSessionList : TffSrSessionList; - seSQLEngine : TffBaseSQLEngine; - seTableList : TffSrTableList; - - seEvtClientDone : TffEvent; - {This event is used to notify a server when a client is done - processing during server shutdown. This event is nill except - when shutting down.} - - function seTransactionStart(const aDB : TffSrDatabase; - const aFailSafe, aImplicit : boolean; - var aTransactionID : TffTransID) : TffResult; - {-starts a transaction based on aImplicit setting} - - function seTransactionCommitSubset(const aDB : TffSrDatabase) : TffResult; -{Begin !!.11} - function seClientAddPrim(var aClientID : TffClientID; - const aClientName : TffNetName; - const aUserID : TffName; - const aTimeout : Longint; - const aClientVersion : Longint; - var aHash : TffWord32) : TffResult; -{End !!.11} - procedure seClientRemovePrim(const aClient : TffSrClient); - function seConvertSingleField(aSourceBuf, - aTargetBuf: PffByteArray; - aSourceCursorID, - aTargetCursorID: Longint; - aSourceFldNr, - aTargetFldNr: Integer; - aBLOBBuffer: Pointer; - aBLOBBufLen: Longint): TffResult; - function seDatabaseAliasListPrim(aList : TList) : TffResult; - function seDatabaseDeleteAliasPrim(aAlias : TffName) : TffResult; - function seDatabaseGetAliasPathPrim(aAlias : TffName; - var aPath : TffPath) : TffResult; - function seDeleteTable(const aDB : TffSrDatabase; - const aTableName : TffTableName) : TffResult; - function seGetConfig : TffServerConfiguration; - function seGetDictionary(const aDB : TffSrDatabase; - const aTableName : TffTableName; - var aDict : TffDataDictionary) : TffResult; - function seIsServerTable(const aTableName : TffTableName) : Boolean; - function seGetCollectFrequency : Longint; - function seGetCollectGarbage : Boolean; - function seGetConfigDir : string; {!!.10} - function seGetMaxRAM : Longint; {!!.01} - function seGetScriptFile : string; {!!.11} - procedure seSetCollectFrequency(aFreq : Longint); - procedure seSetCollectGarbage(aValue : Boolean); - procedure seSetConfigDir(const aPath : string); {!!.10} - procedure seSetMaxRAM(const aValue: Longint); {!!.01} - procedure seSetScriptFile(const aFile : string); {!!.11} - function seTableBuildPrim(aDB : TffSrDatabase; - aOverwrite : Boolean; - const aTableName : TffTableName; - aForServer : Boolean; - aDict : TffDataDictionary) : TffResult; - function seTableDeletePrim(DB : TffSrDatabase; - const aTableName : TffTableName) : TffResult; - function seTableExistsPrim(aDB : TffSrDatabase; {!!.11} - const aTableName: TffTableName) : Boolean; {!!.11} - function seTablePackPrim(aRebuildParamsPtr: PffSrRebuildParams): TffResult; - function seTableRebuildIndexPrim(aRebuildParamsPtr: PffSrRebuildParams): TffResult; - function seTableGetRecordCountPrim(aRebuildParamsPtr : PffSrRebuildParams) : TffResult; { !!.10} - function seTransactionCommit(aDB : TffSrDatabase) : TffResult; - function seTransactionRollback(aDB : TffSrDatabase) : TffResult; - protected - {validation and checking} - - { The Check*IDAndGet routines are responsible for checking the - engine state to make sure it is ffesStarted. The - seCheck*IDAndGet avoid checking the engine state. - WARNING: Ensure changes are made to Check*IDAndGet and - seCheck*IDAndGet } -// function CheckClientIDAndGet(aClientID : TffClientID; {!!.01 - Start} -// var aClient : TffSrClient) {Moved to Public section} -// : TffResult; {!!.01 - End} - function seCheckClientIDAndGet(aClientID : TffClientID; - var aClient : TffSrClient) : TffResult; -// function CheckSessionIDAndGet(aClientID : TffClientID; {!!.01 - Start} -// aSessionID : TffSessionID; {Moved to Public section} -// var aClient : TffSrClient; {!!.01 - End} -// var aSession : TffSrSession) : TffResult; - function seCheckSessionIDAndGet(aSessionID : TffSessionID; - var aSession : TffSrSession) : TffResult; -// function CheckTransactionIDAndGet(aTransactionID : TffTransID; {!!.01 - Start} -// var aTrans : TffSrTransaction) {Moved to Public section} -// : TffResult; {!!.01 - End} - function seCheckCursorIDAndGet(aCursorID : TffCursorID; - var aCursor : TffSrBaseCursor) : TffResult; - {-Find the cursor specified by aCursorID. } - - function seCheckDatabaseIDAndGet(aDatabaseID : TffDatabaseID; - var aDatabase : TffSrDatabase) : TffResult; - function GetTableInstance(aFolder : TffSrFolder; - const aTableName : TffTableName) : TffSrBaseTable; - function IsTableNameOpen(aFolder : TffSrFolder; - const aTableName : TffTableName) : boolean; - - {rebuild status related stuff} - function RebuildRegister(aClientID : TffClientID; - aTotalRecords : Longint) : TffSrRebuildStatus; - procedure RebuildDeregister(aRebuildID : Longint); - - function seBLOBCopy(aSrc, aTgt : TffSrBaseCursor; - aSourceBLOBNr, aTargetBLOBNr : TffInt64; - aBuffer : pointer; - aBufLen : Longint): TffResult; - function seDatabaseAddAliasPrim(const aAlias : TffName; - const aPath : TffPath; - aCheckSpace : Boolean) {!!.11} - : TffResult; - function seDatabaseOpenPrim(Session : TffSrSession; - Folder : TffSrFolder; - anAlias : TffName; - aOpenMode : TffOpenMode; - aShareMode : TffShareMode; - aTimeout : Longint; - aCheckSpace : Boolean) {!!.11} - : TffSrDatabase; - {-Used by the public DatabaseOpenxx methods and used to open system - tables. } - - function seTableRenamePrim(DB : TffSrDatabase; - const aOldName, aNewName : TffName) : TffResult; - - function RecordGetNextSeq(aCursorID : TffCursorID; var aRefNr : TffInt64; aData : PffByteArray) : TffResult; - - {index stuff} - function IndexClear(aCursorID : TffCursorID) : TffResult; - - {misc stuff} - procedure CreateAdminUser(SaveToDisk : Boolean); - {-create the default administrator user} - procedure ReadAliasData; - {-read the aliases from the FFSALIAS.FFD table} - procedure ReadGeneralInfo; - {-read the general info from the FFSINFO.FFD table} - procedure ReadKeyProcData; - {-read the user-defined index data from the FFSINDEX.FFD table} - procedure ReadUserData; - {-read the user data from the FFSUSER.FFD table} - - protected - - {State methods} - procedure scInitialize; override; - procedure scPrepareForShutdown; override; - procedure scShutdown; override; - procedure scStartup; override; - - { Property methods } - function bseGetAutoSaveCfg : Boolean; override; - function bseGetReadOnly : Boolean; override; - procedure bseSetAutoSaveCfg(aValue : Boolean); override; {!!.01} - procedure bseSetReadOnly(aValue : Boolean); override; {!!.01} - procedure lcSetEventLog(anEventLog : TffBaseLog); override; - procedure lcSetLogEnabled(const aEnabled : boolean); override; - - { Misc } - - procedure seCleanRebuildList(const aClientID : TffClientID); virtual; - {-Remove all entries in the rebuild status list for the specified - client. } - - procedure seCollectGarbage(const aTimerEventCookie : Longint); virtual; - {-Looks for clients, sessions, databases, cursors, tables, & - folders that should be closed & freed. } - - procedure seLoadConfig; - {-Reads in the server configuration tables and processes the - server script file (if present). } - - procedure seForce(const aMsg : string; {!!.06 - Start} - args : array of const; - ReadOnly : Boolean); virtual; {!!.06 - End} - {-Use this method to log a formatted string to the event log. Writes to - the log whether or not logging is enabled. } - - function seGetServerName : TffNetName; - {-Returns the server's name from its configuration. } - - procedure seSetLoggingState; - {-Called whenever something is changed that would affect logging. - Sets a boolean flag that tells the logging routines whether or not - they can log. We centralize the logic here so that the logging - routines don't have to do the checks each time they are called. } - - procedure seSetSQLEngine(anEngine : TffBaseSQLEngine); - {-Used to set the SQLEngine property of the server engine. } - - {script stuff} - function CalcPriorityIndex(const PriorityStr : TffShStr) : integer; - function CalcKeyIndex(const KeyStr : TffShStr) : integer; - function ValBoolean(const BoolStr : TffShStr; - var BoolValue : boolean) : boolean; - procedure ProcessAliasScript; - {process the FFALIAS.SC$ script file to autocreate aliases} - procedure ProcessFullScript(const ScriptFileName : TffFullFileName); - {process a server script file to set general info & aliases} - procedure ProcessScriptCommand(const KeyStr, ValueStr : TffShStr; - var DeleteScript : Boolean); - - public - {creation/destruction} - 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 seSQLEngine is detected, this method - sets seSQLEngine to nil to avoid using the freed TffBaseSQLEngine. } - - { 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. } - - { Object validation } - function CheckCursorIDAndGet(aCursorID : TffCursorID; - var aCursor : TffSrBaseCursor) - : TffResult; - {-Find the cursor specified by aCursorID. } - function CheckDatabaseIDAndGet(aDatabaseID : TffDatabaseID; - var aDatabase : TffSrDatabase) - : TffResult; - {-Find the database specified by aDatabaseID. } - function CheckClientIDAndGet(aClientID : TffClientID; {!!.01 - Start} - var aClient : TffSrClient) {Moved from Public section} - : TffResult; - function CheckSessionIDAndGet(aClientID : TffClientID; {Moved from Public section} - aSessionID : TffSessionID; - var aClient : TffSrClient; - var aSession : TffSrSession) - : TffResult; - function CheckTransactionIDAndGet(aTransactionID : TffTransID; {Moved from Public section} - var aTrans : TffSrTransaction) - : TffResult; {!!.01 - End} - - procedure GetServerNames(aList : TStrings; - aTimeout : Longint); override; - - {transaction tracking} - function TransactionCommit(const aDatabaseID : TffDatabaseID) : TffResult; override; -{Begin !!.01} - function TransactionCommitSQL(const aDatabaseID : TffDatabaseID; - const notifyExtenders : Boolean) : TffResult; - { Commit transaction for SQL engine. Does not reset timeout and controls - extender notification. } -{End !!.01} - function TransactionCommitSubset(const aDatabaseID : TffDatabaseID) : TffResult; - function TransactionRollback(const aDatabaseID : TffDatabaseID) : TffResult; override; -{Begin !!.01} - function TransactionRollbackSQL(const aDatabaseID : TffDatabaseID; - const notifyExtenders : Boolean) : TffResult; - { Rollback transaction for SQL engine. Does not reset timeout and - controls extender notification. } -{End !!.01} - function TransactionStart(const aDatabaseID : TffDatabaseID; - const aFailSafe : boolean) : TffResult; override; - {-starts an explicit transaction} -{Begin !!.01} - function TransactionStartSQL(const aDatabaseID : TffDatabaseID; - const notifyExtenders : boolean) : TffResult; - { For use by the SQL engine. Starts a transaction without resetting - the timeout & controls notification of extenders. } -{End !!.01} - -{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 timeout : Longint; - var aSessionID : TffSessionID) : TffResult; override; - function SessionCloseInactiveTables(aClientID : TffClientID) : TffResult; override; {!!.06} - function SessionCount(aClientID : TffClientID; var aCount : integer) : TffResult; override; - function SessionGetCurrent(aClientID : TffClientID; var aSessionID : TffSessionID) : TffResult; override; - function SessionRemove(aClientID : TffClientID; aSessionID : TffSessionID) : TffResult; override; - function SessionSetCurrent(aClientID : TffClientID; aSessionID : TffSessionID) : TffResult; override; - function SessionSetTimeout(const aClientID : TffClientID; - const aSessionID : TffSessionID; - const aTimeout : Longint) : 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; - {-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; 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; {!!.10} - var aTaskID : Longint) : TffResult; override; {!!.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; 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, 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 : Integer) : TffResult; override; - 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 : integer; - aPartialLen1 : integer; - aKeyData1 : PffByteArray; - aKeyIncl1 : boolean; - aFieldCount2 : integer; - aPartialLen2 : integer; - 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 : integer; - aPartialLen : integer; - aKeyData : PffByteArray) : TffResult; override; - function CursorSwitchToIndex(aCursorID : TffCursorID; - aIndexName : TffDictItemName; - aIndexID : integer; - aPosnOnRec : boolean) : TffResult; override; - function CursorSetFilter(aCursorID : TffCursorID; - aExpression : pCANExpr; - aTimeout : TffWord32) : TffResult; override; - -{Begin !!.03} - function CursorListBLOBFreeSpace(aCursorID : TffCursorID; - const aInMemory : Boolean; - aStream : TStream) : TffResult; override; -{End !!.03} - - {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 : integer; - aPartialLen : integer; - 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 : integer; - aStream : TStream) : TffResult; override; - - {misc stuff} - function GetServerDateTime(var aDateTime : TDateTime) : TffResult; override; - {begin !!.10} - function GetServerSystemTime(var aSystemTime : TSystemTime) - : TffResult; override; - function GetServerGUID(var aGUID : TGUID) - : TffResult; override; - function GetServerID(var aUniqueID : TGUID) - : TffResult; override; - function GetServerStatistics(var aStats : TffServerStatistics) - : TffResult; override; - function GetCommandHandlerStatistics(const aCmdHandlerIdx : Integer; - var aStats : TffCommandHandlerStatistics) - : TffResult; override; - function GetTransportStatistics(const aCmdHandlerIdx : Integer; - const aTransportIdx : Integer; - var aStats : TffTransportStatistics) - : TffResult; override; - {end !!.10} - - - function WriteAliasData : TffResult; - {-write the aliases to the FFSALIAS.FFD table} - function WriteGeneralInfo(aOverrideRO : Boolean) : TffResult; - {-write the general info to the FFSINFO.FFD table} - function WriteKeyProcData : TffResult; - {-write the user-defined index data to the FFSINDEX.FFD table} - function WriteUserData : TffResult; - {-write the user data to the FFSUSER.FFD table} - - {properties} - property BufferManager : TffBufferManager read seBufMgr; - property ClientList : TffSrClientList read seClientList; - property Configuration : TffServerConfiguration - read seGetConfig; - property CursorList : TffSrCursorList read seCursorList; - property DatabaseList : TffSrDatabaseList read seDatabaseList; - property FolderList : TffSrFolderList read seFolderList; - property ServerName : TffNetName read seGetServerName; - property SessionList : TffSrSessionList read seSessionList; - property TableList : TffSrTableList read seTableList; - property CursorClass : TffSrCursorClass {!!.06} - read seCursorClass - write seCursorClass; - - published - - property CollectGarbage : Boolean - read seGetCollectGarbage - write seSetCollectGarbage - default False; {!!.01} - { If True then the server engine is to perform garbage collection. } - - property CollectFrequency : Longint - read seGetCollectFrequency - write seSetCollectFrequency - default ffcl_CollectionFrequency; {!!.01} - { The number of milliseconds between each garbage collection run by the - server engine. } - - property ConfigDir : string {!!.10} - read seGetConfigDir - write seSetConfigDir; - - property MaxRAM : Longint {!!.01} - read seGetMaxRAM {!!.01} - write seSetMaxRAM - default 10; {!!.01} - - property OnRecoveryCheck : TNotifyEvent - read seOnRecoveryCheck - write seOnRecoveryCheck; - { Called when the server engine is initializing and it is time to - check for recovery of fail-safe transactions. } - - property ScriptFile : string {!!.11} - read seGetScriptFile - write seSetScriptFile; - - property SQLEngine : TffBaseSQLEngine - read seSQLEngine - write seSetSQLEngine; - - end; - -var - ffc_AdminUserID : string[5]; - -implementation - -uses - TypInfo, - ActiveX, - ffllcomp, - ffllcomm, - ffsrjour, {!!.06} -// ffsqleng, {Deleted !!.03} - ffsrsort; - -const - ffc_NumBLOBBytesToCopy = ffcl_1MB; - { When copying BLOBs from one cursor to another, this is the initial number - of bytes to read from the source BLOB. } - ffcl_FlushRate = 5 * 60 * 1000; {!!.01} - { Flush memory pools and other pools every 5 minutes. } {!!.01} - -resourceString - ffcTable = 'table %s'; - ffcTableContent = 'content of table ''%s'''; - -{===Utility functions================================================} -function FFMapLock(const aClientLock : TffLockType; - const isTableLock : boolean) : TffSrLockType; - {-Map a client lock type to a server lock type. } -begin - Result := ffsltNone; - if isTableLock then - case aClientLock of - ffltNoLock : Result := ffsltShare; - ffltReadLock : Result := ffsltIntentS; - ffltWriteLock : Result := ffsltExclusive; - end { case } - else - if aClientLock = ffltWriteLock then - Result := ffsltExclusive - else - Result := ffsltNone; -end; - -{====================================================================} - - -type - { Base thread class for rebuild operations } - TffSrRebuildBaseThread = class(TffThread) - protected { private } - protected - rthServerEngine: TffServerEngine; - rthParams: PffSrRebuildParams; {!!.13} - public - constructor Create(aServerEngine : TffServerEngine; - aRebuildParamsPtr : PffSrRebuildParams); - destructor Destroy; override; - end; - - { Thread class for table reindexing operation } - TffSrReindexThread = class(TffSrRebuildBaseThread) - protected - procedure Execute; override; - end; - - { Thread class for table packing operation } - TffSrPackThread = class(TffSrRebuildBaseThread) - protected - procedure Execute; override; - end; - - { Thread class for table restructure operation } - TffSrRestructureThread = class(TffSrRebuildBaseThread) - protected - procedure Execute; override; - end; - -{Begin !!.10} - { Thread class for asynchronous record count } - TffSrGetRecordCountThread = class(TffSrRebuildBaseThread) - protected - procedure Execute; override; - end; -{End !!.10} - -{===TffSrReindexThread====================================================} -constructor TffSrRebuildBaseThread.Create( - aServerEngine : TffServerEngine; - aRebuildParamsPtr : PffSrRebuildParams); -begin - rthServerEngine := aServerEngine; - rthParams := aRebuildParamsPtr; -// Dispose(aRebuildParamsPtr); {Deleted !!.13} - - inherited Create(False); - FreeOnTerminate := True; -end; - -destructor TffSrRebuildBaseThread.Destroy; -begin -{Begin !!.13} - if Assigned(rthParams.rpFieldMap) then - rthParams.rpFieldMap.Free; - FFFreeMem(rthParams, SizeOf(rthParams^)); -{End !!.13} - inherited Destroy; -end; -{--------} -procedure TffSrReindexThread.Execute; -begin - rthServerEngine.seTableRebuildIndexPrim(rthParams); {!!.13} -end; -{--------} -procedure TffSrPackThread.Execute; -begin - rthServerEngine.seTablePackPrim(rthParams); {!!.13} -end; -{--------} -procedure TffSrRestructureThread.Execute; -begin - { Because we are passing a field map within the rebuild parameters, - TablePackPrim knows that we are doing a restructure. } - rthServerEngine.seTablePackPrim(rthParams); {!!.13} -end; -{Begin !!.10} -{--------} -procedure TffSrGetRecordCountThread.Execute; -begin - rthServerEngine.seTableGetRecordCountPrim(rthParams); {!!.13} -end; -{End !!.10} -{====================================================================} - -{===TffServerObject==================================================} -constructor TffServerObject.Create(const aTimeout : Longint); -begin - inherited Create; - soState := ffosInactive; - soTimeout := aTimeout; -end; -{--------} -destructor TffServerObject.Destroy; -begin - inherited Destroy; -end; -{--------} -function TffServerObject.Activate : boolean; -begin - if soState in [ffosInactive, ffosActive] then begin - if soClient = nil then - soLock.Lock - else - soClient.soLock.Lock; - soState := ffosActive; - Result := True; - end - else - Result := False; -end; -{--------} -function TffServerObject.CanClose(const Mark : boolean) : boolean; -begin - Result := (soState = ffosInactive) or (soState = ffosClosing); - { Note: If the state is ffosClosePending then the object is active & - will be freed once it has completed. Until then we have to - leave it alone. } - if (soState = ffosInactive) and Mark then - soState := ffosClosing; -end; -{--------} -procedure TffServerObject.Deactivate; -begin - case soState of - ffosActive : - soState := ffosInactive; - ffosClosePending : - begin - soState := ffosClosing; - if Self.CanClose(True) then - Self.Free; - end; - end; { case } - if soClient = nil then - soLock.Unlock - else - soClient.soLock.Unlock; -end; -{--------} -procedure TffServerObject.ForceClose; -begin - soState := ffosClosing; -end; -{--------} -procedure TffServerObject.RequestClose; -begin - if soState = ffosActive then - soState := ffosClosePending - else if soState = ffosInactive then - soState := ffosClosing; -end; -{--------} -function TffServerObject.ShouldClose : boolean; -begin - Result := (soState = ffosClosing); -end; -{====================================================================} - -{===TffServerObjectList==============================================} -constructor TffServerObjectList.Create; -begin - inherited Create; - solList := TffThreadList.Create; -end; -{--------} -destructor TffServerObjectList.Destroy; -begin - solList.Free; - inherited Destroy; -end; -{--------} -procedure TffServerObjectList.BeginRead; -begin - solList.BeginRead; -end; -{--------} -procedure TffServerObjectList.BeginWrite; -begin - solList.BeginWrite; -end; -{--------} -function TffServerObjectList.CanClose(const Mark : boolean) : boolean; -var - Inx : Longint; -begin - Result := True; - for Inx := 0 to pred(solList.Count) do begin - { If any one of the objects cannot be closed then return False. - Note we have the option to tell each Inactive object to mark itself - as closed. This makes sure the object is unavailable until we actually - free it. Note that we must call CanClose on each object. If we break - out of this loop early, an object that should be closed may never - be marked as closable. } - if (not TffServerObject(solList[Inx]).CanClose(Mark)) then - Result := False; - end; -end; -{--------} -procedure TffServerObjectList.EndRead; -begin - solList.EndRead; -end; -{--------} -procedure TffServerObjectList.EndWrite; -begin - solList.EndWrite; -end; -{--------} -procedure TffServerObjectList.ForceClose; -var - Inx : Longint; -begin - for Inx := 0 to pred(solList.Count) do - TffServerObject(solList[Inx]).ForceClose; -end; -{Begin !!.06} -{--------} -function TffServerObjectList.HasClosableState(const Mark : Boolean) : boolean; -var - Inx : Longint; -begin - Result := True; - for Inx := 0 to pred(solList.Count) do begin - { If any one of the objects cannot be closed then return False. } - if not (TffServerObject(solList[Inx]).State in - [ffosInactive, ffosClosing]) then begin - Result := False; - Break; - end; - end; - - { If all objects are in a closable state and we are to mark them as being - closed then do so. } - if Result and Mark then - for Inx := 0 to pred(solList.Count) do - if TffServerObject(solList[Inx]).State = ffosInactive then - TffServerObject(solList[Inx]).State := ffosClosing; - -end; -{End !!.06} -{--------} -procedure TffServerObjectList.RemoveUnused; -var - Index : Longint; -begin - solList.BeginWrite; - try - for Index := pred(solList.Count) downto 0 do -{Begin !!.05} - try - if TffServerObject(solList[Index]).ShouldClose then - solList.DeleteAt(Index); - except - { If an exception occurred then it is most likely because the object - has already been deleted. Remove the invalid object from the list. } - solList.RemoveAt(Index); - end; -{End !!.05} - finally - solList.EndWrite; - end; -end; -{Begin !!.03} -{--------} -procedure TffServerObjectList.RequestClose; -var - Inx : Longint; -begin - for Inx := 0 to pred(solList.Count) do - TffServerObject(solList[Inx]).RequestClose; -end; -{End !!.03} -{--------} -function TffServerObjectList.ShouldClose : boolean; -var - Inx : Longint; -begin - Result := True; - for Inx := 0 to pred(solList.Count) do begin - { If any one of the objects cannot be closed then return False. } - if (not TffServerObject(solList[Inx]).ShouldClose) then begin - Result := False; - break; - end; - end; -end; -{====================================================================} - -{===TffSrBaseCursor==================================================} -constructor TffSrBaseCursor.Create(anEngine : TffServerEngine; - aDatabase : TffSrDatabase; - const aTimeout : Longint); -begin - inherited Create(aTimeout); - soClient := aDatabase.Client; - bcCloseTable := False; - bcCloseWTrans := False; {!!.05} - bcDatabase := aDatabase; - bcEngine := anEngine; - bcExclOwner := False; - bcExtenders := nil; - bcInfoLock := TffPadlock.Create; {!!.06} - bcTable := nil; - bcTempStore := nil; - bcNumReadLocks := 0; {!!.05} -end; -{Begin !!.01} -{--------} -function TffSrBaseCursor.CanClose(const Mark : Boolean) : Boolean; -begin - { Cursor can be closed if it is not in a transaction or if the table is - temporary. } - Result := (bcDatabase.Transaction = nil) or - (fffaTemporary in bcTable.Files[0].fiAttributes); - if Result then - Result := inherited CanClose(Mark) {!!.05 - Start} - else if (bcDatabase.Transaction <> nil) then - bcCloseWTrans := True; {!!.05 - End} -end; -{End !!.01} -{--------} -procedure TffSrBaseCursor.Open(const aTableName : TffTableName; - const aIndexName : TffName; - const aIndexID : Longint; - const aOpenMode : TffOpenMode; - aShareMode : TffShareMode; - aForServer : boolean; - const aExclContLock : Boolean; {!!.10} - aAttribs : TffFileAttributes); -var - aLockType : TffSrLockType; - NewTable : boolean; - OpenIntentRegistered : Boolean; -begin - bcIndexID := aIndexID; - - NewTable := False; - OpenIntentRegistered := False; - - { The cursor references an instance of TffSrBaseTable. Multiple cursors may - reference that same instance of TffSrBaseTable since only 1 instance of - TffSrBaseTable is created per physical table (saves on file handles). - - So we must determine whether the table has already been opened by - another cursor. But first, we must obtain write access on the engine's - table list. Why? - - 1. If the table has not been opened, we don't want two threads trying - to open it at the same time. Should that occur, we would wind - up with duplicate tables in our table list. - - 2. If the table is already open, we don't thread A closing the table - while thread B is trying to "open" the table. Good recipe for an - access violation. - - Complication: If the table is open and locked, and this thread wants - to open the table in an incompatible lock mode, we must make sure - the table list is available to other threads. Otherwise, we will - freeze the server. } - bcEngine.TableList.BeginWrite; - try - { Try & find the open table in the engine's table list. If it exists already - then reference the existing table. } - bcTable := bcEngine.GetTableInstance(bcDatabase.Folder, aTableName); - - { Is the table open? } - if assigned(bcTable) then begin - { Yes. Register our intent to open the table. This prevents another - thread from freeing the table. } - bcTable.RegisterOpenIntent; - OpenIntentRegistered := True; - - { Release our lock on the table list. We must do so because our - request for a lock on the table may cause this thread to wait. - Retaining the lock in such a situation would freeze any threads - wanting access to the table list. } - bcEngine.TableList.EndWrite; - - { Determine the type of lock for the table, based upon the Open mode and - Share mode. } - if (aShareMode = smExclusive) then - aLockType := ffsltExclusive - else if (aOpenMode = omReadOnly) then - { Table is to be opened as Read-only. } - aLockType := ffsltShare - else - { Table is to be opened as Read-Write. } - aLockType := ffsltIntentS; - - { Acquire the lock. We will return from this call when the lock - is granted. Otherwise an exception will be raised (i.e., another - thread has the table locked exclusively and isn't giving it - up). } - bcTable.AcqLock(CursorID, aLockType); - - end - else begin - { No, it is not open. Open it now. } - try - bcTableOpenPrim(bcDatabase, aTableName, aOpenMode, aShareMode, - aForServer, aAttribs); - except - bcEngine.TableList.EndWrite; - raise; - end; - - NewTable := true; - bcTable.RegisterOpenIntent; {!!.01} - OpenIntentRegistered := True; {!!.01} - - end; - - { Make sure we meet all requirements for opening the table. } - try - bcTableOpenPreconditions(bcTable, aIndexName, bcIndexID, aOpenMode); - except - { If we created a new table then get rid of it. } - if NewTable then begin - if OpenIntentRegistered then {!!.02} - bcTable.DeregisterOpenIntent; {!!.02} - bcTable.Free; - bcTable := nil; - end; - raise; - end; - - { Add the newly opened table to the server table list. } - if NewTable then - bcEngine.TableList.AddTable(bcTable); - - bcInit(aOpenMode, aShareMode, aExclContLock); {Moved !!.01} - - finally - { If the table was not already opened then we still have the tableList - locked. Unlock it. } - if NewTable then - bcEngine.TableList.EndWrite; {!!.01} - if (bcTable <> nil) and OpenIntentRegistered then {!!.02} - { If we registered our intent to open then deregister our intent. } - bcTable.DeregisterOpenIntent; - end; - -// bcInit(aOpenMode, aShareMode); {Moved !!.01} - -end; -{--------} -procedure TffSrBaseCursor.Build(const aTableName : TffTableName; - aDict : TffDataDictionary; - const aOpenMode : TffOpenMode; - aShareMode : TffShareMode; - aForServer : boolean; - aOverWrite : boolean; - aAttribs : TffFileAttributes; - aStoreSize : TffWord32); -var - aLockType : TffSrLockType; - aTransID : TffTransID; - OpenIntentRegistered : Boolean; {!!.10} - TableDataFile : TffFileNameExt; - TmpTableName : TffTableName; -begin - bcIndexID := 0; - OpenIntentRegistered := False; {!!.10} - - TmpTableName := aTableName; - if (fffaTemporary in aAttribs) then begin - { Requirement: If the temporary file attribute is specified, the table must - have a block size of 64k. This is due to temporary storage (unit FFLLTEMP) - being restricted to 64k blocks of data. } - if (aDict.BlockSize < (64 * 1024)) then - aDict.BlockSize := (64 * 1024); - - { If no tablename specified then generate a unique table name. } - if TmpTableName = '' then - TmpTableName := IntToStr(Longint(Self)); - end; - - { Obtain write access to the table list. Our purpose is to make sure - the table is not opened. By obtaining write access, we prevent other - threads from creating or opening the table. } - bcEngine.TableList.BeginWrite; - try - - { Was a tablename specified? } - if aTableName <> '' then begin - { Yes. It is possible the table may already exist. - Try and find the open table in our list. If it exists already - obviously there's an error (we can't build a new table when it's - already open). } - bcTable := bcEngine.GetTableInstance(bcDatabase.Folder, TmpTableName); - if assigned(bcTable) then - FFRaiseException(EffException, ffStrResServer, fferrTableOpen, - [TmpTableName]); - - { The table name must be a valid file name without extension. } - if not FFVerifyFileName(TmpTableName) then - FFRaiseException(EffException, ffStrResServer, fferrInvalidTableName, - [TmpTableName]); - - { Is this a temporary table? } - if not (fffaTemporary in aAttribs) then begin - { No. The table's data file cannot exist within the database. } - TableDataFile := FFMakeFileNameExt(TmpTableName, ffc_ExtForData); - if FFFileExists(FFMakeFullFileName(bcDatabase.Folder.Path, - TableDataFile)) then begin - if aOverWrite then - { We want to overwrite this table - we have to delete it first. } - bcEngine.seDeleteTable(bcDatabase, TmpTableName) - else - FFRaiseException(EffException, ffStrResServer, fferrTableExists, - [TmpTableName]); - end; - end; - end; - - { Is this cursor to have its own temporary storage? } - if aStoreSize > 0 then - bcTempStore := ffcTempStorageClass.Create(bcEngine.ConfigDir, - aStoreSize, 64 * 1024) - else - bcTempStore := nil; - - { Create the table. } - bcTable := bcTableClass.Create(bcEngine, TmpTableName, bcDatabase.Folder, - bcEngine.BufferManager, omReadWrite); - - try - bcTable.RegisterOpenIntent; {!!.10} - OpenIntentRegistered := True; {!!.10} - bcEngine.seTransactionStart(bcDatabase, false, true, aTransID); - try - { Create the files comprising the table. } - bcTable.BuildFiles(bcDatabase.TransactionInfo, aForServer, aDict, - aAttribs, bcTempStore); - bcEngine.seTransactionCommit(bcDatabase); - except - bcEngine.seTransactionRollback(bcDatabase); - raise; - end; - - { Acquire the right type of lock on the table. } - if aShareMode = smExclusive then - aLockType := ffsltExclusive - else if aOpenMode = omReadOnly then - aLockType := ffsltShare - else - aLockType := ffsltIntentS; - - bcTable.AcqLock(CursorID, aLockType); - - bcTableOpenPreconditions(bcTable, '', bcIndexID, aOpenMode); - except - { Destroy the table object. This will close all the files. } - bcTable.DeregisterOpenIntent; - bcTable.Free; - bcTable := nil; - raise; - end;{try..finally} - - bcEngine.TableList.AddTable(bcTable); - bcInit(aOpenMode, aShareMode, False); {!!.10} - finally - bcEngine.TableList.EndWrite; - if assigned(bcTable) and OpenIntentRegistered then {!!.10} - bcTable.DeregisterOpenIntent; {!!.10} - end; -end; -{--------} -destructor TffSrBaseCursor.Destroy; -var - anExtender : TffBaseEngineExtender; - anIndex : Longint; -begin - bcEngine.TableList.BeginWrite; {!!.10} - try - { Assumption: If cursor is being closed in the context of a transaction then - the changes made to the table should be saved. We will retain the cursor's - locks in the lock manager so that no other cursors can access those - records. The changes to the table will stay in memory until the transaction - commits or rolls back. } - -{Begin !!.03} - { If still have a record locked from TffTable.Edit then release the lock. } - if not FFI64IsZero(bcLockedRefNum) then - bcTable.RemoveLocksForCursor(bcDatabase.DatabaseID, {!!.10} - CursorID, bcLockedRefNum, {!!.10} - bcDatabase.TransactionInfo); -{End !!.03} - - if (bcRecordData <> nil) then {!!.01} - FFFreeMem(bcRecordData, bcRecordLen); {!!.01} - - bcBLOBCursors.Free; - - if bcExclOwner then begin - bcTable.SetExclOwner(ffc_W32NoValue); - bcExclOwner := False; - end; - - if assigned(bcExtenders) then begin - for anIndex := pred(bcExtenders.Count) downto 0 do begin - anExtender := TffBaseEngineExtender - (TffIntListItem(bcExtenders[anIndex]).KeyAsInt); - anExtender.Free; - end; - bcExtenders.Free; - end; - -// if bcCloseTable then begin {Deleted !!.02} - if bcTable <> nil then begin {!!.02} - bcTable.CursorList.BeginWrite; - try - bcTable.CursorList.RemoveCursor(CursorID); - finally - bcTable.CursorList.EndWrite; - end; - if bcCloseTable then {!!.02} - bcEngine.TableList.RemoveIfUnused(bcTable); - end; - - bcTempStore.Free; - bcInfoLock.Free; {!!.06} - - finally - bcEngine.TableList.EndWrite; {!!.10} - inherited Destroy; - end; -end; -{--------} -procedure TffSrBaseCursor.AcqContentLock(const aMode : TffContentLockMode); {!!.10} -{ NOTE:: If you change this method then look at AcqContentLockCond for similar - changes. } -begin - if (fffaBLOBChainSafe in bcGetAttribs) or {!!.05} - (bcExclOwner and (not bcTable.Dictionary.HasBLOBFields)) then {!!.03}{!!.05} - Exit; - - Assert(assigned(bcDatabase.Transaction) or - (aMode = ffclmRead)); - - { Is a transaction active? } - if assigned(bcDatabase.Transaction) then - { Yes. Call the appropriate table method. } - case aMode of - ffclmCommit : - bcTable.BeginCommit; - ffclmRead : - bcTable.AcqContentLock(bcDatabase.Transaction, ffsltShare, False); - ffclmWrite : - bcTable.AcqContentLock(bcDatabase.Transaction, ffsltExclusive, False); - end { case } - else begin {!!.05 - Start} - { No transaction. This should be a reader thread that wants read access. } - if (bcNumReadLocks = 0) then - bcTable.BeginRead; - InterlockedIncrement(bcNumReadLocks); - end; {!!.05 - End} -end; -{Begin !!.10} -{--------} -function TffSrBaseCursor.AcqExclContentLock : TffResult; -{ NOTE:: If you change this method then look at AcqContentLock for similar - changes. } -begin - if not ((fffaBLOBChainSafe in bcGetAttribs) or - (bcExclOwner and (not bcTable.Dictionary.HasBLOBFields))) then begin - Assert(assigned(bcDatabase.Transaction)); - Result := bcTable.AcqExclContentLock(bcDatabase.Transaction); - end - else - Result := DBIERR_NONE; -end; -{End !!.10} -{--------} -procedure TffSrBaseCursor.AppendNewRecord(aData : PffByteArray); -begin - AcqContentLock(ffclmWrite); - InsertRecord(aData, ffsltExclusive); -end; -{--------} -procedure TffSrBaseCursor.bcAddExtender(anExtender : TffBaseEngineExtender); -var - anItem : TffIntListItem; -begin - if assigned(anExtender) then begin - if not assigned(bcExtenders) then - bcExtenders := TffList.Create; - anItem := TffIntListItem.Create(Longint(anExtender)); - bcExtenders.Insert(anItem); - end; -end; -{--------} -function TffSrBaseCursor.bcBLOBCopy(aSrcCursor : TffSrBaseCursor; - const aBLOBNr : TffInt64; - var aDestBLOBNr : TffInt64) - : TffResult; -var - aBLOB : PffByteArray; - aBytesRead, - aLen, - aOffset : TffWord32; {!!.06} - FileName : TffFullFileName; -begin - Result := DBIERR_NONE; - { Assumption: Transaction has already been started by a calling routine. } - - { Is this a file BLOB? } - if FFTblGetFileNameBLOB - (aSrcCursor.bcTable.btFiles[aSrcCursor.Dictionary.BLOBFileNumber], - bcDatabase.TransactionInfo, aBLOBNr, FileName) then begin - FFTblAddFileBLOB(bcTable.btFiles[Dictionary.BLOBFileNumber], - bcDatabase.TransactionInfo, - FileName, aDestBLOBNr); - end - else begin - aBytesRead := 0; - aOffset := 0; -{Begin !!.12} - aLen := FFMinI(aSrcCursor.BLOBGetLength(aBLOBNr, Result), - ffc_NumBLOBBytesToCopy); - if Result = DBIERR_NONE then begin -{End !!.12} - FFGetMem(aBLOB, aLen); - try - { Create the BLOB in the destination cursor. } - Result := BLOBAdd(aDestBLOBNr); - if Result = DBIERR_NONE then - repeat - Result := aSrcCursor.BLOBRead(aBLOBNr, aOffset, aLen, aBLOB^, - aBytesRead); - if aBytesRead > 0 then begin - Result := BLOBWrite(aDestBLOBNr, aOffset, aBytesRead, aBLOB^); - inc(aOffset, aBytesRead); - end; - until (aBytesRead = 0) or (Result <> DBIERR_NONE); - finally - FFFreeMem(aBLOB, aLen); - end; - end; { if } {!!.12} - end; -end; -{--------} -function TffSrBaseCursor.bcBLOBLinkGetLength(const aTableName : TffTableName; - const aBLOBNr : TffInt64; - var aLength : Longint) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - Cursor := bcFindBLOBCursor(aTableName); - Assert(Assigned(Cursor)); - aLength := Cursor.BLOBGetLength(aBLOBNr, Result); -end; -{--------} -function TffSrBaseCursor.bcBLOBLinkRead(const aTableName : TffTableName; - const aBLOBNr : TffInt64; - const aOffset : TffWord32; {!!.06} - const aLen : TffWord32; {!!.06} - var aBLOB; - var aBytesRead : TffWord32) {!!.06} - : TffResult; -var - Cursor : TffSrBaseCursor; -begin - Cursor := bcFindBLOBCursor(aTableName); - Assert(Assigned(Cursor)); - Result := Cursor.BLOBRead(aBLOBNr, aOffset, aLen, aBLOB, aBytesRead); -end; -{--------} -function TffSrBaseCursor.bcCheckExclusiveReadWrite : TffResult; -begin - Result := DBIERR_NONE; - - { The cursor must have Exclusive access to the table. } - if (not bcExclOwner) then - Result := DBIERR_NEEDEXCLACCESS - else if (bcOpenMode = omReadOnly) and {!!.06} - not (fffaTemporary in bcTable.Files[0].fiAttributes)then {!!.06} - { The cursor must be in read-write mode. Temporary files are excluded - from this rule. } - Result := DBIERR_TABLEREADONLY; - -end; -{--------} -function TffSrBaseCursor.bcFindBLOBCursor(const aTableName : TffTableName) - : TffSrBaseCursor; -var - Inx : Longint; - UTableName : TffTableName; -begin - Result := nil; - UTableName := Uppercase(aTableName); - { Do we have any BLOB cursors yet? } - if bcBLOBCursors = nil then - { No. Instantiate. } - bcBLOBCursors := TffList.Create; - - { Have we opened a cursor for the referenced table? } - for Inx := 0 to pred(bcBLOBCursors.Count) do begin - if UpperCase(TffSrBaseCursor(bcBLOBCursors[Inx]).bcTable.BaseName) = - UTableName then begin - Result := TffSrBaseCursor(bcBLOBCursors[Inx]); - break; - end; - end; - - { Did we find a cursor? } - if Result = nil then begin - { No. Create one. } - { Limitation: BLOB links can refer only to standard cursors, not to - SQL result sets. } - Result := bcEngine.CursorClass.Create(bcEngine, {!!.06} - bcDatabase, - Timeout); - Result.Open(aTableName, '', 0, omReadOnly, smShared, False, False, []); {!!.01} - bcBLOBCursors.Insert(Result); - end; -end; -{--------} -function TffSrBaseCursor.bcGetAttribs : TffFileAttributes; -begin - Result := bcTable.Files[0]^.fiAttributes; -end; -{--------} -function TffSrBaseCursor.bcGetCursorID : TffCursorID; -begin - Result := TffCursorID(Self); -end; -{--------} -function TffSrBaseCursor.bcGetPosition : TffCursorPosition; -begin - Result := bcInfo.Pos; -end; -{--------} -function TffSrBaseCursor.bcGetRefNr : TffInt64; -begin - Result := bcInfo.RefNr; -end; -{--------} -procedure TffSrBaseCursor.bcInit(const aOpenMode : TffOpenMode; - const aShareMode : TffShareMode; - const aExclContLock : Boolean); {!!.10} -var - anIndex : Longint; - aMonitor : TffBaseEngineMonitor; - anExtender : TffBaseEngineExtender; - MonitorList : TffList; -begin - - { Assumption: This routine only called once a table has been successfully - opened by the cursor. } - bcFilter := nil; - bcFilterSav := nil; - bcNewRecBuff := nil; - bcOldRecBuff := nil; - - { Miscellaneous. } - if bcEngine.Configuration.GeneralInfo^.giReadOnly then - bcOpenMode := omReadOnly - else - bcOpenMode := aOpenMode; - FreeOnRemove := true; - - { Add ourself to the cursor lists in the table and database. } - bcTable.CursorList.BeginWrite; - try - bcTable.CursorList.AddCursor(Self); - finally - bcTable.CursorList.EndWrite; - end; - - bcDatabase.CursorList.BeginWrite; - try - bcDatabase.CursorList.AddCursor(Self); - finally - bcDatabase.CursorList.EndWrite; - end; - - { If there are any monitors interested in cursors then see if they - are interested in this cursor. } - MonitorList := bcEngine.GetInterestedMonitors(TffSrBaseCursor); - if assigned(MonitorList) then begin - for anIndex := 0 to pred(MonitorList.Count) do begin - aMonitor := TffBaseEngineMonitor - (TffIntListItem(MonitorList[anIndex]).KeyAsInt); - try - anExtender := aMonitor.Interested(Self); - if assigned(anExtender) then - bcAddExtender(anExtender); - except - on E:Exception do - bcEngine.seForce('Monitor [%s] exception, bcInit: %s', {!!.06 - Start} - [aMonitor.ClassName,E.message], - bcEngine.bseGetReadOnly); {!!.06 - End} - end; - end; - MonitorList.Free; - end; - - { Get memory for a record data scratch pad. } - bcRecordLen := bcTable.Dictionary.RecordLength; - FFGetMem(bcRecordData, bcRecordLen); - - { If the cursor is the exclusive owner of the table then mark this - fact. } - if aShareMode = smExclusive then begin - bcTable.SetExclOwner(CursorID); - bcExclOwner := True; - end; - -{Begin !!.10} - if aExclContLock then - bcTable.AcqContentLock(bcDatabase.Transaction, ffsltExclusive, False); -{End !!.10} - -end; -{--------} -procedure TffSrBaseCursor.bcInvalidateCurKey; -begin - bcInfo.KeyValid := false; -end; -{--------} -function TffSrBaseCursor.bcIsCurKeyPathValid : boolean; -begin - Result := (bcInfo.KeyPath.kpPos <> kppUnknown); -end; -{--------} -function TffSrBaseCursor.bcIsCurKeyValid: boolean; -begin - Result := bcInfo.KeyValid; -end; -{--------} -procedure TffSrBaseCursor.bcRecordUpdated(aOp : TffRecOp; - aRefNr : TffInt64; - aIndexID : integer); -begin - { A cursor is affected by another cursor's operations as follows: - - 1. When a cursor inserts a record, it may cause a Structural Modification - Operation (SMO) in the indices. Other cursors open on the same - table may now have invalid key paths. - - In FF 1.x, this routine would reset the key path. In FF 2.x, we - leave the key path as is. The next time the cursor moves to the next - or previous record, the indexing code will see that the key path has - been modified and rebuild the key path. - - *** We do not call this routine for a record insertion. *** - - 2. When a cursor deletes a record, it may cause an SMO in the indices. As - mentioned for inserts, we will rely upon the indexing code to rebuild - the key path. - - If another cursor is positioned on the deleted record, we must make sure - the cursor knows the record has been deleted. This routine sets the - bcInfo.Deleted flag and positions the cursor to OnCrack. When this - notification occurs, any cursors wanting to do something with the record - will be blocked while waiting for a lock on the record so this should - be a safe operation. - - 3. When a cursor modifies a record, it may cause an SMO in zero or more - indicies. As mentioned for inserts, we will rely upon the indexing - code to rebuild the key path. - - If another cursor is positioned on the modified record, we must make - it look like the record has been deleted. This routine sets the - bcInfo.Deleted flag and positions the cursor to OnCrack. When this - notification occurs, any cursors wanting to do something with the record - will be blocked while waiting for a lock on the record so this should - be a safe operation. - - In general, this method is thread-safe. It is called only for those cursors - that belong to the same database as the cursor performing the insert, - update, or delete. Those cursors should be in the same client thread - and only one request from that client thread is executed on the server - at any given time. So operations should not be active for any of the - other cursors belonging to the same database. - } - - case aOp of - roDelete : - if (FFCmpI64(aRefNr, bcInfo.RefNr) = 0) and - (bcInfo.Pos = cpOnRecord) then begin - bcInfo.Deleted := True; - if bcIsCurKeyPathValid then begin - Assert(bcInfo.KeyPath.kpCount > 0); - bcInfo.Pos := cpOnCrack; - bcInfo.KeyPath.kpPos := kppOnCrackBefore; - end - else - bcInfo.KeyPath.kpPos := kppUnknown; - end; - roModify : - if (aIndexID = IndexID) and - (FFCmpI64(aRefNr, bcInfo.RefNr) = 0) and - (bcInfo.Pos = cpOnRecord) then begin - bcInfo.Deleted := True; - if bcIsCurKeyPathValid then begin - Assert(bcInfo.KeyPath.kpCount > 0); - bcInfo.Pos := cpOnCrack; - bcInfo.KeyPath.kpPos := kppOnCrackBefore; - end - else - bcInfo.KeyPath.kpPos := kppUnknown; - end; - end;{case} -end; -{--------} -procedure TffSrBaseCursor.bcRestoreCurInfo; -begin - bcInfo := bcSavedInfo; -end; -{--------} -procedure TffSrBaseCursor.bcSaveCurInfo; -begin - bcSavedInfo := bcInfo; -end; -{--------} -procedure TffSrBaseCursor.bcTableOpenPrim(aDatabase : TffSrDatabase; - const aTableName : TffTableName; - const aOpenMode : TffOpenMode; - const aShareMode : TffShareMode; - const aForServer : boolean; - const aAttribs : TffFileAttributes); -var - aLockType : TffSrLockType; - TableDataFile : TffFileNameExt; -begin - - { The table name must be a valid file name without extension. } - if not FFVerifyFileName(aTableName) then - FFRaiseException(EffException, ffstrResServer, fferrInvalidTableName, - [aTableName]); - - { The table's data file must exist within the database. } - TableDataFile := FFMakeFileNameExt(aTableName, ffc_ExtForData); - if not FFFileExists(FFMakeFullFileName(aDatabase.Folder.Path, TableDataFile)) then - FFRaiseException(EffException, ffstrResServer, fferrUnknownTable, - [TableDataFile, aDatabase.Alias]); - - { Create the table instance. } - bcTable := bcTableClass.Create(aDatabase.Engine, aTableName, {!!.03} - aDatabase.Folder, - aDatabase.Engine.BufferManager, aOpenMode);{!!.03} - - try - { Acquire the right type of lock on the table. } - if aShareMode = smExclusive then - aLockType := ffsltExclusive - else if aOpenMode = omReadOnly then - aLockType := ffsltShare - else - aLockType := ffsltIntentS; - - bcTable.AcqLock(CursorID, aLockType); - - { Open up the files in the table, making sure that all of them - are in FF format. } - bcTable.OpenFiles(aDatabase.TransactionInfo, aForServer, aAttribs); - TffSrTable(bcTable).ResolveDynamicLinks; {!!.06} - bcTable.SetAttributes(aAttribs); - except - bcTable.Free; - bcTable := nil; - raise; - end; -end; -{--------} -function TffSrBaseCursor.BLOBAdd(var aBLOBNr : TffInt64) : TffResult; -begin - Result := NotifyExtenders(ffeaBeforeBLOBCreate, ffeaBLOBCreateFail); - - if Result = DBIERR_NONE then - try - AcqContentLock(ffclmWrite); - FFTblAddBLOB(bcTable.Files[bcTable.Dictionary.BLOBFileNumber], - bcDatabase.TransactionInfo, aBLOBNr); - NotifyExtenders(ffeaAfterBLOBCreate, ffeaNoAction); - except - NotifyExtenders(ffeaBLOBCreateFail, ffeaNoAction); - raise; - end; -end; -{--------} -function TffSrBaseCursor.BLOBLinkAdd(const aTableName : TffTableName; - const aTableBLOBNr : TffInt64; - var aBLOBNr : TffInt64) : TffResult; -begin - Result := NotifyExtenders(ffeaBeforeBLOBLinkAdd, ffeaBLOBLinkAddFail); - - if Result = DBIERR_NONE then - try - AcqContentLock(ffclmWrite); - FFTblAddBLOBLink(bcTable.Files[bcTable.Dictionary.BLOBFileNumber], - bcDatabase.TransactionInfo, aTableName, aTableBLOBNr, - aBLOBNr); - NotifyExtenders(ffeaAfterBLOBLinkAdd, ffeaNoAction); - except - NotifyExtenders(ffeaBLOBLinkAddFail, ffeaNoAction); - raise; - end; -end; -{--------} -function TffSrBaseCursor.FileBLOBAdd(const aFileName : TffFullFileName; - var aBLOBNr : TffInt64) : TffResult; -begin - Result := NotifyExtenders(ffeaBeforeFileBLOBAdd, ffeaFileBLOBAddFail); - - if Result = DBIERR_NONE then - try - AcqContentLock(ffclmWrite); - FFTblAddFileBLOB(bcTable.Files[bcTable.Dictionary.BLOBFileNumber], - bcDatabase.TransactionInfo, aFileName, aBLOBNr); - NotifyExtenders(ffeaAfterFileBLOBAdd, ffeaNoAction); - except - NotifyExtenders(ffeaFileBLOBAddFail, ffeaNoAction); - raise; - end; -end; -{--------} -function TffSrBaseCursor.BLOBDelete(const aBLOBNr : TffInt64) : TffResult; -begin - Result := NotifyExtenders(ffeaBeforeBLOBDelete, ffeaBLOBDeleteFail); - if Result = DBIERR_NONE then - try - AcqContentLock(ffclmWrite); - FFTblDeleteBLOB(bcTable.Files[bcTable.Dictionary.BLOBFileNumber], - bcDatabase.TransactionInfo, aBLOBNr); - NotifyExtenders(ffeaAfterBLOBDelete, ffeaNoAction); - except - NotifyExtenders(ffeaBLOBDeleteFail, ffeaNoAction); - raise; - end; -end; -{--------} -function TffSrBaseCursor.BLOBFree(aBLOBNr : TffInt64) : TffResult; -begin - Result := NotifyExtenders(ffeaBeforeBLOBFree, ffeaBLOBFreeFail); - - if Result = DBIERR_NONE then - try - AcqContentLock(ffclmWrite); - if FFTblFreeBLOB(bcTable.Files[bcTable.Dictionary.BLOBFileNumber], - bcDatabase.TransactionInfo, aBLOBNr) then - Result := DBIERR_BLOBMODIFIED; - NotifyExtenders(ffeaAfterBLOBFree, ffeaNoAction); - except - NotifyExtenders(ffeaBLOBFreeFail, ffeaNoAction); - raise; - end; -end; -{--------} -function TffSrBaseCursor.BLOBGetLength(aBLOBNr : TffInt64; - var aFBError: TffResult) : Longint; -begin - Result := -1; - aFBError := NotifyExtenders(ffeaBeforeBLOBGetLength, ffeaBLOBGetLengthFail); - - if aFBError = DBIERR_NONE then - try - AcqContentLock(ffclmRead); - try - Result := FFTblGetBLOBLength(bcTable.Files[bcTable.Dictionary.BLOBFileNumber], - bcDatabase.TransactionInfo, - aBLOBNr, - bcBLOBLinkGetLength, - aFBError); - NotifyExtenders(ffeaAfterBLOBGetLength, ffeaNoAction); - finally - RelContentLock(ffclmRead); - end; - except - NotifyExtenders(ffeaBLOBGetLengthFail, ffeaNoAction); - raise; - end; -end; -{Begin !!.03} -{--------} -function TffSrBaseCursor.BLOBIsLink(aBLOBNr : TffInt64; {!!.11 - Start} - var aSrcTableName : TffTableName; - var aSrcTableBLOBNr : TffInt64) - : Boolean; -begin - Result := FFTblIsBLOBLink(bcTable.Files[bcTable.Dictionary.BLOBFileNumber], - bcDatabase.TransactionInfo, - aBLOBNr, - aSrcTableName, - aSrcTableBLOBNr); -end; -{--------} {!!.11 - End} -function TffSrBaseCursor.BLOBListSegments(aBLOBNr : TffInt64; - aStream : TStream) - : TffResult; -begin - Result := DBIERR_NONE; - AcqContentLock(ffclmRead); - try - FFTblListBLOBSegments(bcTable.Files[bcTable.Dictionary.BLOBFileNumber], - bcDatabase.TransactionInfo, aBLOBNr, - aStream); - finally - RelContentLock(ffclmRead); - end; -end; -{End !!.03} -{--------} -function TffSrBaseCursor.BLOBRead(aBLOBNr : TffInt64; - aOffset : TffWord32; {!!.06} - aLen : TffWord32; {!!.06} - var aBLOB; - var aBytesRead : TffWord32) {!!.06} - : TffResult; -begin - Result := NotifyExtenders(ffeaBeforeBLOBRead, ffeaBLOBReadFail); - - if Result = DBIERR_NONE then - try - AcqContentLock(ffclmRead); - try -{Begin !!.11} - bcTable.btBLOBEngine.Read - (bcTable.Files[bcTable.Dictionary.BLOBFileNumber], - bcDatabase.TransactionInfo, - aBLOBNr, - aOffset, - aLen, - bcBLOBLinkRead, - aBLOB, - aBytesRead, - Result); -{End !!.11} - NotifyExtenders(ffeaAfterBLOBRead, ffeaNoAction); - finally - RelContentLock(ffclmRead); - end; - except - NotifyExtenders(ffeaBLOBReadFail, ffeaNoAction); - raise; - end; -end; -{--------} -function TffSrBaseCursor.BLOBTruncate(aBLOBNr : TffInt64; - aLen : TffWord32) : TffResult; -begin - Result := NotifyExtenders(ffeaBeforeBLOBTruncate, ffeaBLOBTruncateFail); - - if Result = DBIERR_NONE then - try - AcqContentLock(ffclmWrite); -{Begin !!.11} - bcTable.btBLOBEngine.Truncate - (bcTable.Files[bcTable.Dictionary.BLOBFileNumber], - bcDatabase.TransactionInfo, aBLOBNr, aLen); -{End !!.11} - NotifyExtenders(ffeaAfterBLOBTruncate, ffeaNoAction); - except - NotifyExtenders(ffeaBLOBTruncateFail, ffeaNoAction); - raise; - end; -end; -{--------} -function TffSrBaseCursor.BLOBWrite(const aBLOBNr : TffInt64; - aOffset : TffWord32; - aLen : TffWord32; - var aBLOB) : TffResult; -begin - Result := NotifyExtenders(ffeaBeforeBLOBWrite, ffeaBLOBWriteFail); - - if Result = DBIERR_NONE then - try - AcqContentLock(ffclmWrite); -{Begin !!.11} - bcTable.btBLOBEngine.Write - (bcTable.Files[bcTable.Dictionary.BLOBFileNumber], - bcDatabase.TransactionInfo, aBLOBNr, aOffset, aLen, - aBLOB); -{End !!.11} - NotifyExtenders(ffeaAfterBLOBWrite, ffeaNoAction); - except - on E:Exception do begin - NotifyExtenders(ffeaBLOBWriteFail, ffeaNoAction); - raise; - end; - end; -end; -{--------} -function TffSrBaseCursor.CopyRecords(aSrcCursor : TffSrBaseCursor; - aBLOBCopyMode : TffBLOBCopyMode; - aCallback : TffSrCopyRecordsProc; - aCookie1, aCookie2 : Longint) : TffResult; -var - aAutoIncField : Integer; {!!.02} - aAutoIncHigh : TffWord32; {!!.02} - aThisAutoInc : TffWord32; {!!.02} - aBLOBFields : TffPointerList; - aBLOBNr, - aSrcBLOBNr : TffInt64; - aInx, - aOffset : integer; - aRecord : PffByteArray; - aTableName : TffTableName; - aTransID : TffTransID; - aVal : PffByteArray; - Include, - IsNull : boolean; -begin - - aVal := nil; - -{Begin !!.02} - { Does the target have an autoinc field? } - if Dictionary.HasAutoIncField(aAutoIncField) then - { Yes. Get the current seed value. } - ReadAutoIncValue(aAutoIncHigh) - else - { No. Flag it. } - aAutoIncField := -1; -{End !!.02} - - { Requirement: The cursors must be pointing to different tables. } - if bcTable = aSrcCursor.Table then - FFRaiseExceptionNoData(EffException, ffStrResServer, fferrSameTable); - - aTableName := aSrcCursor.Table.BaseName; - aBLOBFields := TffPointerList.Create; - try - { Requirement: The dictionary field types and sizes must match. } - if not bcTable.Dictionary.HasSameFields(aSrcCursor.Dictionary, aBLOBFields) then - FFRaiseExceptionNoData(EffException, ffStrResServer, fferrIncompatDict); - - { Save the position of each cursor. } - bcSaveCurInfo; - aSrcCursor.bcSaveCurInfo; - { Create a record buffer. } - FFGetMem(aRecord, bcTable.Dictionary.RecordLength); - try - { Position the source cursor to BOF. } - aSrcCursor.SetToBegin; - - { Start a transaction. It will be nested if a transaction is already - in progress. } - Result := bcEngine.seTransactionStart(bcDatabase, False, True, aTransID); - try - while (Result = DBIERR_NONE) do begin - - { Grab a record from the source cursor. } - Result := aSrcCursor.GetNextRecord(aRecord, ffsltNone); - if Result = DBIERR_NONE then begin - - { Was a callback function specified? } - Include := True; - if assigned(aCallback) then - aCallback(aSrcCursor, aRecord, aCookie1, aCookie2, Include); - - if Include then begin - { Any BLOB fields? } - if aBLOBFields.Count > 0 then begin - { Yes. Copy or link as necessary. } - for aInx := 0 to pred(aBLOBFields.Count) do begin - aOffset := bcTable.Dictionary.FieldOffset[Integer(aBLOBFields[aInx])]; - { Is the BLOB field null? } - aSrcCursor.Dictionary.GetRecordField(Integer(aBLOBFields[aInx]), - aRecord, IsNull, aVal); - if not IsNull then begin - case aBLOBCopyMode of - ffbcmNoCopy : - bcTable.Dictionary.SetRecordField - (Integer(aBLOBFields[aInx]), aRecord, nil); - ffbcmCopyFull : - begin - aSrcBLOBNr := PffInt64(@aRecord^[aOffset])^; - Result := bcBLOBCopy(aSrcCursor, aSrcBLOBNr, aBLOBNr); - if Result = DBIERR_NONE then - PffInt64(@aRecord^[aOffset])^ := aBLOBNr - else - break; - end; - else { link the BLOBs } - { Get the BLOB reference out of the record. } - aSrcBLOBNr := PffInt64(@aRecord^[aOffset])^; - { Add a BLOB link. } - BLOBLinkAdd(aTableName, aSrcBLOBNr, aBLOBNr); - { Update the BLOB reference in the record. } - PffInt64(@aRecord^[aOffset])^ := aBLOBNr; - end; { case } - end; { if BLOB field not null } - end; { for } - end; - Result := InsertRecord(aRecord, ffsltNone); -{Begin !!.02} - { If the target has an autoinc field then keep track of the - highest value. } - if (Result = DBIERR_NONE) and(aAutoIncField > -1) then begin - Dictionary.GetRecordField(aAutoIncField, - aRecord, IsNull, @aThisAutoInc); - if not IsNull and (aThisAutoInc > aAutoIncHigh) then - aAutoIncHigh := aThisAutoInc; - end; -{End !!.02} - end; - end; { if } - end; { while } -{Begin !!.02} - if Result = DBIERR_EOF then begin - { If the destination has an autoinc field then update the seed - value. } - if aAutoIncField <> -1 then - FFTblSetAutoIncValue(Table.Files[0], - Database.TransactionInfo, - aAutoIncHigh); - Result := bcEngine.seTransactionCommit(bcDatabase); - end -{End !!.02} - else - bcEngine.seTransactionRollback(bcDatabase); - except - bcEngine.seTransactionRollback(bcDatabase); - raise; - end; - finally - { Free the record buffer. } - FFFreeMem(aRecord, bcTable.Dictionary.RecordLength); - { Restore the position of each cursor. } - bcRestoreCurInfo; - aSrcCursor.bcRestoreCurInfo; - end; - finally - aBLOBFields.Free; - end; -end; -{--------} -function TffSrBaseCursor.CopyRecordParts(aSrcCursor : TffSrBaseCursor; - aFields : PffLongintArray; - aNumFields : integer; - aBLOBCopyMode : TffBLOBCopyMode; - aCallback : TffSrCopyRecordsProc; - aCookie1, aCookie2 : Longint) : TffResult; -var - aBLOBFields : TffPointerList; - aInx : integer; - aDestRec, aSrcRec : PffByteArray; - aSrcBLOBNr, aBLOBNr : TffInt64; - aOffset : integer; - aTableName : TffTableName; - aTransID : TffTransID; - aVal : PffByteArray; - DestLen : integer; - Include : boolean; - IsNull : boolean; -begin - - { Requirement: The cursors must be pointing to different tables. } - if bcTable = aSrcCursor.Table then - FFRaiseExceptionNoData(EffException, ffStrResServer, fferrSameTable); - - aTableName := aSrcCursor.Table.BaseName; - aBLOBFields := TffPointerList.Create; - try - { Requirement: The dictionary field types and sizes must match. } - if not bcTable.Dictionary.HasSameFieldsEx(aSrcCursor.Dictionary, aFields, - aNumFields, aBLOBFields) then - FFRaiseExceptionNoData(EffException, ffStrResServer, fferrIncompatDict); - - { Save the position of each cursor. } - bcSaveCurInfo; - aSrcCursor.bcSaveCurInfo; - - { Create record buffers. } - DestLen := bcTable.Dictionary.RecordLength; - FFGetMem(aDestRec, DestLen); - FFGetMem(aSrcRec, aSrcCursor.Dictionary.RecordLength); - FFGetMem(aVal, aSrcCursor.Dictionary.BlockSize); - try - { Position the source cursor to BOF. } - aSrcCursor.SetToBegin; - - { Start a transaction. It will be nested if a transaction is already - in progress. } - Result := bcEngine.seTransactionStart(bcDatabase, False, True, aTransID); - try - while (Result = DBIERR_NONE) do begin - - { Grab a record from the source cursor. } - Result := aSrcCursor.GetNextRecord(aSrcRec, ffsltNone); - if Result = DBIERR_NONE then begin - - { Was a callback function specified? } - Include := True; - if assigned(aCallback) then - aCallback(aSrcCursor, aSrcRec, aCookie1, aCookie2, Include); - - if Include then begin - { Build the destination record. } - FillChar(aDestRec^, destLen, 0); - for aInx := 0 to pred(aNumFields) do begin - aSrcCursor.Dictionary.GetRecordField(aFields^[aInx], - aSrcRec, IsNull, aVal); - if IsNull then - bcTable.Dictionary.SetRecordField(aInx, aDestRec, nil) - else begin - { Is this a BLOB field? } - if bcTable.Dictionary.FieldType[aInx] in - [fftBLOB..fftBLOBFile] then begin - aOffset := aSrcCursor.Dictionary.FieldOffset[aFields^[aInx]]; - { Yes. How is it to be handled? } - case aBLOBCopyMode of - ffbcmNoCopy : - bcTable.Dictionary.SetRecordField(aInx, aDestRec, nil); - ffbcmCopyFull : - begin - aSrcBLOBNr := PffInt64(@aSrcRec^[aOffset])^; - Result := bcBLOBCopy(aSrcCursor, aSrcBLOBNr, aBLOBNr); - if Result = DBIERR_NONE then - PffInt64(@aDestRec^[aOffset])^ := aBLOBNr - else - break; - end; - else { link the BLOBs } - { Get the BLOB reference out of the record. } - aSrcBLOBNr := PffInt64(@aSrcRec^[aOffset])^; - { Add a BLOB link. } - BLOBLinkAdd(aTableName, aSrcBLOBNr, aBLOBNr); - { Update the BLOB reference in the record. } - PffInt64(@aDestRec^[aOffset])^ := aBLOBNr; - end; { case } - end - else - bcTable.Dictionary.SetRecordField(aInx, aDestRec, aVal); - end; - end; - { Insert the record. } - Result := InsertRecord(aDestRec, ffsltNone); - end; - end; { if } - end; { while } - if Result = DBIERR_EOF then - Result := bcEngine.seTransactionCommit(bcDatabase) - else - bcEngine.seTransactionRollback(bcDatabase); - except - bcEngine.seTransactionRollback(bcDatabase); - raise; - end; - finally - { Free the record buffers. } - FFFreeMem(aSrcRec, aSrcCursor.Dictionary.RecordLength); - FFFreeMem(aDestRec, DestLen); - FFFreeMem(aVal, aSrcCursor.Dictionary.BlockSize); - { Restore the position of each cursor. } - bcRestoreCurInfo; - aSrcCursor.bcRestoreCurInfo; - end; - finally - aBLOBFields.Free; - end; -end; -{--------} -function TffSrBaseCursor.DeleteRecord(aData : PffByteArray) : TffResult; -var - BTreeChanged : Boolean; {!!.05} - LockedRefNr : TffInt64; {!!.05} -begin - Result := DBIERR_NONE; {!!.01} - { Are we on a record? } - if (bcInfo.Pos <> cpOnRecord) then begin - { No. } - Result := DBIERR_NOCURRREC; - Exit; - end; - - { Note: By this time, any other cursor deleting the record ahead of us has - completed and has set bcInfo.Deleted. We can be assured of this because - TffServerEngine.RecordDelete calls Cursor.EnsureWritable(true) which - obtains a lock on the record to be deleted. We won't get that lock until - the other cursor has finished. } - - try {!!.01} - { Has this record already been deleted? } - if bcInfo.Deleted then begin - { Yes. } - Result := DBIERR_KEYORRECDELETED; - Exit; - end; - - AcqContentLock(ffclmWrite); - if (aData = nil) and {!!.02} - ((bcFilter <> nil) or (bcExtenders <> nil)) then {!!.02} - aData := bcRecordData; - if (aData <> nil) then begin - Table.GetRecord(bcDatabase.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, bcInfo.refNr, aData, {!!.10} - ffsltExclusive, True, False); { lock obtained in EnsureWritable } {!!.02} - if Assigned(bcFilter) then - if not bcFilter.MatchesRecord(aData) then begin - { Release the record lock. } -// Table.RelRecordLock(bcDatabase.TransactionInfo, CursorID, bcInfo.refNr); {Deleted !!.01} - Result := DBIERR_NOCURRREC; - Exit; - end; - end; - - { Notify extenders. } - bcOldRecBuff := aData; - try - Result := NotifyExtenders(ffeaBeforeRecDelete, ffeaDeleteRecFail); - { If the extenders object, we can't continue. } - if Result = DBIERR_NONE then begin - BTreeChanged := False; {!!.05 - Start} - LockedRefNr := bcInfo.refNr; {!!.05} - Result := Table.DeleteRecord(Database.TransactionInfo, CursorID, - bcInfo.refNr, True, BTreeChanged); - if (Result = DBIERR_NONE) then begin - bcTable.RelaxRecordLock(bcDatabase.TransactionInfo, CursorID,{!!.10} - bcInfo.RefNr); {!!.10} - if bcInfo.KeyPath.kpPos = kppUnknown then - bcInfo.Pos := cpUnknown - else if (BTreeChanged) then begin - bcRebuildKeyPath; - end else if (bcInfo.KeyPath.kpPos = kppOnKey) then begin - bcInfo.KeyPath.kpPos := kppOnCrackBefore; - bcInfo.Deleted := True; - bcInfo.Pos := cpOnCrack; - end; {!!.05 - End} - - { Notify extenders of successful delete. } - NotifyExtenders(ffeaAfterRecDelete, ffeaNoAction); - end else - { Notify extenders of failed delete. } - NotifyExtenders(ffeaDeleteRecFail, ffeaNoAction); - end; - finally - bcOldRecBuff := nil; - end; -{Begin !!.01} - finally - { Release the record lock if an error occurred or we are in an implicit - transaction. } -{Begin !!.03} - if (Result <> DBIERR_NONE) or - bcDatabase.Transaction.IsImplicit then begin - Table.RelRecordLock(bcDatabase.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, LockedRefNr); {!!.05}{!!.10} - { Did an edit occur just prior to the delete? } - if not FFI64IsZero(bcLockedRefNum) then begin - Table.RelRecordLock(bcDatabase.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, bcLockedRefNum); {!!.10} - FFInitI64(bcLockedRefNum); - end; - end; -{End !!.03} - end; -{End !!.01} -end; -{Begin !!.06} -{--------} -function TffSrBaseCursor.DeleteRecords : TffResult; -var - aRecord : PffByteArray; - aTransID : TffTransID; -begin - - { Create a record buffer. } - FFGetMem(aRecord, bcTable.Dictionary.RecordLength); - try - { Position to BOF. } - SetToBegin; - - { Start a transaction. It will be nested if a transaction is already - in progress. } - Result := bcEngine.seTransactionStart(bcDatabase, False, True, aTransID); - try - while (Result = DBIERR_NONE) do begin - - { If on a record then get it otherwise move to the next - record. } - if bcInfo.Pos = cpOnRecord then begin - Result := GetRecord(aRecord, ffsltExclusive); - { Is a filter active? } - if Result = DBIERR_NOCURRREC then - { Yes. The current record didn't match the filter. Find the next - record that matches the filter. } - Result := GetNextRecord(aRecord, ffsltExclusive); - end - else - Result := GetNextRecord(aRecord, ffsltExclusive); - if Result = DBIERR_NONE then - Result := DeleteRecord(aRecord); - end; { while } - if Result = DBIERR_EOF then - Result := bcEngine.seTransactionCommit(bcDatabase) - else - bcEngine.seTransactionRollback(bcDatabase); - except - bcEngine.seTransactionRollback(bcDatabase); - raise; - end; - finally - FFFreeMem(aRecord, bcTable.Dictionary.RecordLength); - end; -end; -{End !!.06} -{--------} -function TffSrBaseCursor.Empty : TffResult; -begin - { Requirement: Transaction must be started. } - Assert(Assigned(bcDatabase.Transaction)); - - { The cursor must have Exclusive Read-Write access. } - Result := bcCheckExclusiveReadWrite; - if Result <> DBIERR_NONE then - exit; - - { Get the table to empty itself. } - AcqContentLock(ffclmWrite); - Result := bcTable.EmptyFiles(Database.TransactionInfo); -end; -{--------} -function TffSrBaseCursor.EnsureWritable(aCheckCurRec, aConditionalLock : Boolean) : TffResult; -begin - { The cursor must have been opened in read-write mode. } - if (bcOpenMode = omReadOnly) then begin - Result := DBIERR_TABLEREADONLY; - Exit; - end; - - { There cannot be any type of lock on the table (unless its ours and - is a write lock). } - if Table.btClientLocks.Count > 0 then - if Table.btClientLocks.SummaryMode = ffsltExclusive then begin - if not Table.HasClientLock(CursorID) then begin - Result := DBIERR_FILELOCKED; - Exit; - end; - end - else begin - Result := DBIERR_FILELOCKED; - Exit; - end; - - - { Make sure the cursor is positioned on a record. } - if aCheckCurRec then begin - if (bcInfo.pos <> cpOnRecord) then begin - Result := DBIERR_NOCURRREC; - Exit; - end; -// if Assigned(bcFilter) then begin {Deleted !!.02} - AcqContentLock(ffclmRead); - try - Table.GetRecord(Database.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, bcInfo.refNr, {!!.10} - bcRecordData, ffsltExclusive, false, aConditionalLock); {!!.02} - { Note: We assume we can ask for an Exclusive lock because this - method is passed True only from the Engine.RecordDelete and - Engine.RecordModify methods. } - if assigned(bcFilter) and {!!.02} - (not bcFilter.MatchesRecord(bcRecordData)) then begin {!!.02} - Result := DBIERR_NOCURRREC; - Exit; - end; - finally - RelContentLock(ffclmRead); - end; -// end; {Deleted !!.02} - end; - - { There must have been a transaction started for our owning database. } - if not assigned(Database.Transaction) then begin - Result := DBIERR_NOACTIVETRAN; - Exit; - end; - - Result := DBIERR_NONE; - -end; -{--------} -procedure TffSrBaseCursor.ReadAutoIncValue(var aValue: TffWord32); -begin - AcqContentLock(ffclmRead); - try - aValue := FFTblReadAutoIncValue(bcTable.Files[0], bcDatabase.TransactionInfo); - finally - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrBaseCursor.bcGetDictionary : TffDataDictionary; -begin - Result := Table.Dictionary; -end; -{--------} -function TffSrBaseCursor.GetRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; -begin - { Request a lock on the record prior to our testing any logic. We must - make sure that a delete in progress has finished before we make - any decisions. } -{Begin !!.03}{Begin !!.06} - if (bcInfo.pos = cpOnRecord) and (aLockType <> ffsltNone) then begin - { If there is a write lock on the table then return an error. } - if (bcTable.btClientLocks.Count > 0) then - { If table is write locked but not by this client then cannot obtain - a lock on the record. If table is read locked by any client then cannot - obtain a lock on the record. } - if Table.btClientLocks.SummaryMode = ffsltExclusive then begin - if (not bcTable.HasClientLock(CursorID)) then begin - Result := DBIERR_FILELOCKED; - Exit; - end; - end - else begin - Result := DBIERR_FILELOCKED; - Exit; - end; - - { Made it this far. Obtain the record lock. } - Table.GetRecordLock(bcDatabase.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, bcInfo.refNr, aLockType); {!!.10} - bcLockedRefNum := bcInfo.refNr; - end; { if } -{End !!.03}{End !!.06} - - if (bcInfo.pos = cpOnRecord) then begin - AcqContentLock(ffclmRead); - bcInfoLock.Lock; {!!.06} - try - Result := Table.GetRecord(bcDatabase.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, {!!.10} - bcInfo.refNr, aData, aLockType, true, false); {!!.02} - if Assigned(bcFilter) then begin - if not bcFilter.MatchesRecord(aData) then begin - { Release the record lock. } - Table.RelRecordLock(bcDatabase.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, bcInfo.RefNr); {!!.10} - Result := DBIERR_NOCURRREC; - Exit; - end; - end; -{Begin !!.02} - if (Result = DBIERR_NONE) and (aData <> nil) then - Move(aData^, bcRecordData^, bcRecordLen); -{End !!.02} - finally - bcInfoLock.Unlock; {!!.06} - RelContentLock(ffclmRead); - end; - end - else if bcInfo.pos = cpEOF then - Result := DBIERR_EOF - else if bcInfo.Deleted then - Result := DBIERR_KEYORRECDELETED - else - Result := DBIERR_NOCURRREC; -end; -{--------} -function TffSrBaseCursor.GetRecordField(aField : integer; - aRecordBuffer : PffByteArray; - var isNull: boolean; - aFieldBuffer : pointer) : TffResult; -begin - Result := DBIERR_NONE; - bcTable.Dictionary.GetRecordField(aField, aRecordBuffer, isNull, aFieldBuffer); -end; -{--------} -function TffSrBaseCursor.IsRecordLocked(aLockType : TffSrLockType) : Boolean; -begin - Result := bcTable.IsRecordLocked(Database.TransactionInfo, CursorID, - bcInfo.refNr, aLockType); -end; -{Begin !!.03} -{--------} -procedure TffSrBaseCursor.ListBLOBFreeSpace(aTI : PffTransInfo; - const aInMemory : Boolean; - aStream : TStream); -begin - Assert(bcTable <> nil); - bcTable.ListBLOBFreeSpace(aTI, aInMemory, aStream); -end; -{End !!.03} -{--------} -function TffSrBaseCursor.NotifyExtenders(const anAction : TffEngineAction; - const aFailAction : TffEngineAction) : TffResult; -var - anExtender : TffBaseEngineExtender; - anIndex : Longint; - anIndex2 : Longint; -begin - Result := DBIERR_NONE; - if assigned(bcExtenders) then - for anIndex := 0 to pred(bcExtenders.Count) do begin - anExtender := TffBaseEngineExtender - (TffIntListItem(bcExtenders[anIndex]).KeyAsInt); - if (anAction in anExtender.InterestedActions) or - (anExtender.InterestedActions = []) then begin - Result := anExtender.Notify(Self, anAction); {!!.06} - {since we aren't ignoring Notify's error code, we must - capture it. If an extender reports an error we will not - process the rest of the extenders and we will notify the - previous extenders that we are "undoing" the previous action} - if Result <> DBIERR_NONE then begin - for anIndex2 := 0 to pred(anIndex) do begin - anExtender := TffBaseEngineExtender - (TffIntListItem(bcExtenders[anIndex2]).KeyAsInt); - anExtender.Notify(self, aFailAction); - end; - break; - end; - end; - end; -end; -{--------} -function TffSrBaseCursor.OverrideFilter(aExpression : pCANExpr; - aTimeout : TffWord32) - : TffResult; -begin - Result := DBIERR_NONE; - try - bcFilterSav := bcFilter; - bcFilter := nil; - if Assigned(aExpression) then - bcFilter := TffSrFilter.Create(self, bcTable.Dictionary, {!!.11} - aExpression, - aTimeout); - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, - bcEngine.FEventLog, - bcEngine.bseGetReadOnly); - end; - end; -end; -{--------} -procedure TffSrBaseCursor.RelContentLock(aMode : TffContentLockMode); -begin - if (fffaBLOBChainSafe in bcGetAttribs) or {!!.05} - (bcExclOwner and (not bcTable.Dictionary.HasBLOBFields)) then {!!.03}{!!.05} - Exit; - - Assert(assigned(bcDatabase.Transaction) or (aMode = ffclmRead)); - - if assigned(bcDatabase.Transaction) then begin - { Content locks obtained by a transaction via AcqContentLock are freed when - the transaction's locks are released. } - if aMode = ffclmCommit then - bcTable.EndCommit(bcDatabase.DatabaseID); - end else begin {!!.05 - Start} - InterlockedDecrement(bcNumReadLocks); - { If the number of read locks ever goes below 0, it's outta whack.} - Assert(bcNumReadLocks >= 0); - if (bcNumReadLocks = 0) then - bcTable.EndRead; - end; {!!.05 - End} -end; -{--------} -procedure TffSrBaseCursor.RelRecordLock(aAllLocks : boolean); -begin - Assert((not aAllLocks), 'Unsupported: Release all record locks for a cursor'); -{Begin !!.03} - if not FFI64IsZero(bcInfo.refNr) then begin - bcTable.RemoveLocksForCursor(bcDatabase.DatabaseID, {!!.10} - CursorID, bcInfo.refNr, {!!.10} - bcDatabase.TransactionInfo); {!!.10} - if FFCmpI64(bcInfo.refNr, bcLockedRefNum) = 0 then - FFInitI64(bcLockedRefNum); - end; -{End !!.03} -end; -{--------} -procedure TffSrBaseCursor.RelTableLock(aAllLocks : Boolean); -begin - bcTable.RelLock(CursorID, aAllLocks); -end; -{--------} -procedure TffSrBaseCursor.RemoveIfUnused; {!!.05 - Added} -begin - if (State = ffosClosing) then - Free; -end; {!!.05 - End added} -{--------} -function TffSrBaseCursor.RestoreFilter : TffResult; -begin - Result := DBIERR_NONE; - try - bcFilter.Free; - bcFilter := bcFilterSav; - bcFilterSav := nil; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, - bcEngine.FEventLog, - bcEngine.bseGetReadOnly); - end; - end; -end; -{--------} -procedure TffSrBaseCursor.SetAutoIncValue(aValue: TffWord32); -begin - AcqContentLock(ffclmWrite); - FFTblSetAutoIncValue(bcTable.Files[0], bcDatabase.TransactionInfo, aValue); -end; -{--------} -function TffSrBaseCursor.SetFilter(aExpression : pCANExpr; - aTimeout : TffWord32) : TffResult; - -begin - Result := DBIERR_NONE; - try - bcFilter.Free; - bcFilter := nil; - if Assigned(aExpression) then - bcFilter := TffSrFilter.Create(self, bcTable.Dictionary, {!!.11} - aExpression, aTimeout); {!!.11} - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, bcEngine.EventLog, bcEngine.bseGetReadOnly); - end; - end; -end; -{Begin !!.01} -{--------} -function TffSrBaseCursor.ShouldClose : boolean; -begin - Result := (bcDatabase.Transaction = nil) and (soState = ffosClosing); -end; -{End !!.01} -{--------} -function TffSrBaseCursor.SortRecords(aFieldsArray : TffFieldList; - const aOrderByArray : TffOrderByArray; - const aNumFields : integer) : TffResult; -var - aRecord : PffByteArray; - aTransID : TffTransID; - RecLen : Longint; - SortEngine : TffSrBaseSortEngine; -begin - - { The cursor must have Exclusive Read-Write access. } - Result := bcCheckExclusiveReadWrite; - if Result <> DBIERR_NONE then - exit; - - { Create the sort engine. } - SortEngine := ffcSortEngineClass.Create(bcEngine, bcDatabase, aFieldsArray, - aOrderByArray, aNumFields, - bcTable.Dictionary, bcIndexID); - RecLen := bcTable.Dictionary.RecordLength; - FFGetMem(aRecord, RecLen); - try - { Start a transaction. } - bcEngine.seTransactionStart(bcDatabase, false, true, aTransID); - try - { Position to the beginning of the table. } - Result := DBIERR_NONE; - SetToBegin; - - { Walk through the records, posting them to the sort engine. } - while (Result = DBIERR_NONE) do begin - Result := GetNextRecord(aRecord, ffsltNone); - if Result = DBIERR_NONE then begin - SortEngine.Put(aRecord); - end; - end; - bcEngine.seTransactionCommit(bcDatabase); - except - bcEngine.seTransactionRollback(bcDatabase); - raise; - end; - - bcEngine.seTransactionStart(bcDatabase, false, true, aTransID); - try -{Begin !!.01} - { Empty the table. } -// Result := Empty; -// if Result = DBIERR_NONE then begin - { Position to start of table. We will overwrite existing records - in order to preserve BLOB data. } - Result := DBIERR_NONE; - SetToBegin; - { Read the records back from the sort engine. } - while (Result = DBIERR_NONE) do begin - if SortEngine.Get(aRecord) then begin - GetNextRecord(nil, ffsltNone); - Result := ModifyRecord(aRecord, true); - end - else - break; - end; -// end; -{End !!.01} - bcEngine.seTransactionCommit(bcDatabase); - except - { Rollback if an exception occurs. } - bcEngine.seTransactionRollback(bcDatabase); - raise; - end; - finally - FFFreeMem(aRecord, RecLen); - SortEngine.Free; - end; - - SetToBegin; - -end; -{====================================================================} - -{===TffSrCursor======================================================} -constructor TffSrCursor.Create(anEngine : TffServerEngine; - aDatabase : TffSrDatabase; - const aTimeout : Longint); -begin - bcTableClass := TffSrTable; - inherited Create(anEngine, aDatabase, aTimeout); -end; -{--------} -destructor TffSrCursor.Destroy; -begin - - { Notify extenders. } - NotifyExtenders(ffeaBeforeCursorClose, ffeaNoAction); - -{Begin !!.02} - bcEngine.TableList.BeginRead; - try - { If we exclusively opened the table then remove the mark from the - table. } - if bcExclOwner then begin - bcTable.SetExclOwner(ffc_W32NoValue); - bcExclOwner := False; - end; - - { Free the table locks held by the cursor. } - if assigned(bcTable) then - bcTable.RelLock(CursorID, True); - finally - bcEngine.TableList.EndRead; - end; -{End !!.02} - -// if (bcRecordData <> nil) then {!!.01} -// FFFreeMem(bcRecordData, bcRecordLen); {!!.01} - if (bcRng1Key <> nil) then begin - FFFreeMem(bcRng1Key, scKeyLen); - bcRng1Key := nil; - end; - if (bcRng2Key <> nil) then begin - FFFreeMem(bcRng2Key, scKeyLen); - bcRng2Key := nil; - end; - if (bcCurKey <> nil) then begin - FFFreeMem(bcCurKey, scKeyLen); - bcCurKey := nil; - end; - bcFilter.Free; - bcFilter := nil; - bcFilterSav.Free; - bcFilterSav := nil; - inherited Destroy; -end; -{--------} -function TffSrCursor.AddIndexToTable(const aIndexDesc : TffIndexDescriptor) : TffResult; -begin - - { The cursor must have Exclusive Read-Write access. } - Result := bcCheckExclusiveReadWrite; - if Result <> DBIERR_NONE then - exit; - - { The index descriptor cannot be a user-defined index. } - if (aIndexDesc.idCount = -1) then begin - Result := DBIERR_INVALIDINDEXTYPE; - Exit; - end; - - { The index descriptor must be valid. } - if not Table.Dictionary.IsIndexDescValid(aIndexDesc) then begin - Result := DBIERR_INVALIDIDXDESC; - Exit; - end; - - { The index name cannot already exist. } - if (Table.Dictionary.GetIndexFromName(aIndexDesc.idName) <> -1) then begin - Result := DBIERR_INDEXEXISTS; - Exit; - end; - - { There must be room for the new index. } - if (Table.Dictionary.IndexCount = ffcl_MaxIndexes) then begin - Result := DBIERR_INDEXLIMIT; - Exit; - end; - - { Let the table do its stuff. } - Result := DBIERR_NONE; - AcqContentLock(ffclmWrite); - Table.AddIndex(aIndexDesc, Database.TransactionInfo) -end; -{--------} -procedure TffSrCursor.bcInit(const aOpenMode : TffOpenMode; - const aShareMode : TffShareMode; - const aExclContLock : Boolean); {!!.10} -begin - inherited bcInit(aOpenMode, aShareMode, aExclContLock); {!!.10} - - { Resolve any special build key and compare key routine links - (i.e., user-defined indexes) for the new table. } - {TffSrTable(bcTable).ResolveDynamicLinks;} {!!.06} - - { Get our work areas for the key. } - bcKID.kidCompareData := @bcCompareData; - scKeyLen := bcTable.Dictionary.IndexKeyLength[bcIndexID]; - FFGetMem(bcCurKey, scKeyLen); - FFGetMem(bcRng1Key, scKeyLen); - FFGetMem(bcRng2Key, scKeyLen); - - { Initialise our key index data record. } - bcTable.MakeKIDForCursor(bcIndexID, bcKID); - - { Set up the position of the cursor to BOF. } - SetToBegin; -end; -{--------} -procedure TffSrCursor.bcTableOpenPreconditions(aTable : TffSrBaseTable; - const aIndexName : string; - var aIndexID : Longint; - const aOpenMode : TffOpenMode); -begin - - { Validate the index information; if the index name is non-blank - it must exist and will supercede the index number; if the index - name is blank the index number must exist} - if (aIndexName <> '') then begin - aIndexID := aTable.Dictionary.GetIndexFromName(aIndexName); - if (aIndexID = -1) then - FFRaiseException(EffException, ffStrResServer, fferrUnknownIndex, - [aTable.BaseName, aIndexName, aIndexID]); - end - else if (0 > aIndexID) or (aIndexID >= aTable.Dictionary.IndexCount) then - FFRaiseException(EffException, ffStrResServer, fferrUnknownIndex, - [aTable.BaseName, aIndexName, aIndexID]); - - { If the table's data file is open in read-only mode it means the - physical file is read-only: hence this call's openmode must be - read-only as well. } - if (aTable.Files[0]^.fiOpenMode = omReadOnly) and - (aOpenMode <> omReadOnly) then - FFRaiseException(EffException, ffStrResServer, fferrCursorReadOnly, - [aTable.BaseName]); - -end; -{--------} -function TffSrCursor.CheckBookmark(aBookmark : PffByteArray) : TffResult; -var - CheckHash : Longint; -begin - Result := DBIERR_INVALIDBOOKMARK; - if (aBookmark = nil) then - Exit; - with PffSrBookmark(aBookmark)^ do begin - if (sbIndexID <> IndexID) then - Exit; - if (sbKeyLen <> scKeyLen) then - Exit; - CheckHash := FFCalcElfHash(sbIndexID, - ffcl_FixedBookmarkSize - sizeof(sbHash) + sbKeyLen); - if (sbHash <> CheckHash) then - Exit; - end; - Result := DBIERR_NONE; -end; -{--------} -procedure TffSrCursor.ClearIndex; -begin - with bcCompareData do begin - cdFldCnt := 0; - cdPartLen := 0; - end; - AcqContentLock(ffclmWrite); - FFTblDeleteAllKeys(Database.TransactionInfo, bcKID); -end; -{--------} -function TffSrCursor.CloneCursor(aOpenMode : TffOpenMode) : TffSrBaseCursor; -begin - {NOTE: we are not checking rights for this action because the client - had the rights to open the cursor} - - { Resolve the open mode. } - if (bcOpenMode = omReadOnly) then - aOpenMode := omReadOnly; - - { Create the cursor. } - Result := bcEngine.CursorClass.Create(bcEngine, {!!.06} - bcDatabase, - soTimeout); - Result.Open(bcTable.BaseName , '', bcIndexID, aOpenMode, smShared, - bcTable.IsServerTable, False, []); - - AcqContentLock(ffclmRead); - try - { Set up all of the position, range, etc, fields. } - Result.bcKID := bcKID; - Result.bcKID.kidCompareData := @Result.bcCompareData; - Result.bcCompareData := bcCompareData; - Result.bcInfo := bcInfo; - if bcInfo.KeyValid then - Move(bcCurKey^, Result.bcCurKey^, scKeyLen); - Result.bcHasRange := bcHasRange; - if bcHasRange then begin - Result.bcRng1Valid := bcRng1Valid; - if bcRng1Valid then begin - Move(bcRng1Key^, Result.bcRng1Key^, scKeyLen); - Result.bcRng1FldCnt := bcRng1FldCnt; - Result.bcRng1PtlLen := bcRng1PtlLen; - Result.bcRng1Incl := bcRng1Incl; - end; - Result.bcRng2Valid := bcRng2Valid; - if bcRng2Valid then begin - Move(bcRng2Key^, Result.bcRng2Key^, scKeyLen); - Result.bcRng2FldCnt := bcRng2FldCnt; - Result.bcRng2PtlLen := bcRng2PtlLen; - Result.bcRng2Incl := bcRng2Incl; - end; - end; - if Assigned(bcFilter) then - Result.SetFilter(bcFilter.Expression,bcFilter.Timeout); - finally - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrCursor.CompareBookmarks(aBookmark1, aBookmark2 : PffByteArray; - var CmpResult : Longint) : TffResult; -var - BM1 : PffSrBookmark absolute aBookmark1; - BM2 : PffSrBookmark absolute aBookmark2; -begin - Result := CheckBookmark(aBookmark1); - if (Result = DBIERR_NONE) then - Result := CheckBookmark(aBookmark2); - if (Result <> DBIERR_NONE) then - Exit; - case BM1^.sbPos of - cpUnknown : CmpResult := -1; - cpBOF : if (BM2^.sbPos = cpBOF) then - CmpResult := 0 - else - CmpResult := -1; - cpEOF : if (BM2^.sbPos = cpEOF) then - CmpResult := 0 - else - CmpResult := 1; - else - {bookmark 1 is on a crack or on a record} - case BM2^.sbPos of - cpUnknown : CmpResult := 1; - cpBOF : CmpResult := 1; - cpEOF : CmpResult := -1; - else - {bookmark 2 is also on a crack or on a record} - {check the reference numbers, if equal the key ought to be} - if (ffCmpI64(BM1^.sbRefNr, BM2^.sbRefNr) = 0) then - CmpResult := 0 - else begin - {compare the keys} - with bcCompareData do begin - cdFldCnt := 0; - cdPartLen := 0; - end; - CmpResult := Table.CompareKeysForCursor(bcKID, - PffByteArray(@BM1^.sbKey), - PffByteArray(@BM2^.sbKey)); - if (CmpResult = 0) then - if (ffCmpI64(BM1^.sbRefNr, BM2^.sbRefNr) = -1) then - CmpResult := -1 - else - CmpResult := 1; - end; - end;{case} - end;{case} -end; -{--------} -function TffSrCursor.DropIndexFromTable(const aIndexName : TffDictItemName; - aIndexID : Longint) : TffResult; -var - CompareData : TffCompareData; - KID : TffKeyIndexData; -begin - - {if the index name is set, convert to an index ID} - if (aIndexName <> '') then - aIndexID := Table.Dictionary.GetIndexFromName(aIndexName); - - {check the index number (count index 0 as invalid as well)} - if (aIndexID <= 0) or (aIndexID >= Table.Dictionary.IndexCount) then begin - Result := DBIERR_NOSUCHINDEX; - Exit; - end; - - {the index number cannot be our index number} - if (aIndexID = IndexID) then begin - Result := DBIERR_ACTIVEINDEX; - Exit; - end; - - { The cursor must have Exclusive Read-Write access. } - Result := bcCheckExclusiveReadWrite; - if Result <> DBIERR_NONE then - exit; - - { Delete all the keys and then drop the index. } - Result := DBIERR_NONE; - KID.kidCompareData := @CompareData; - Table.MakeKIDForCursor(aIndexID, KID); - AcqContentLock(ffclmWrite); - FFTblDeleteAllKeys(Database.TransactionInfo, KID); - Table.DropIndex(Database.TransactionInfo, aIndexID); - -end; -{--------} -function TffSrCursor.ExtractKey(aData : PffByteArray; aKey : PffByteArray) : TffResult; -begin - Result := DBIERR_NOCURRREC; - if (aData = nil) and (bcInfo.pos = cpOnRecord) then begin - aData := bcRecordData; - AcqContentLock(ffclmRead); - try - Table.GetRecord(bcDatabase.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, bcInfo.refNr, aData, {!!.10} - ffsltNone, false, false); {!!.02} - finally - RelContentLock(ffclmRead); - end; - if Assigned(bcFilter) then - if not bcFilter.MatchesRecord(aData) then - aData := nil; - end; - if (aData <> nil) then begin - Result := Table.BuildKeyForRecord(IndexID, aData, aKey, 0, 0); - end; -end; -{--------} -function TffSrCursor.GetBookmark(aBookmark : PffByteArray) : TffResult; -begin - Result := DBIERR_NONE; - AcqContentLock(ffclmRead); - try - FillChar(PffSrBookmark(aBookmark)^, ffcl_FixedBookmarkSize, 0); - with PffSrBookmark(aBookmark)^ do begin - sbIndexID := IndexID; - sbPos := bcInfo.pos; - sbKeyValid := bcInfo.KeyValid; - sbRefNr := bcInfo.refNr; - sbKeyLen := scKeyLen; - if bcInfo.KeyValid then - Move(bcCurKey^, sbKey, scKeyLen) - else - FillChar(sbKey, scKeyLen, 0); - sbHash := FFCalcElfHash(sbIndexID, - ffcl_FixedBookmarkSize - sizeof(sbHash) + sbKeyLen); - end; - finally - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrCursor.GetBookmarkSize : integer; -begin - Result := ffcl_FixedBookmarkSize + scKeyLen; -end; -{--------} -function TffSrCursor.GetNextRecord(aData : PffByteArray; - aLockType : TffSrLockType) : TffResult; -var - KeyCompareResult : integer; - Action : TffSearchKeyAction; -begin - { If we are at EOF, then obviously there's no next record. } - if (bcInfo.pos = cpEOF) then begin - Result := DBIERR_EOF; - Exit; - end; - - AcqContentLock(ffclmRead); - bcInfoLock.Lock; {!!.06} - try - { If our position is at BOF and we have a range active, position the - index at the start of the range} - if (bcInfo.pos = cpBOF) and bcHasRange and bcRng1Valid then begin - { Position at start of range. } - if bcRng1Incl then - Action := skaGreaterEqual - else - Action := skaGreater; - { Note: the following call will always return true in this case. } - Move(bcRng1Key^, bcCurKey^, scKeyLen); - with bcCompareData do begin - cdFldCnt := bcRng1FldCnt; - cdPartLen := bcRng1PtlLen; - end; - Table.FindKey(bcKID, bcInfo.refNr, Database.TransactionInfo, - bcCurKey, bcInfo.KeyPath, Action); - - { Is the keypath positioned at EOF? } - if (bcInfo.KeyPath.kpPos = kppEOF) then begin - {Yes. The start of the range is at EOF, so it's not likely we'll find a - 'next record <g>. } - Result := DBIERR_EOF; - SetToEnd; - Exit; - end; - - { Make sure the keypath is on the crack before the key so that the next - key call returns the right record. } - if (bcInfo.KeyPath.kpPos = kppOnKey) then begin - Assert(bcInfo.keyPath.kpCount > 0); - bcInfo.KeyPath.kpPos := kppOnCrackBefore; - end; - - end - { Otherwise do we need to rebuild the key path? } - else if (not bcIsCurKeyPathValid) then - bcRebuildKeyPath; {!!.05} - - { Make sure that we have somewhere to read the record into. } - if (aData = nil) then - aData := bcRecordData; - - { Get the next record. } - with bcCompareData do begin - cdFldCnt := 0; - cdPartLen := 0; - end; - - if Assigned(bcFilter) then - bcFilter.BeginTimeout; - repeat - Result := bcTable.GetNextRecord(bcDatabase.TransactionInfo, - bcDatabase.DatabaseID, {!!.10} - CursorID, bcKID, bcInfo.refNr, bcCurKey, - bcInfo.KeyPath, aData, aLockType); - if (Result <> DBIERR_NONE) then begin - if (Result = DBIERR_EOF) then - SetToEnd; - Exit; - end; - {in theory we're on a record} - bcInfo.Deleted := False; - bcInfo.KeyValid := True; - bcInfo.pos := cpOnRecord; - {check that we're in range if required} - if bcHasRange and bcRng2Valid then begin - {check whether beyond end of range} - with bcCompareData do begin - cdFldCnt := bcRng2FldCnt; - cdPartLen := bcRng2PtlLen; - end; - KeyCompareResult := bcTable.CompareKeysForCursor(bcKID, bcCurKey, bcRng2Key); - if (KeyCompareResult > 0) or - ((KeyCompareResult = 0) and (not bcRng2Incl)) then begin - Result := DBIERR_EOF; - SetToEnd; - end; - end; -{Begin !!.03} -// until (Result <> DBIERR_NONE) or not Assigned(bcFilter) or -// bcFilter.MatchesRecord(aData) or bcFilter.CheckTimeout(Result); - until (Result <> DBIERR_NONE) or ((not Assigned(bcFilter) or - bcFilter.MatchesRecord(aData) or bcFilter.CheckTimeout(Result)) and - (not Assigned(bcFilterSav) or bcFilterSav.MatchesRecord(aData))); -{End !!.03} - - { Place the lock if needed... record will not be read again} -{Begin !!.02} - if (Result = DBIERR_NONE) then begin - if aData <> bcRecordData then - Move(aData^, bcRecordData^, bcRecordLen); - if (aLockType <> ffsltNone) then - Result := bcTable.GetRecord(bcDatabase.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, {!!.10} - bcInfo.refNr, nil, aLockType, false, false); {!!.02} - end; -{End !!.02} - finally - bcInfoLock.Unlock; {!!.06} - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrCursor.GetPriorRecord(aData : PffByteArray; aLockType : TffSrLockType) : TffResult; -var - KeyCompareResult : integer; - Action : TffSearchKeyAction; -begin - - { If we are at BOF, then obviously there's no prior record. } - if (bcInfo.pos = cpBOF) then begin - Result := DBIERR_BOF; - Exit; - end; - - AcqContentLock(ffclmRead); - bcInfoLock.Lock; {!!.06} - try - { If our position is at EOF and we have a range active, position the - index at the end of the range. } - if (bcInfo.pos = cpEOF) and bcHasRange and bcRng2Valid then begin - { Position at end of range. } - if bcRng2Incl then - Action := skaGreater - else - Action := skaGreaterEqual; - - { Note: the following call will always return true in this case. } - Move(bcRng2Key^, bcCurKey^, scKeyLen); - with bcCompareData do begin - cdFldCnt := bcRng2FldCnt; - cdPartLen := bcRng2PtlLen; - end; - bcTable.FindKey(bcKID, bcInfo.refNr, bcDatabase.TransactionInfo, - bcCurKey, bcInfo.KeyPath, Action); - end - { Otherwise, do we need to rebuild the key path? } - else if (not bcIsCurKeyPathValid) then - bcRebuildKeyPath; {!!.05} - - { Make sure that we have somewhere to read the record into. } - if (aData = nil) then - aData := bcRecordData; - - { Get the previous record. } - with bcCompareData do begin - cdFldCnt := 0; - cdPartLen := 0; - end; - - if Assigned(bcFilter) then - bcFilter.BeginTimeout; - repeat - Result := bcTable.GetPriorRecord(bcDatabase.TransactionInfo, - bcDatabase.DatabaseID, {!!.10} - CursorID, bcKID, - bcInfo.refNr, bcCurKey, - bcInfo.KeyPath, aData, ffsltNone); - if (Result <> DBIERR_NONE) then begin - if (Result = DBIERR_BOF) then - SetToBegin; - Exit; - end; - - { In theory we're on a record. } - bcInfo.Deleted := false; - bcInfo.KeyValid := true; - bcInfo.pos := cpOnRecord; - - { Check that we're in range if required. } - if bcHasRange and bcRng1Valid then begin - {check whether beyond start of range} - with bcCompareData do begin - cdFldCnt := bcRng1FldCnt; - cdPartLen := bcRng1PtlLen; - end; - KeyCompareResult := bcTable.CompareKeysForCursor(bcKID, bcCurKey, bcRng1Key); - if (KeyCompareResult < 0) or - ((KeyCompareResult = 0) and (not bcRng1Incl)) then begin - Result := DBIERR_BOF; - SetToBegin; - end; - end; - until (Result <> DBIERR_NONE) or not Assigned(bcFilter) or - bcFilter.MatchesRecord(aData) or bcFilter.CheckTimeout(Result); - - { Place the lock if needed... record will not be read again. } -{Begin !!.02} - if (Result = DBIERR_NONE) then begin - if aData <> bcRecordData then - Move(aData^, bcRecordData^, bcRecordLen); - if (aLockType <> ffsltNone) then - Result := bcTable.GetRecord(bcDatabase.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, {!!.10} - bcInfo.refNr, nil, aLockType, false, false); {!!.02} - end; -{End !!.02} - finally - bcInfoLock.Unlock; {!!.06} - RelContentLock(ffclmRead); - end; - -end; -{--------} -function TffSrCursor.GetRecordCount(var aRecCount : Longint) : TffResult; -var - Action : TffSearchKeyAction; - KeyCompareResult : integer; - SavedKey : PffByteArray; - Info : TffRecordInfo; -begin - Result := DBIERR_NONE; - AcqContentLock(ffclmRead); - try - if bcHasRange or Assigned(bcFilter) then begin - {set count to zero} - aRecCount := 0; - {save the current position} - bcSaveCurInfo; - FFGetMem(SavedKey, bcKID.kidCompareData^.cdKeyLen); {!!.06} - try - Move(bcCurKey^, SavedKey^, bcKID.kidCompareData^.cdKeyLen); - {BOF} - SetToBegin; - if bcHasRange and bcRng1Valid then begin - {position at start of range} - if bcRng1Incl then - Action := skaGreaterEqual - else - Action := skaGreater; - {note: the following FindKey call will always return true in - this case} - Move(bcRng1Key^, bcCurKey^, scKeyLen); - with bcCompareData do begin - cdFldCnt := bcRng1FldCnt; - cdPartLen := bcRng1PtlLen; - end; - Table.FindKey(bcKID, bcInfo.refNr, Database.TransactionInfo, bcCurKey, - bcInfo.KeyPath, Action); - {check whether the keypath was positioned at EOF, if so the - start of the range is at EOF, so it's not likely we'll find a - 'next' key or any keys at all <g>} - if (bcInfo.KeyPath.kpPos = kppEOF) then begin - {note the reset of the cursor position still occurs} - Exit; - end; - {make sure that the keypath is on the crack before the key so that - the next key call in a minute returns the right record} - if (bcInfo.KeyPath.kpPos = kppOnKey) then begin - Assert(bcInfo.KeyPath.kpCount > 0); - bcInfo.KeyPath.kpPos := kppOnCrackBefore; - end; - end; - {while not EOF or other error do} - while (Result = DBIERR_NONE) do begin -{Begin !!.05} - { Check for timeout. } - if FFGetRetry < GetTickCount then - FFRaiseExceptionNoData(EffServerException, ffStrResServer, - fferrGeneralTimeout); -{End !!.05} - {readnext key} - Result := Table.GetNextKey(bcKID, bcInfo.refNr, Database.TransactionInfo, - bcCurKey, bcInfo.KeyPath); - if (Result = DBIERR_NONE) then begin - {check that we're in range if required} - if bcHasRange and bcRng2Valid then begin - {check whether beyond end of range} - with bcCompareData do begin - cdFldCnt := bcRng2FldCnt; - cdPartLen := bcRng2PtlLen; - end; - KeyCompareResult := - Table.CompareKeysForCursor(bcKID, bcCurKey, bcRng2Key); - if (KeyCompareResult > 0) or - ((KeyCompareResult = 0) and (not bcRng2Incl)) then begin - Result := DBIERR_EOF; - end - else {key is in range} begin - if Assigned(bcFilter) then begin - Table.GetRecord(bcDatabase.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, bcInfo.refNr, {!!.10} - bcRecordData, ffsltNone, false, false); {!!.02} - if bcFilter.MatchesRecord(bcRecordData) then - inc(aRecCount); - end else - inc(aRecCount); - end; - end - else {end of range = end of index path} begin - if Assigned(bcFilter) then begin - Table.GetRecord(bcDatabase.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, bcInfo.refNr, {!!.10} - bcRecordData, ffsltNone, false, false); {!!.02} - if bcFilter.MatchesRecord(bcRecordData) then - inc(aRecCount); - end else - inc(aRecCount); - end; - end; - end; - Result := DBIERR_NONE; - {endwhile} - finally - {reset current position} - bcRestoreCurInfo; - Move(SavedKey^, bcCurKey^, bcKID.kidCompareData^.cdKeyLen); - FFFreeMem(SavedKey, bcKID.kidCompareData^.cdKeyLen); {!!.06} - end; - end - else begin - FFTblGetRecordInfo(Table.Files[0], Database.TransactionInfo, Info); - aRecCount := Info.riRecCount; - end; - finally - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrCursor.GetRecordForKey(aDirectKey : boolean; - aFieldCount : integer; - aPartialLen : integer; - aKeyData : PffByteArray; - aData : PffByteArray; - aFirstCall : Boolean) : TffResult; -var - Action : TffSearchKeyAction; - aTI : PffTransInfo; - RecFound : boolean; - KeyToFind : PffByteArray; - TmpCompareData : TffCompareData; {!!.11} -begin - {calculate the key} - if aDirectKey then - Move(aKeyData^, bcCurKey^, scKeyLen) - else if (IndexID = 0) then begin - Result := DBIERR_INVALIDINDEXTYPE; - Exit; - end - else begin - Result := Table.BuildKeyForRecord(IndexID, aKeyData, bcCurKey, aFieldCount, - aPartialLen); - if (Result <> DBIERR_NONE) then - Exit; - end; - - AcqContentLock(ffclmRead); - bcInfoLock.Lock; {!!.06} - try - {now position the index on that exact key or the one that partially - matches it} - if aFirstCall then begin - FFInitKeyPath(bcInfo.KeyPath); - bcInfo.refNr.iLow := 0; - bcInfo.refNr.iHigh := 0; - bcInfo.Deleted := false; - end; - Action := skaEqual; - {try to find the exact or partial key} - with bcCompareData do begin - cdFldCnt := aFieldCount; - cdPartLen := aPartialLen; - end; - - Result := DBIERR_NONE; - aTI := Database.TransactionInfo; - KeyToFind := nil; - try - // we need a copy of the key - if Assigned(bcFilter) or (not aFirstCall) then begin - FFGetMem(KeyToFind, scKeyLen); - Move(bcCurKey^, KeyToFind^, scKeyLen) - end; - - if Assigned(bcFilter) then begin - if aData = nil then - aData := bcRecordData; - bcFilter.BeginTimeout; - end; - repeat - if aFirstCall then begin - RecFound := Table.FindKey(bcKID, bcInfo.refNr, aTI, - bcCurKey, bcInfo.KeyPath, Action); - aFirstCall := False; - end else begin - RecFound := (Table.GetNextKey(bcKID, bcInfo.refNr, aTI, - bcCurKey, bcInfo.KeyPath) = DBIERR_NONE) and - (Table.CompareKeysForCursor(bcKID, bcCurKey, KeyToFind) = 0); - end; - - if RecFound then begin - TmpCompareData := bcCompareData; {!!.11} - if IsInRange(bcCurKey) <> 0 then begin {!!.11} - bcCompareData := TmpCompareData; {!!.11} - Result := DBIERR_RECNOTFOUND; {!!.11} - end else begin {!!.11} - bcCompareData := TmpCompareData; {!!.11} - if Assigned(aData) then - Table.GetRecord(aTI, bcDatabase.DatabaseID, {!!.10} - CursorID, bcInfo.refNr, aData, ffsltNone,{!!.10} - false, false); {!!.02} - bcInfo.KeyValid := true; - bcInfo.pos := cpOnRecord; - end - end else - Result := DBIERR_RECNOTFOUND; - until (Result <> DBIERR_NONE) or {!!.11} - ((not Assigned(bcFilter)) or {!!.11} - bcFilter.MatchesRecord(aData) or {!!.11} - bcFilter.CheckTimeout(Result)); {!!.11} - - { If we didn't find the key then set to the end of the dataset. } - if Result = DBIERR_RECNOTFOUND then - SetToEnd; - finally - if Assigned(KeyToFind) then - FFFreeMem(KeyToFind, scKeyLen); - end; - finally - bcInfoLock.Unlock; {!!.06} - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrCursor.InsertRecord(aData : PffByteArray; - aLockType : TffSrLockType) : TffResult; -var - NewRefNr : TffInt64; - SavInfo : TffSrCursorInfo; {!!.12} - SavKey : PffByteArray; {!!.12} -begin - { Notify extenders. } - bcNewRecBuff := aData; - SavKey := nil; {!!.12} - try - Result := NotifyExtenders(ffeaBeforeRecInsert, ffeaInsertRecFail); - - if Result = DBIERR_NONE then begin - AcqContentLock(ffclmWrite); - Result := bcTable.InsertRecord(bcDatabase.TransactionInfo, - CursorID, aData, aLockType, NewRefNr); - if (Result = DBIERR_NONE) then begin -{Begin !!.12} - { If a range is active then save the current key & cursor information. - We may need to reposition the cursor to its original position if - the inserted record does not fit into the range. } - if bcHasRange then begin - FFGetMem(SavKey, scKeyLen); - Move(bcCurKey^, SavKey^, scKeyLen); - SavInfo := bcInfo; - end; - - FFInitKeyPath(bcInfo.KeyPath); - bcInfo.pos := cpOnRecord; - bcInfo.refNr := NewRefNr; - bcInfo.Deleted := false; - scRebuildCurKey(aData, true); - if bcHasRange and (IsInRange(bcCurKey) <> 0) then begin - bcInfo := SavInfo; - Move(SavKey^, bcCurKey^, scKeyLen); - end; -{End !!.12} - bcTable.RelaxRecordLock(bcDatabase.TransactionInfo, CursorID, {!!.10} - bcInfo.RefNr); {!!.10} - - { Notify extenders of successful insert. } - NotifyExtenders(ffeaAfterRecInsert, ffeaNoAction); - end else - { Notify extenders of failed insert. } - NotifyExtenders(ffeaInsertRecFail, ffeaNoAction); - end; - finally - if SavKey <> nil then {!!.12} - FFFreeMem(SavKey, scKeyLen); {!!.12} - bcNewRecBuff := nil; - end; -end; -{--------} -function TffSrCursor.InsertRecordNoDefault(aData : PffByteArray; {!!.10} - aLockType : TffSrLockType) : TffResult; -var - NewRefNr : TffInt64; -begin - { Notify extenders. } - bcNewRecBuff := aData; - try - Result := NotifyExtenders(ffeaBeforeRecInsert, ffeaInsertRecFail); - - if Result = DBIERR_NONE then begin - AcqContentLock(ffclmWrite); - Result := bcTable.InsertRecordNoDefault(bcDatabase.TransactionInfo,{!!.10} - CursorID, aData, aLockType, - NewRefNr); - if (Result = DBIERR_NONE) then begin - FFInitKeyPath(bcInfo.KeyPath); - bcInfo.pos := cpOnRecord; - bcInfo.refNr := NewRefNr; - bcInfo.Deleted := false; - scRebuildCurKey(aData, true); - bcTable.RelaxRecordLock(bcDatabase.TransactionInfo, CursorID, {!!.10} - bcInfo.RefNr); {!!.10} - - { Notify extenders of successful insert. } - NotifyExtenders(ffeaAfterRecInsert, ffeaNoAction); - end else - { Notify extenders of failed insert. } - NotifyExtenders(ffeaInsertRecFail, ffeaNoAction); - end; - finally - bcNewRecBuff := nil; - end; -end; -{--------} -function TffSrCursor.IsInRange(aKey : PffByteArray) : integer; -var - KeyCompareResult : integer; -begin - Result := 0; - if not bcHasRange then - Exit; - if bcRng1Valid then begin - with bcCompareData do begin - cdFldCnt := bcRng1FldCnt; - cdPartLen := bcRng1PtlLen; - end; - KeyCompareResult := Table.CompareKeysForCursor(bcKID, aKey, bcRng1Key); - if (KeyCompareResult < 0) then begin - Result := -1; - Exit; - end; - if (KeyCompareResult = 0) then begin - if not bcRng1Incl then - Result := -1; - Exit; - end; - end; - if bcRng2Valid then begin - with bcCompareData do begin - cdFldCnt := bcRng2FldCnt; - cdPartLen := bcRng2PtlLen; - end; - KeyCompareResult := Table.CompareKeysForCursor(bcKID, aKey, bcRng2Key); - if (KeyCompareResult > 0) then begin - Result := 1; - Exit; - end; - if (KeyCompareResult = 0) then begin - if not bcRng2Incl then - Result := 1; - Exit; - end; - end; -end; -{--------} -function TffSrCursor.ModifyRecord(aData : PffByteArray; aRelLock : boolean) : TffResult; -var {!!.05} - aKeyChanged : Boolean; {!!.05} - SavKey : PffByteArray; {!!.05} -begin - - { Note: By this time, any other cursor deleting or modifying the record ahead - of us has completed and has set bcInfo.Deleted. We can be assured of this - because TffServerEngine.RecordDelete calls Cursor.EnsureWritable(true) which - obtains a lock on the record to be deleted. We won't get that lock until - the other cursor has finished. } - - { Has this record already been deleted? } - if bcInfo.Deleted then begin - { Yes. } - Result := DBIERR_KEYORRECDELETED; - Exit; - end; - - { Are we on a record? } - if (bcInfo.Pos <> cpOnRecord) then begin - { No. } - case bcInfo.Pos of - cpBOF : Result := DBIERR_BOF; - cpEOF : Result := DBIERR_EOF; - else - Result := DBIERR_NOCURRREC; - end; - Exit; - end; - - { Notify extenders. } - FFGetMem(bcOldRecBuff, bcRecordLen); {!!.02} - bcNewRecBuff := aData; - try - Move(bcRecordData^, bcOldRecBuff^, bcRecordLen); {!!.02} - Result := NotifyExtenders(ffeaBeforeRecUpdate, ffeaUpdateRecFail); - if Result = DBIERR_NONE then begin - AcqContentLock(ffclmWrite); -{Begin !!.05} - Result := bcTable.PutRecord(bcDatabase.TransactionInfo, CursorID, - bcInfo.refNr, aData, aRelLock, aKeyChanged); - if (Result = DBIERR_NONE) then begin - bcTable.RelaxRecordLock(bcDatabase.TransactionInfo, CursorID, {!!.10} - bcInfo.RefNr); {!!.10} - { Was the key for the current index changed? } - SavKey := nil; - if aKeyChanged then begin - { Yes. Save the current key & rebuild it so that we may reposition to - the record. } - FFGetMem(SavKey, scKeyLen); - try - Move(bcCurKey^, SavKey^, scKeyLen); - scRebuildCurKey(aData, true); - { Does the new key fall outside of the current range? } - if IsInRange(bcCurKey) <> 0 then - { Yes. Restore the old key. The cursor will be repositioned to the - next record. } - Move(SavKey^, bcCurKey^, scKeyLen); - finally - FFFreeMem(SavKey, scKeyLen); - end; - end; - - FFInitKeyPath(bcInfo.KeyPath); - bcInfo.pos := cpOnRecord; - bcRebuildKeyPath; -{End !!.05} - { Notify extenders of successful update. } - NotifyExtenders(ffeaAfterRecUpdate, ffeaNoAction); - end else - { Notify extenders of failed update. } - NotifyExtenders(ffeaUpdateRecFail, ffeaNoAction); - end; - finally - FFFreeMem(bcOldRecBuff, bcRecordLen); {!!.02} - bcOldRecBuff := nil; - bcNewRecBuff := nil; - end; -end; -{--------} -procedure TffSrCursor.ResetRange; -begin - bcHasRange := false; -end; -{--------} -procedure TffSrCursor.scRebuildCurKey(aRecData : PffByteArray; - aLockObtained : boolean); -begin - bcInvalidateCurKey; - if (IndexID = 0) then begin - Move(bcInfo.refNr, bcCurKey^, scKeyLen); - bcInfo.KeyValid := true; - end - else begin - AcqContentLock(ffclmRead); - try - { If we have been passed the record buffer then use it otherwise - read the record from the file. } - if assigned(aRecData) then - Move(aRecData^, bcRecordData^, Table.Files[0]^.fiRecordLength) - else - Table.GetRecord(bcDatabase.TransactionInfo, {!!.10} - bcDatabase.DatabaseID, {!!.10} - CursorID, bcInfo.refNr, {!!.10} - bcRecordData, ffsltNone, aLockObtained, false); {!!.02} - - {calculate the key for this record} - bcInfo.KeyValid := - (Table.BuildKeyForRecord(IndexID, bcRecordData, bcCurKey, 0, 0) = DBIERR_NONE); - finally - RelContentLock(ffclmRead); - end; - end; -end; -{--------} -procedure TffSrBaseCursor.bcRebuildKeyPath; {!!.05 - Moved from TffSrCursor.scRebuildKeyPath} -var - InRangeResult : Integer; -begin - - { Assumption: Content read lock already obtained. } - - { If we have a valid key, calculate the actual key path by finding that key - within the current index. } - if bcIsCurKeyValid then begin - FFInitKeyPath(bcInfo.KeyPath); - with bcCompareData do begin - cdFldCnt := 0; - cdPartLen := 0; - end; - if Table.FindKey(bcKID, bcInfo.refNr, bcDatabase.TransactionInfo, bcCurKey, - bcInfo.KeyPath, skaGreaterEqual) then begin - { Does the key fit within the current range? } - InRangeResult := IsInRange(bcCurKey); - if InRangeResult <> 0 then - bcInfo.pos := cpOnCrack - else - { Make sure that the current position is set to reflect the - keypath's position. } - case bcInfo.KeyPath.kpPos of - kppBOF : SetToBegin; - kppOnCrackBefore, - kppOnCrackAfter : bcInfo.pos := cpOnCrack; - kppEOF : SetToEnd; - end;{case} - end; { if } - end; -end; -{--------} -function TffSrCursor.SetRange(aDirectKey : boolean; - aFieldCount1 : integer; - aPartialLen1 : integer; - aKeyData1 : PffByteArray; - aKeyIncl1 : boolean; - aFieldCount2 : integer; - aPartialLen2 : integer; - aKeyData2 : PffByteArray; - aKeyIncl2 : boolean) : TffResult; -begin - Result := DBIERR_NONE; - {we now have a range} - bcRng1Valid := (aKeyData1 <> nil); - bcRng2Valid := (aKeyData2 <> nil); - {calculate the keys} - if aDirectKey then begin - if bcRng1Valid then - Move(aKeyData1^, bcRng1Key^, scKeyLen); - if bcRng2Valid then - Move(aKeyData2^, bcRng2Key^, scKeyLen); - end - else begin - if bcRng1Valid then - Result := Table.BuildKeyForRecord(IndexID, aKeyData1, bcRng1Key, - aFieldCount1, aPartialLen1); - if (Result = DBIERR_NONE) and bcRng2Valid then - Result := Table.BuildKeyForRecord(IndexID, aKeyData2, bcRng2Key, - aFieldCount2, aPartialLen2); - if (Result <> DBIERR_NONE) then - Exit; - end; - {store the other fields} - if bcRng1Valid then begin - bcRng1FldCnt := aFieldCount1; - bcRng1PtlLen := aPartialLen1; - bcRng1Incl := aKeyIncl1; - end; - if bcRng2Valid then begin - bcRng2FldCnt := aFieldCount2; - bcRng2PtlLen := aPartialLen2; - bcRng2Incl := aKeyIncl2; - end; - {position ourselves at BOF} - SetToBegin; - bcHasRange := true; -end; -{--------} -procedure TffSrCursor.SetToBegin; -begin - AcqContentLock(ffclmRead); - try - bcInfo.pos := cpBOF; - FFSetKeyPathToBOF(bcInfo.KeyPath); - bcInvalidateCurKey; - ffInitI64(bcInfo.refNr); - bcInfo.Deleted := false; - finally - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrCursor.SetToBookmark(aBookmark : PffByteArray) : TffResult; -begin - Result := CheckBookmark(aBookmark); - if (Result = DBIERR_NONE) then begin - - { Requirement: The cursor must be on the same index as the bookmark. } - if IndexID <> PffSrBookmark(aBookmark)^.sbIndexID then begin - Result := DBIERR_INVALIDBOOKMARK; - exit; - end; - - AcqContentLock(ffclmRead); - bcInfoLock.Lock; {!!.06} - try - { Initialize the key path. } - FFInitKeyPath(bcInfo.KeyPath); - with PffSrBookmark(aBookmark)^ do begin - bcInfo.pos := sbPos; - bcInfo.refNr := sbRefNr; - bcInfo.KeyValid := sbKeyValid; - bcInfo.Deleted := false; - if sbKeyValid then - Move(sbKey, bcCurKey^, sbKeyLen); - try - { See if the record still exists by rebuilding the key path. } - bcRebuildKeyPath; {!!.05} - - { Does the record still exist? } - if (ffCmpI64(bcInfo.refNr, sbRefNr) <> 0) then begin - { No. Position the cursor to the crack before the record. } - bcInfo.pos := cpOnCrack; - bcInfo.refNr := sbRefNr; - if (bcInfo.KeyPath.kpPos = kppOnKey) then begin - Assert(bcInfo.KeyPath.kpCount > 0); - bcInfo.KeyPath.kpPos := kppOnCrackBefore; - end; - bcInfo.Deleted := true; - end; - except - SetToBegin; - Result := DBIERR_INVALIDBOOKMARK; - end; - end; - finally - bcInfoLock.Unlock; {!!.06} - RelContentLock(ffclmRead); - end; - end; -end; -{--------} -function TffSrCursor.SetToCursor(aCursor : TffSrBaseCursor) : TffResult; -var - InRangeResult : integer; -begin - Result := DBIERR_NONE; - if (aCursor.Table <> Table) then begin - Result := DBIERR_DIFFERENTTABLES; - Exit; - end; - - AcqContentLock(ffclmRead); - try - { If the cursors are using the same index, copy over the source cursor's - information as is.} - if (aCursor.IndexID = IndexID) then begin - bcInfo := aCursor.bcInfo; - if bcInfo.KeyValid then - Move(aCursor.bcCurKey^, bcCurKey^, scKeyLen); - { If this cursor has a range applied and the record to which it is - positioning does not fit within the range, position the cursor on crack. } - if (bcInfo.pos in [cpOnRecord, cpOnCrack]) and bcInfo.KeyValid then begin - InRangeResult := IsInRange(bcCurKey); - if InRangeResult <> 0 then - aCursor.bcInfo.Pos := cpOnCrack; - end; - end - else begin - { Otherwise, the cursor's are on different indices. } - - { If the source cursor is not on a record then return an error. This - could happen if the source cursor was not originally on a record or - the record has been deleted by the time we were granted a lock on the - record. } - if (aCursor.bcInfo.pos <> cpOnRecord) then begin - Result := DBIERR_NOCURRREC; - Exit; - end; - - { Otherwise, position this cursor to the same record as the source cursor. - We can use the source cursor's refNr as is. We don't need to figure out - the key path. However, we do need to rebuild this cursor's key based - upon the current index. } - bcInfo.pos := cpOnRecord; - bcInfo.refNr := aCursor.bcInfo.refNr; - FFInitKeyPath(bcInfo.KeyPath); - scRebuildCurKey(nil, true); - bcRebuildKeyPath; {!!.05} - end; - finally - RelContentLock(ffclmRead); - end; -end; -{--------} -procedure TffSrCursor.SetToEnd; -begin - AcqContentLock(ffclmRead); - try - bcInfo.pos := cpEOF; - FFSetKeyPathToEOF(bcInfo.KeyPath); - bcInvalidateCurKey; - ffInitI64(bcInfo.refNr); - bcInfo.Deleted := false; - finally - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrCursor.SetToKey(aSearchAction : TffSearchKeyAction; - aDirectKey : boolean; - aFieldCount : integer; - aPartialLen : integer; - aKeyData : PffByteArray) : TffResult; -var - aTI : PffTransInfo; - InRangeResult : integer; -begin - {calculate the key} - if aDirectKey then - Move(aKeyData^, bcCurKey^, scKeyLen) - else begin - Result := Table.BuildKeyForRecord(IndexID, aKeyData, bcCurKey, - aFieldCount, aPartialLen); - if (Result <> DBIERR_NONE) then - Exit; - end; - - AcqContentLock(ffclmRead); - bcInfoLock.Lock; {!!.06} - try - {now position the index on that key or the one that partially - matches it} - FFInitKeyPath(bcInfo.KeyPath); - ffInitI64(bcInfo.refNr); - bcInfo.Deleted := false; - aTI := Database.TransactionInfo; - {try to find the key according to the search action} - with bcCompareData do begin - cdFldCnt := aFieldCount; - cdPartLen := aPartialLen; - end; - if Table.FindKey(bcKID, bcInfo.refNr, aTI, bcCurKey, bcInfo.KeyPath, - aSearchAction) then begin - {we found it} - Result := DBIERR_NONE; - {if we're at EOF, set all current key variables and exit} - if (bcInfo.KeyPath.kpPos = kppEOF) then begin - SetToEnd; - Exit; - end; - {but did we? better see whether we're in the current range} - InRangeResult := IsInRange(bcCurKey); - {the key we found is before the start of the range: position - ourselves at BOF, and only signal an error if the search action - was "search for equal"} - if (InRangeResult < 0) then begin - if aSearchAction = skaEqual then - Result := DBIERR_RECNOTFOUND; - SetToBegin; - Exit; - end; - {the key we found is after the end of the range: position - ourselves at EOF, and only signal an error if the search action - was "search for equal"} - if (InRangeResult > 0) then begin - if aSearchAction = skaEqual then - Result := DBIERR_RECNOTFOUND; - SetToEnd; - Exit; - end; - if Assigned(bcFilter) then begin - Table.GetRecord(aTI, bcDatabase.DatabaseID, {!!.10} - CursorID, bcInfo.refNr, bcRecordData, ffsltNone, {!!.10} - false, false); {!!.02} - if not bcFilter.MatchesRecord(bcRecordData) then begin - if aSearchAction = skaEqual then - Result := DBIERR_RECNOTFOUND - else begin {begin !!.11} - repeat - Result := bcTable.GetNextRecord(aTI, - bcDatabase.DatabaseID, - CursorID, bcKID, bcInfo.refNr, - bcCurKey, bcInfo.KeyPath, bcRecordData, - ffsltNone); - if (Result <> DBIERR_NONE) then begin - if (Result = DBIERR_EOF) then - SetToEnd; - Exit; - end; - {in theory we're on a record} - bcInfo.Deleted := False; - bcInfo.KeyValid := True; - bcInfo.pos := cpOnRecord; - until (Result <> DBIERR_NONE) or - (not Assigned(bcFilter) or bcFilter.MatchesRecord(bcRecordData) - or bcFilter.CheckTimeout(Result)); - end; {end !!.11} - if Result = DBIERR_FF_FilterTimeout then - Exit; - if Result <> DBIERR_NONE then begin - SetToEnd; - Exit; - end; - end; - end; - {SetToKey is supposed to leave the position on the crack before - the record, so make sure} - bcInfo.KeyValid := true; - bcInfo.pos := cpOnCrack; - if (bcInfo.KeyPath.kpPos = kppOnKey) then begin - Assert(bcInfo.KeyPath.kpCount > 0); - bcInfo.KeyPath.kpPos := kppOnCrackBefore; - end; - end - else {we didn't find the key} begin - {if the search action was "search for equal", signal an error and - position ourselves at BOF} - if aSearchAction = skaEqual then begin - Result := DBIERR_RECNOTFOUND; - SetToBegin; - Exit; - end; - {otherwise we're fine} - Result := DBIERR_NONE; - {if we're at EOF, set all current key variables and exit} - if (bcInfo.KeyPath.kpPos = kppEOF) then begin - SetToEnd; - Exit; - end; - {check whether we're in the current range or not} - InRangeResult := IsInRange(bcCurKey); - if InRangeResult <> 0 then begin - bcInfo.Pos := cpOnCrack; - Exit; - end; - - if Assigned(bcFilter) then begin - Table.GetRecord(aTI, bcDatabase.DatabaseID, {!!.10} - CursorID, bcInfo.refNr, bcRecordData, ffsltNone, {!!.10} - false, false); {!!.02} - if not bcFilter.MatchesRecord(bcRecordData) then begin - Result := GetNextRecord(bcRecordData, ffsltNone); - if Result = DBIERR_FF_FilterTimeout then - Exit; - if Result <> DBIERR_NONE then begin - SetToEnd; - Exit; - end; - end; - end; - {otherwise set all current key variables} - bcInfo.KeyValid := true; - bcInfo.pos := cpOnCrack; - end; - finally - bcInfoLock.Unlock; {!!.06} - RelContentLock(ffclmRead); - end; -end; -{--------} -function TffSrCursor.SwitchToIndex(aIndexID : integer; - aPosnOnRec : boolean) : TffResult; -begin - {Assumption: aIndexID has been validated} - Result := DBIERR_NONE; - - if aPosnOnRec and (bcInfo.pos <> cpOnRecord) then begin - Result := DBIERR_NOCURRREC; - Exit; - end; - - AcqContentLock(ffclmRead); - try - {set the index} - bcIndexID := aIndexID; - {free the key buffers} - FFFreeMem(bcCurKey, scKeyLen); - FFFreeMem(bcRng1Key, scKeyLen); - FFFreeMem(bcRng2Key, scKeyLen); - {we lose our range} - bcHasRange := false; - {get our work areas for the key} - scKeyLen := bcTable.Dictionary.IndexKeyLength[aIndexID]; - FFGetMem(bcCurKey, scKeyLen); - FFGetMem(bcRng1Key, scKeyLen); - FFGetMem(bcRng2Key, scKeyLen); - {initialise our key index data record} - bcTable.MakeKIDForCursor(aIndexID, bcKID); - { Set up the position of the cursor to the current record or BOF. } - if aPosnOnRec then begin - { Note that we've already checked that bcInfo.pos is cpOnRecord. } - scRebuildCurKey(nil, false); - bcRebuildKeyPath; {!!.05} - end else - SetToBegin; - finally - RelContentLock(ffclmRead); - end; -end; -{====================================================================} - -{===TffSrCursorList==================================================} -procedure TffSrCursorList.AddCursor(aCursor : TffSrBaseCursor); -begin - solList.Insert(aCursor); -end; -{--------} -function TffSrCursorList.CursorCount : integer; -begin - Assert(Assigned(solList)); - Result := solList.Count; -end; -{--------} -procedure TffSrCursorList.DeleteCursor(aCursorID : TffCursorID); -begin - solList.Delete(aCursorID); -end; -{--------} -function TffSrCursorList.GetCursorItem(Find : TffListFindType; Value : Longint) : TffSrBaseCursor; -var - Inx : integer; -begin - Result := nil; - if (Find = ftFromID) then begin - Inx := solList.Index(Value); - if (Inx <> -1) then - Result := TffSrBaseCursor(solList[Inx]); - end - else {Find = ftFromIndex} - Result := TffSrBaseCursor(solList[Value]); -end; -{--------} -procedure TffSrCursorList.RemoveCursor(aCursorID : TffCursorID); -begin - solList.Remove(aCursorID); -end; -{====================================================================} - -{===TffSrBaseTable===================================================} -constructor TffSrBaseTable.Create(anEngine : TffServerEngine; - const aBaseName : TffTableName; - aFolder : TffSrFolder; - aBufMgr : TffBufferManager; - const aOpenMode : TffOpenMode); -begin - inherited Create; - btBaseName := FFShStrAlloc(aBaseName); - btBufMgr := aBufMgr; - btEngine := anEngine; - btFolder := aFolder; - {create the data dictionary, it'll be empty for now} - btDictionary := TffServerDataDict.Create(4096); - btDictionary.SetBaseName(aBaseName); - {create the list of file info records, set the capacity to 8, - generally tables will have less than this number of files} - btFiles := TffVCLList.Create; - btFiles.Capacity := 8; - {create the cursor list} - btCursorList := TffSrCursorList.Create; - btContentLocks := TffLockContainer.Create; - btClientLocks := TffLockContainer.Create; - btPortal := TffReadWritePortal.Create; -// btUseInternalRollback := False; {!!.03}{Deleted !!.11} -end; -{--------} -destructor TffSrBaseTable.Destroy; -begin - try {!!.06} - CloseFiles(false, nil); - finally {!!.06} - btCursorList.Free; - btFiles.Free; - btDictionary.Free; - btContentLocks.Free; - btClientLocks.Free; - btPortal.Free; - FFShStrFree(btBaseName); - inherited Destroy; - end; {!!.06} -end; -{--------} -procedure TffSrBaseTable.AcqClientLock(aCursorID : Longint; - const aLockType : TffSrLockType; - const aConditional : Boolean); -var - LockStatus : TffLockRequestStatus; - RetryUntil : DWORD; - TblStr : string; - TickCount : DWORD; -begin - - RetryUntil := FFGetRetry; - TickCount := GetTickCount; - - { Do we have any time left? Note that we are doing this check to avoid - the situation where we ask for a lock and pass a negative timeout. } - if (RetryUntil > TickCount) and - ((RetryUntil - TickCount) >= 5) then begin - -{Begin !!.06} - { If there are record locks already on the table then raise an - exception. } - if HasRecordLocks then - FFRaiseException(EffServerException, ffStrResServer, fferrLockRejected, - [FFMapLockToName(ffsltExclusive), '', - PffFileInfo(btFiles[0])^.fiName^]); -{End !!.06} - - { Obtain an exclusive lock on the table content. } - LockStatus := Folder.LockMgr.AcquireClientLock(btClientLocks, - aCursorID, - (RetryUntil - TickCount), - aLockType); - - { Raise an exception if something went awry. } - if LockStatus <> fflrsGranted then - TblStr := format(ffcTableContent,[btBaseName^]); - case LockStatus of - fflrsTimeout : - FFRaiseException(EffServerException, ffStrResServer, fferrTableLockTimeout, - [FFMapLockToName(aLockType), TblStr]); - fflrsRejected : - FFRaiseException(EffServerException, ffStrResServer, fferrLockRejected, - [FFMapLockToName(aLockType), TblStr, '']); - end; { case } - end else - { No. Assume we will time out waiting for the resource. } - FFRaiseExceptionNoData(EffServerException, ffStrResServer, - fferrGeneralTimeout); -end; -{--------} -procedure TffSrBaseTable.AcqContentLock(aTrans : TffSrTransaction; - const aLockType : TffSrLockType; - const aConditional : Boolean); -var - LockStatus : TffLockRequestStatus; - RetryUntil : DWORD; - TblStr : string; - TickCount : DWORD; - TranLockType : TffSrLockType; {!!.03} -begin - -{Begin !!.03} - { Does the transaction have a lock container? } - if assigned(aTrans.TransLockContainer) then begin - { Yes. Does it already have a sufficient lock on this table? } - TranLockType := TffTransContainer(aTrans.TransLockContainer).TableContentLockType(btContentLocks); - if TranLockType >= aLockType then - { Yes. Exit. We don't need to request another lock since we have one - already. } - Exit; - - { Does this transaction already have a share lock on this table & is now - requesting an exclusive lock? } - if (TranLockType = ffsltShare) and - (aLockType = ffsltExclusive) and - (btContentLocks.Count > 1) then begin - { Yes. Does another transaction currently have a share lock on this - table and is already waiting for an exclusive lock? } - btContentLocks.BeginRead; - try - if btContentLocks.SimpleDeadlock then - { Yes. We have a simple deadlock situation. Raise a deadlock exception - so that this transaction is rolled back. This will free up its - share lock which may allow the other transaction to continue - processing. } - FFRaiseException(EffServerException, ffStrResServer, - fferrDeadlock, - [FFMapLockToName(aLockType), - Format(ffcTableContent,[btBaseName^]), - aTrans.TransactionID]); - finally - btContentLocks.EndRead; - end; - end; - end; -{End !!.03} - - RetryUntil := FFGetRetry; - TickCount := GetTickCount; - - { Do we have any time left? Note that we are doing this check to avoid - the situation where we ask for a lock and pass a negative timeout. } - if (RetryUntil > TickCount) and - ((RetryUntil - TickCount) >= 5) then begin - - { Obtain an exclusive lock on the table content. } - LockStatus := Folder.LockMgr.AcquireContentLock(btContentLocks, - Self, - aTrans, - aConditional, - (RetryUntil - TickCount), - aLockType); - - { Raise an exception if something went awry. } - if LockStatus <> fflrsGranted then - TblStr := format(ffcTableContent,[btBaseName^]); - case LockStatus of - fflrsTimeout : - FFRaiseException(EffServerException, ffStrResServer, fferrTableLockTimeout, - [FFMapLockToName(aLockType), TblStr]); - fflrsRejected : - FFRaiseException(EffServerException, ffStrResServer, fferrLockRejected, - [FFMapLockToName(aLockType), TblStr, '']); - end; { case } - end - else - { No. Assume we will time out waiting for the resource. } - FFRaiseExceptionNoData(EffServerException, ffStrResServer, - fferrGeneralTimeout); -end; -{Begin !!.10} -{--------} -function TffSrBaseTable.AcqExclContentLock(aTrans : TffSrTransaction) : TffResult; -var - LockStatus : TffLockRequestStatus; -begin - { Obtain an exclusive lock on the table content. } - LockStatus := Folder.LockMgr.AcquireContentLock(btContentLocks, - Self, - aTrans, - True, - 0, - ffsltExclusive); - - { Set the result. } - case LockStatus of - fflrsGranted : Result := DBIERR_NONE; - fflrsTimeout : Result := fferrLockTimeout; - fflrsRejected : Result := fferrLockRejected; - else - Result := DBIERR_FF_Unknown; - end; { case } -end; -{End !!.10} -{--------} -procedure TffSrBaseTable.AcqLock(const aCursorID : TffCursorID; - const aLockType : TffSrLockType); -var - LockStatus : TffLockRequestStatus; - RetryUntil : DWORD; - TblStr : string; - TickCount : DWORD; -begin - - RetryUntil := FFGetRetry; - TickCount := GetTickCount; - - { Do we have any time left? Note that we are doing this check to avoid - the situation where we ask for a lock and pass a negative timeout. } - if (RetryUntil > TickCount) and - ((RetryUntil - TickCount) >= 5) then begin - - { Obtain an exclusive lock on the file header. } - LockStatus := Folder.LockMgr.AcquireTableLock(TableID, aLockType, - False, - (RetryUntil - TickCount), - aCursorID); - { Raise an exception if something went awry. } - if LockStatus <> fflrsGranted then - TblStr := format(ffcTable,[btBaseName^]); - case LockStatus of - fflrsTimeout : - FFRaiseException(EffServerException, ffStrResServer, fferrTableLockTimeout, - [FFMapLockToName(aLockType), TblStr]); - fflrsRejected : - FFRaiseException(EffServerException, ffStrResServer, fferrLockRejected, - [FFMapLockToName(aLockType), TblStr, '']); - end; { case } - end else - { No. Assume we will time out waiting for the resource. } - FFRaiseExceptionNoData(EffServerException, ffStrResServer, - fferrGeneralTimeout); -end; -{Begin !!.03} -{--------} -procedure TffSrBaseTable.AddAttribute(const anAttrib : TffFileAttribute); -var - Index : Longint; -begin - for Index := 0 to pred(FileCount) do - include(Files[Index].fiAttributes, anAttrib); -end; -{End !!.03} -{--------} -procedure TffSrBaseTable.BeginCommit; -begin - btPortal.BeginWrite; -end; -{--------} -procedure TffSrBaseTable.BeginRead; -begin - btPortal.BeginRead; -end; -{Begin !!.03} -{--------} -procedure TffSrBaseTable.btCommitBLOBMgr; -var - anInx : LongInt; -begin - for anInx := 0 to pred(FileCount) do - if Files[anInx].fiBLOBrscMgr <> nil then - Files[anInx].fiBLOBrscMgr.Commit; -end; -{End !!.03} -{--------} -procedure TffSrBaseTable.btCreateFile(aFileInx : Integer; - aTI : PffTransInfo; - const aExtension : TffExtension; - aForServer : Boolean; - aAttribs : TffFileAttributes; - aStore : TffBaseTempStorage); -var - RecLen : Integer; - BlockSize : Longint; - FI : PffFileInfo; - FileHeader : PffBlockHeaderFile; - aRelMethod : TffReleaseMethod; -begin - {ASSUMPTION: btFiles.Count has already been set to the correct number - of files so that the aFileInx'th element of the btFiles - array can be set - btFiles[aFileInx] is nil, except for aFileInx=0} - - {create the file inforec (note that the descriptor for file 0, the - data file, has already been created)} - if (aFileInx <> 0) then begin - Files[aFileInx] := FFAllocFileInfo(FFMakeFullFileName(Folder.Path, BaseName), - aExtension, btBufMgr); - with Files[aFileInx]^ do begin - fiAttributes := aAttribs; - fiForServer := aForServer; - fiEncrypted := btEngine.Configuration.GeneralInfo^.giAllowEncrypt and - btDictionary.IsEncrypted; - fiTempStore := aStore; - end; - end; - - FI := Files[aFileInx]; - - { Create the file on disk. } - RecLen := Dictionary.RecordLength; - BlockSize := Dictionary.FileBlockSize[aFileInx]; - FFOpenFile(FI, omReadWrite, smExclusive, true, true); - try - {patch up the file's block size for the buffer manager} - FI^.fiBlockSize := BlockSize; - FI^.fiBlockSizeK := BlockSize div 1024; {!!.11} - FI^.fiLog2BlockSize := FFCalcLog2BlockSize(BlockSize); - {add a new block for the new header} - FileHeader := PffBlockHeaderFile(btBufMgr.AddBlock(FI, aTI, 0, aRelMethod)); - {set up the file header information} - with FileHeader^ do begin - bhfSignature := ffc_SigHeaderBlock; - bhfNextBlock := $FFFFFFFF; - bhfThisBlock := 0; - bhfLSN := 0; - bhfBlockSize := BlockSize; - bhfEncrypted := ord( - btEngine.Configuration.GeneralInfo^.giAllowEncrypt and - Dictionary.IsEncrypted); - bhfLog2BlockSize := FFCalcLog2BlockSize(BlockSize); - bhfUsedBlocks := 1; {ie this header block} - bhfAvailBlocks := 0; - bhf1stFreeBlock := $FFFFFFFF; - bhfRecordCount := 0; - bhfDelRecCount := 0; - bhf1stDelRec.iLow := $FFFFFFFF; - bhfRecordLength := RecLen; - bhfRecLenPlusTrailer := RecLen + Sizeof(Byte); - bhfRecsPerBlock := (BlockSize - ffc_BlockHeaderSizeData) div bhfRecLenPlusTrailer; - bhf1stDataBlock := $FFFFFFFF; - bhfLastDataBlock := $FFFFFFFF; - bhfBLOBCount := 0; - bhfDelBLOBHead.iLow := $FFFFFFFF; - bhfDelBLOBTail.iLow := $FFFFFFFF; - bhfAutoIncValue := 0; - bhfIndexCount := Dictionary.IndexCount; - bhfHasSeqIndex := 1; - bhfIndexHeader := ffc_W32NoValue; - bhfDataDict := 0; - bhfFieldCount := Dictionary.FieldCount; - bhfFFVersion := btFolder.NewTableVersion; {!!.11} - end; - aRelMethod(PffBlock(FileHeader)); - except - aRelMethod(PffBlock(FileHeader)); - btBufMgr.RemoveFile(FI); - FFCloseFile(FI); - if (aFileInx <> 0) then begin - FFFreeFileInfo(FI); - btFiles[aFileInx] := nil; - end; - raise; - end;{try..except} -end; -{--------} -procedure TffSrBaseTable.btDeleteBLOBsForRecord(aTI : PffTransInfo; - aData : PffByteArray); -var - FldInx : integer; - FldDesc : PffFieldDescriptor; - BLOBNr : TffInt64; - IsNull : boolean; -begin - with Dictionary do begin - for FldInx := 0 to pred(FieldCount) do begin - FldDesc := FieldDescriptor[FldInx]; - if (FldDesc^.fdType >= fftBLOB) and - (FldDesc^.fdType <= ffcLastBLOBType) then begin - GetRecordField(FldInx, aData, IsNull, @BLOBNr); - if (not IsNull) and (BLOBNr.iLow <> ffc_W32NoValue) then {!!.03} - FFTblDeleteBLOB(Files[BLOBFileNumber], aTI, BLOBNr); - end; - end; - end; -end; -{--------} -function TffSrBaseTable.btGetBaseName : TffTableName; -begin - Result := btBaseName^; -end; -{--------} -function TffSrBaseTable.btGetCursorList : TffSrCursorList; -begin - Result := btCursorList; -end; -{--------} -function TffSrBaseTable.btGetDictionary : TffServerDataDict; -begin - Result := btDictionary; -end; -{--------} -function TffSrBaseTable.btGetFile(Inx : integer) : PffFileInfo; -begin - if (0 <= Inx) and (Inx < btFiles.Count) then - Result := PffFileInfo(btFiles[Inx]) - else - Result := nil; -end; -{--------} -function TffSrBaseTable.btGetFileCount : integer; -begin - Result := btFiles.Count; -end; -{--------} -function TffSrBaseTable.btGetFolder : TffSrFolder; -begin - Result := btFolder; -end; -{--------} -procedure TffSrBaseTable.btInformCursors(aSrcCursorID : TffCursorID; - aOp : TffRecOp; - aRefNr : TffInt64; - aIndexID : integer); -var - Inx : integer; - Cursor, SrcCursor : TffSrBaseCursor; -begin - SrcCursor := TffSrBaseCursor(aSrcCursorID); - CursorList.BeginRead; - try - for Inx := 0 to pred(CursorList.CursorCount) do begin - Cursor := CursorList[ftFromIndex, Inx]; - { Is the cursor within the context of our transaction? } - if (Cursor.Database = SrcCursor.Database) and - (Cursor.CursorID <> aSrcCursorID) then - Cursor.bcRecordUpdated(aOp, aRefNr, aIndexID); - end; - finally - CursorList.EndRead; - end; -end; -{--------} -function TffSrBaseTable.btGetOpenIntents : Longint; -begin - Result := btOpenIntents; -end; -{Begin !!.03} -{--------} -procedure TffSrBaseTable.btRollbackBLOBMgr; {!!.05 - Rewritten} -begin - Files[btDictionary.BLOBFileNumber].fiBLOBrscMgr.RollBack; -end; {!!.05 - End rewritten} -{End !!.03} -{--------} -procedure TffSrBaseTable.btSetFile(Inx : integer; FI : PffFileInfo); -begin - btFiles[Inx] := FI; -end; -{--------} -procedure TffSrBaseTable.btSetFileCount(FC : integer); -begin - if (FC <> btFiles.Count) then - btFiles.Count := FC; -end; -{--------} -procedure TffSrBaseTable.btTableUpdated(aDatabaseID : TffDatabaseID); -var - Inx : integer; - Cursor : TffSrBaseCursor; - Database : TffSrDatabase; -begin - { The purpose of this routine is to invalidate the key path of any - other cursors attached to this table. We do this because an operation - may have caused a Structural Modification Operation (SMO) in the index - used by the cursor and the key path is no longer valid. - - This method is thread-safe for the following reasons: - - 1. A server thread committing a transaction must gain write access to the - table being modified. No other threads will be performing any read or - write operations on that table until the transaction has committed. - - 2. This routine attempts to activate a cursor if the cursor belongs to - another client. If a thread is in the middle of an operation pertaining - to the cursor's client (e.g., RecordGetNext) then this routine will not - be able to update the cursor until the other thread has finished, and - vice versa. - - Future: We could get rid of this if the index structure was such that all - keys were in leaf pages. Then the cursor could just check the LSN of its - current leaf page to see if it should reset its key path. } - Database := TffSrDatabase(aDatabaseID); - CursorList.BeginRead; - try - for Inx := 0 to pred(CursorList.CursorCount) do begin - Cursor := CursorList[ftFromIndex, Inx]; - { Is this cursor attached to another database? } - if (Cursor.Database <> Database) then begin -{Begin !!.06} - Cursor.bcInfoLock.Lock; - try - FFInitKeyPath(Cursor.bcInfo.KeyPath); - finally - Cursor.bcInfoLock.Unlock; - end; -{End !!.06} - end; - end; - finally - CursorList.EndRead; - end; -end; -{--------} -procedure TffSrBaseTable.btUpdateAutoInc(aTI : PffTransInfo; aData : PffByteArray); -var - FldInx : integer; - AutoIncValue : Longint; - IsNull : boolean; -begin - with Dictionary do begin - if HasAutoIncField(FldInx) then begin - GetRecordField(FldInx, aData, IsNull, @AutoIncValue); - if IsNull or (AutoIncValue = 0) then begin - AutoIncValue := FFTblNextAutoIncValue(Files[0], aTI); - SetRecordField(FldInx, aData, @AutoIncValue); - end; - end; - end; -end; -{--------} -procedure TffSrBaseTable.CloseFiles(commitChanges : boolean; aTI : PffTransInfo); -var - FileInx : integer; - TempFile : PffFileInfo; -begin - for FileInx := 0 to pred(FileCount) do begin - TempFile := Files[FileInx]; - if (TempFile <> nil) then begin - if FFFileIsOpen(TempFile) then begin - if commitChanges then - TempFile^.fiBufMgr.CommitFileChanges(TempFile, aTI^.tirTrans); - FFCloseFile(TempFile); - end; - TempFile^.fiBufMgr.RemoveFile(TempFile); - FFFreeFileInfo(TempFile); - end; - end; -end; -{--------} -procedure TffSrBaseTable.CommitChanges(aTI : PffTransInfo); -var - FileInx : integer; - TempFile : PffFileInfo; -begin - for FileInx := 0 to pred(FileCount) do begin - TempFile := Files[FileInx]; - if (TempFile <> nil) and - FFFileIsOpen(TempFile) then - TempFile^.fiBufMgr.CommitFileChanges(TempFile, aTI^.tirTrans); - end; -end; -{--------} -procedure TffSrBaseTable.DeregisterOpenIntent; -begin - if btOpenIntents > 0 then - dec(btOpenIntents); -end; -{--------} -function TffSrBaseTable.EmptyFiles(aTI : PffTransInfo) : TffResult; -var - aAttribs : TffFileAttributes; - aStore : TffBaseTempStorage; - TempDict : TffServerDataDict; -begin - Result := DBIERR_NONE; - { Preserve the existing attributes. Assume that each file managed by the - table has the same set of attributes. } - aAttribs := Files[0]^.fiAttributes; - aStore := TffBaseTempStorage(Files[0]^.fiTempStore); - - TempDict := TffServerDataDict.Create(Dictionary.BlockSize); - try - TempDict.Assign(Dictionary); - { Flush out any changes related to this file. They will be eliminated - when we rebuild the file but we want to make sure they are no longer - part of an explicit transaction. } - CloseFiles(true, aTI); - BuildFiles(aTI, false, TempDict, aAttribs, aStore); - - { Is this a temporary file? } - if not (fffaTemporary in aAttribs) then begin - { No. Commit the changes to the file. } - CloseFiles(true, aTI); - OpenFiles(aTI, false, aAttribs); - end; - finally - TempDict.Free; - end; -end; -{--------} -procedure TffSrBaseTable.EndCommit(aDatabaseID : TffDatabaseID); -begin - btTableUpdated(aDatabaseID); - btPortal.EndWrite; -end; -{--------} -procedure TffSrBaseTable.EndRead; -begin - btPortal.EndRead; -end; -{--------} -procedure TffSrBaseTable.GetNextRecordSeq(aTI : PffTransInfo; - var aRefNr : TffInt64; - aData : PffByteArray); -begin - FFTblReadNextRecord(Files[0], aTI, aRefNr, aRefNr, aData); -end; -{--------} -procedure TffSrBaseTable.GetPrevRecordSeq(aTI : PffTransInfo; - var aRefNr : TffInt64; - aData : PffByteArray); -begin - FFTblReadPrevRecord(Files[0], aTI, aRefNr, aRefNr, aData); -end; -{--------} -function TffSrBaseTable.GetRecord(aTI : PffTransInfo; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.10} - aRefNr : TffInt64; - aData : PffByteArray; - const aLockType : TffSrLockType; {!!.10} - const aLockObtained : boolean; {!!.02}{!!.10} - const aConditional : Boolean) : TffResult; {!!.02}{!!.10} -begin - - Result := DBIERR_NONE; - - { Acquire a lock on the record. } - if (not aLockObtained) then - FFAcqRecordLock(Files[0], aTI, aRefNr, aLockType, aDatabaseID, {!!.10} - aCursorID, aConditional); {!!.02}{!!.10} - - try - if Assigned(aData) then - FFTblReadRecord(Files[0], aTI, aRefNr, aData); - except - if aLockType <> ffsltNone then - FFRelRecordLock(Files[0], aTI, aRefNr, aDatabaseID, aCursorID); - raise; - end; -end; -{--------} -procedure TffSrBaseTable.GetRecordLock(aTI : PffTransInfo; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.10} - const aRefNr : TffInt64; {!!.10} - const aLockType : TffSrLockType); {!!.10} -begin - { Acquire a lock on the record. } - FFAcqRecordLock(Files[0], aTI, aRefNr, aLockType, aDatabaseID, {!!.10} - aCursorID, false); {!!.02}{!!.10} -end; -{Begin !!.10} -{--------} -procedure TffSrBaseTable.GetRecordNoLock(aTI : PffTransInfo; - aRefNr : TffInt64; - aData : PffByteArray); -begin - if Assigned(aData) then - FFTblReadRecord(Files[0], aTI, aRefNr, aData); -end; -{End !!.10} -{--------} -function TffSrBaseTable.HasClientLock(const aCursorID : TffCursorID) : boolean; -begin - Result := Folder.LockMgr.HasClientLock(btClientLocks, aCursorID); -end; -{--------} -function TffSrBaseTable.HasLock(const aCursorID : TffCursorID; - const aLockType : TffSrLockType) : boolean; -begin - if (aLockType = ffsltNone) then - Result := true - else - Result := Folder.LockMgr.IsTableLockedBy(TableID, aCursorID, aLockType); -end; -{Begin !!.06} -{--------} -function TffSrBaseTable.HasRecordLocks : Boolean; -var - RecordLocks : TffThreadHash64; -begin - RecordLocks := PffFileInfo(btFiles[0])^.fiRecordLocks; - Result := (RecordLocks <> nil) and (RecordLocks.Count > 0); -end; -{End !!.06} -{--------} -function TffSrBaseTable.IsContentLockedBy(aTrans : TffSrTransaction) : boolean; -begin - Result := Folder.LockMgr.IsContentLockedBy(btContentLocks, aTrans); -end; -{--------} -function TffSrBaseTable.IsRecordLocked(aTI : PffTransInfo; - aCursorID : TffCursorID; - aRefNr : TffInt64; - aLockType : TffSrLockType) : Boolean; -begin - Result := Folder.LockMgr.IsRecordLocked(aRefNr, Files[0]); -end; -{--------} -function TffSrBaseTable.IsServerTable : boolean; -begin - Result := btForServer; -end; -{Begin !!.03} -{--------} -procedure TffSrBaseTable.ListBLOBFreeSpace(aTI : PffTransInfo; - const aInMemory : Boolean; - aStream : TStream); -var - anInx : LongInt; - aStr : string; -begin - for anInx := 0 to pred(FileCount) do - if Files[anInx].fiBLOBrscMgr <> nil then begin - aStr := Files[anInx].fiName^ + #13#10; - if anInx > 0 then - aStr := #13#10 + aStr; - aStream.Write(aStr[1], Length(aStr)); - Files[anInx].fiBLOBrscMgr.ListFreeSpace(Files[anInx], aTI, aInMemory, - aStream); - end; -end; -{End !!.03} -{--------} -procedure TffSrBaseTable.OpenFiles(aTI : PffTransInfo; aForServer : boolean; - aAttribs : TffFileAttributes); -var - FileInx : integer; - FileCnt : integer; - DataFile : PffFileInfo; - Page : PffBlock; - TempFile : PffFileInfo; - State : integer; - aRelMethod : TffReleaseMethod; -begin - State := 0; - FileCnt := 0; - TempFile := nil; - try - { Allocate the first file inforec: it'll be for the data file. } - btFiles.Count := 1; - btFiles[0] := FFAllocFileInfo(FFMakeFullFileName(Folder.Path, BaseName), - ffc_ExtForData, - btBufMgr); - State := 25; - PffFileInfo(btFiles[0])^.fiAttributes := aAttribs; - PffFileInfo(btFiles[0])^.fiForServer := aForServer; - - { Open up the data file. } - DataFile := Files[0]; - FFOpenFile(DataFile, omReadWrite, smExclusive, aForServer, false); - State := 50; - - { Make sure it's a proper FF file: try to load the header record, - make it fixed (this'll also check the encryption level). } - Page := btBufMgr.AddFile(DataFile, aTI, false, aRelMethod); -{Begin !!.11} - { Adjust in-memory version if overridden via folder. } - if btFolder.ExistingTableVersion <> 0 then - Files[0].fiFFVersion := btFolder.ExistingTableVersion; -{End !!.11} - aRelMethod(Page); - - { Read the data dictionary. } - Dictionary.ReadFromFile(DataFile, aTI); - Dictionary.BindIndexHelpers; - - { Set up the count of files in the Files array. } - FileCnt := Dictionary.FileCount; - FileCount := FileCnt; - for FileInx := 1 to pred(FileCnt) do begin - Files[FileInx] := nil; - end; - { Now read through the Dictionary's file list and allocate the - file inforecs, obviously don't do file 0 since it's been done - already. } - State := 100; - for FileInx := 1 to pred(FileCnt) do begin - Files[FileInx] := FFAllocFileInfo(FFMakeFullFileName(Folder.Path, BaseName), - Dictionary.FileExt[FileInx], - btBufMgr); - PffFileInfo(btFiles[FileInx])^.fiAttributes := aAttribs; - PffFileInfo(btFiles[FileInx])^.fiForServer := aForServer; - end; - - { Now open up all the new files, ie excepting file 0 which is - already open (it was opened to read the data dictionary); read - the header record from each file as well, as a security check - to see whether the file is in FF format. } - State := 200; - for FileInx := 1 to pred(FileCnt) do begin - TempFile := Files[FileInx]; - FFOpenFile(TempFile, - DataFile^.fiOpenMode, DataFile^.fiShareMode, - DataFile^.fiWriteThru, false); - Page := btBufMgr.AddFile(TempFile, aTI, false, aRelMethod); - aRelMethod(Page); - end; -{Begin !!.11} - Files[Dictionary.BLOBFileNumber].fiBLOBrscMgr := - TffBaseBLOBResourceMgr.GetMgr(Files[Dictionary.BLOBFileNumber]); - btBLOBEngine := TffBaseBLOBEngine.GetEngine(Files[Dictionary.BLOBFileNumber]); -{End !!.11} - State := 300; - btForServer := aForServer; - except - if (State = 300) then - {BLOB Resource Mgr created} - Files[Dictionary.BLOBFileNumber].fiBLOBrscMgr.Free; - if (State >= 200) then begin - {some files are open, all file inforecs are created} - for FileInx := 1 to pred(FileCnt) do begin - TempFile := Files[FileInx]; - if FFFileIsOpen(TempFile) then - FFCloseFile(TempFile); - TempFile^.fiBufMgr.RemoveFile(TempFile); - end; - end; - if (State >= 100) then begin - {at least some of the inforecs have been created} - for FileInx := 1 to pred(FileCnt) do begin - TempFile := Files[FileInx]; - FFFreeFileInfo(TempFile); - end; - end; - if (State >= 50) then begin - {at least the data file is open} - TempFile := Files[0]; - if FFFileIsOpen(TempFile) then - FFCloseFile(TempFile); - TempFile^.fiBufMgr.RemoveFile(TempFile); - end; - if (State >= 25) then begin - {at least the data file inforec has been allocated} - TempFile := Files[0]; - FFFreeFileInfo(TempFile); - end; - if (State >= 0) then begin - {empty the files list} - FileCount := 0; - end; - raise; - end;{try..except} -end; -{--------} -procedure TffSrBaseTable.RegisterOpenIntent; -begin - inc(btOpenIntents); -end; -{--------} -procedure TffSrBaseTable.RelClientLock(aCursorID : Longint; aRemoveAll : Boolean); -begin - if (not aRemoveAll) then {!!.03} - Folder.LockMgr.ReleaseClientLock(btClientLocks, aCursorID) - else - Folder.LockMgr.ReleaseClientLockAll(btClientLocks, aCursorID); -end; -{--------} -procedure TffSrBaseTable.RelContentLock(aTrans : TffSrTransaction); -begin - Folder.LockMgr.ReleaseContentLock(btContentLocks, aTrans); -end; -{--------} -procedure TffSrBaseTable.RelLock(const aCursorID : TffCursorID; - const aAllLocks : Boolean); -begin - if aAllLocks then - Folder.LockMgr.ReleaseTableLockAll(TableID, aCursorID) - else - Folder.LockMgr.ReleaseTableLock(TableID, aCursorID); -end; -{Begin !!.10} -{--------} -procedure TffSrBaseTable.RelaxRecordLock(aTI : PffTransInfo; - aCursorID : TffCursorID; - aRefNr : TffInt64); -begin - FFRelaxRecordLock(Files[0], aTI, aCursorID, aRefNr); -end; -{End !!.10} -{--------} -procedure TffSrBaseTable.RelRecordLock(aTI : PffTransInfo; - aDatabaseID : TffDatabaseID; {!!.10} - aCursorID : TffCursorID; - aRefNr : TffInt64); -begin - FFRelRecordLock(Files[0], aTI, aRefNr, aDatabaseID, aCursorID); {!!.10} -end; -{--------} -procedure TffSrBaseTable.RemoveLocksForCursor(const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; - const aRefNr : TffInt64; - aTI : PffTransInfo); -begin - { In FF 1, if aRefNr = 0 then all of a cursor's locks were - released. We do not have such a need for FF2 since the only time a cursor - has record locks is if it is in a transaction and has acquired exclusive - locks on one or more records. When the transaction is committed or rolled - back, the record locks are released. } - FFRelRecordLock(Files[0], aTI, aRefNr, aDatabaseID, aCursorID); {!!.10} -end; -{--------} -procedure TffSrBaseTable.SetAttributes(const fileAttribs : TffFileAttributes); -var - Index : Longint; -begin - for Index := 0 to pred(FileCount) do - Files[Index].fiAttributes := fileAttribs; -end; -{--------} -procedure TffSrBaseTable.SetExclOwner(const aCursorID : TffCursorID); -var - Index : Longint; -begin - for Index := 0 to pred(FileCount) do - Files[Index].fiExclOwner := aCursorId; -end; -{====================================================================} - -{===TffSrTable=======================================================} -constructor TffSrTable.Create(anEngine : TffServerEngine; - const aBaseName : TffTableName; - aFolder : TffSrFolder; - aBufMgr : TffBufferManager; - const aOpenMode : TffOpenMode); -begin - inherited Create(anEngine, aBaseName, aFolder, aBufMgr, aOpenMode); - {create the user routine arrays} - stUserBuildKey := TffVCLList.Create; - stUserCompareKey := TffVCLList.Create; - {miscellaneous} - FreeOnRemove := true; -// stUseInternalRollback := False; {!!.03} -end; -{--------} -destructor TffSrTable.Destroy; -begin - stUserCompareKey.Free; - stUserBuildKey.Free; - RemoveDynamicLinks; - inherited Destroy; -end; -{--------} -procedure TffSrTable.AddIndex(const aIndexDesc : TffIndexDescriptor; - aTI : PffTransInfo); -var - IndexInx : integer; -begin - {assumption: aIndexDesc has been validated} - IndexInx := Dictionary.IndexCount; - with aIndexDesc do - Dictionary.AddIndex(idName, idDesc, idFile, idCount, idFields, - idFieldIHlprs, idDups, idAscend, idNoCase); - Dictionary.BindIndexHelpers; - Dictionary.WriteToFile(Files[0], aTI); - FFTblAddIndex(Files[aIndexDesc.idFile], - aTI, - IndexInx, - Dictionary.IndexKeyLength[IndexInx], - aIndexDesc.idDups, - IndexInx = 0); -end; -{--------} -procedure TffSrTable.BuildFiles(aTI : PffTransInfo; - aForServer : boolean; - aDictionary : TffDataDictionary; - aAttribs : TffFileAttributes; - aStore : TffBaseTempStorage); -var - FileInx : integer; - IndexInx : integer; - DataFile : PffFileInfo; - FileCnt : integer; {dup for speed} -begin - {allocate the first file inforec now: it'll be for the data file} - btFiles.Count := 1; - btFiles[0] := FFAllocFileInfo(FFMakeFullFileName(Folder.Path, BaseName), - ffc_ExtForData, btBufMgr); - with PffFileInfo(btFiles[0])^ do begin - fiAttributes := aAttribs; - fiForServer := aForServer; - fiEncrypted := btEngine.Configuration.GeneralInfo^.giAllowEncrypt and - aDictionary.IsEncrypted; - fiRecLenPlusTrailer := aDictionary.RecordLength + SizeOf(Byte); - fiRecordLength := aDictionary.RecordLength; - fiTempStore := aStore; - end; - - { Validate the dictionary. } - aDictionary.CheckValid; - - { Assimilate the dictionary. } - btDictionary.ForceOffReadOnly; - btDictionary.Assign(aDictionary); - btDictionary.BindIndexHelpers; - - { Get the file count for this table (for speed reasons, etc). } - FileCnt := Dictionary.FileCount; - FileCount := FileCnt; - - { Get the data file for speed reasons. } - DataFile := Files[0]; - - { Build all the files and assume that all will contain indexes. } - for FileInx := 0 to pred(FileCnt) do begin - btCreateFile(FileInx, aTI, btDictionary.FileExt[FileInx], aForServer, - aAttribs, aStore); - FFTblPrepareIndexes(btFiles[FileInx], aTI); - end; - - { Write the dictionary. } - Dictionary.WriteToFile(DataFile, aTI); - - { Add the indexes to their associated index files. } - with btDictionary do begin - for IndexInx := 0 to pred(IndexCount) do begin - FFTblAddIndex(Files[IndexFileNumber[IndexInx]], - aTI, - IndexInx, - IndexKeyLength[IndexInx], - IndexAllowDups[IndexInx], - IndexInx = 0); - end; - end; - -{Begin !!.11} - Files[btDictionary.BLOBFileNumber].fiBLOBrscMgr := - TffBaseBLOBResourceMgr.GetMgr(Files[Dictionary.BLOBFileNumber]); - btBLOBEngine := TffBaseBLOBEngine.GetEngine(Files[btDictionary.BLOBFileNumber]); -{End !!.11} - Files[btDictionary.BLOBFileNumber].fiMaxSegSize := - FFCalcMaxBLOBSegSize(Files[btDictionary.BLOBFileNumber]); - -end; -{--------} -function TffSrTable.BuildKeyForRecord(aIndexID : integer; - aData : PffByteArray; - aKey : PffByteArray; - aFieldCount : integer; - aPartialLen : integer) : TffResult; -var - BuildKey : TffKeyBuildFunc; - LenKeyToGen : integer; -begin - if (Dictionary.IndexType[aIndexID] = itComposite) then begin - Result := stBuildCompositeKey(aIndexID, aData, aKey, aFieldCount, aPartialLen); - end - else {user-defined index} begin - BuildKey := stGetUserBuildKey(aIndexID); - if (aFieldCount = 0) and (aPartialLen = 0) then - LenKeyToGen := Dictionary.IndexKeyLength[aIndexID] - else - LenKeyToGen := aPartialLen; - if not BuildKey(aIndexID, aData, aKey^, LenKeyToGen) then - Result := DBIERR_KEYVIOL - else - Result := DBIERR_NONE; - end; -end; -{--------} -function TffSrTable.CompareKeysForCursor(var aKID : TffKeyIndexData; - aKey1 : PffByteArray; - aKey2 : PffByteArray) : integer; -var - CompareKey : TffKeyCompareFunc; -begin - with aKID, kidCompareData^ do begin - if (kidIndexType = itComposite) then begin - Result := FFKeyCompareComposite(aKey1^, aKey2^, kidCompareData); - end - else {user-defined index} if (kidIndex = 0) then begin - Result := FFCmpDW(PffWord32(aKey1)^, PffWord32(aKey2)^); - end - else {not index 0} begin - CompareKey := stGetUserCompareKey(kidIndex); - Result := CompareKey(aKey1^, aKey2^, kidCompareData); - end; - end; -end; -{--------} -function TffSrTable.DeleteRecord(aTI : PffTransInfo; - const aCursorID : TffCursorID; - const aRefNr : TffInt64; - const aLockObtained : Boolean; - var aBTreeChanged : Boolean) : TffResult; {!!.05} -var - OldData : PffByteArray; - RecLen : integer; -begin - RecLen := Dictionary.RecordLength; - FFGetMem(OldData, RecLen); - - { If we have yet to lock the record then do so. } - if (not aLockObtained) then - FFAcqRecordLock(Files[0], aTI, aRefNr, ffsltExclusive, - aTI^.tirTrans.DatabaseID, {!!.10} - aCursorID, false); {!!.02}{!!.10} - { Note: We leave all such locks active until the transaction is committed. } - - try - FFTblReadRecord(Files[0], aTI, aRefNr, OldData); - Result := stDeleteKeysForRecord(aTI, aRefNr, - OldData, aBTreeChanged); {!!.05} - if (Result <> DBIERR_NONE) then - Exit; - btDeleteBLOBsForRecord(aTI, OldData); - FFTblDeleteRecord(Files[0], aTI, aRefNr); - finally - btInformCursors(aCursorID, roDelete, aRefNr, 0); - FFFreeMem(OldData, RecLen); - end;{try..finally} -end; -{--------} -procedure TffSrTable.DropIndex(aTI : PffTransInfo; aIndexID : Longint); -var - i : integer; -begin - Dictionary.RemoveIndex(aIndexID); - Dictionary.WriteToFile(Files[0], aTI); - for i := 0 to pred(Dictionary.FileCount) do - FFTblDeleteIndex(Files[i], aTI, aIndexID); -end; -{--------} -function TffSrTable.FindKey(var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aAction : TffSearchKeyAction) : boolean; -begin - Result := FFTblFindKey(aKID, aRefNr, aTI, aKey, aKeyPath, aAction); -end; -{--------} -function TffSrTable.GetNextKey(var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath) : TffResult; -begin - if FFTblNextKey(aKID, aRefNr, aTI, aKey, aKeyPath) then - Result := DBIERR_NONE - else - Result := DBIERR_EOF; -end; -{--------} -function TffSrTable.GetNextRecord(aTI : PffTransInfo; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.10} - var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aData : PffByteArray; - const aLockType : TffSrLockType) : TffResult; {!!.10} -begin - Result := DBIERR_NONE; - - try - if FFTblNextKey(aKID, aRefNr, aTI, aKey, aKeyPath) then begin - FFAcqRecordLock(Files[0], aTI, aRefNr, aLockType, {!!.10} - aDatabaseID, aCursorID, false); {!!.10} - FFTblReadRecord(Files[0], aTI, aRefNr, aData); - end - else - Result := DBIERR_EOF; - except - if aLockType <> ffsltNone then - FFRelRecordLock(Files[0], aTI, aRefNr, aDatabaseID, aCursorID); {!!.10} - raise; - end; -end; -{--------} -function TffSrTable.GetPriorRecord(aTI : PffTransInfo; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.10} - var aKID : TffKeyIndexData; - var aRefNr : TffInt64; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aData : PffByteArray; - const aLockType : TffSrLockType) : TffResult; {!!.10} -begin - Result := DBIERR_NONE; - - try - if FFTblPrevKey(aKID, aRefNr, aTI, aKey, aKeyPath) then begin - FFAcqRecordLock(Files[0], aTI, aRefNr, aLockType, {!!.10} - aDatabaseID, aCursorID, false); {!!.10} - FFTblReadRecord(Files[0], aTI, aRefNr, aData); - end - else - Result := DBIERR_BOF; - except - if aLockType <> ffsltNone then - FFRelRecordLock(Files[0], aTI, aRefNr, aDatabaseID, aCursorID); {!!.10} - raise; - end; -end; -{--------} -function TffSrTable.InsertRecord(aTI : PffTransInfo; - aCursorID : TffCursorID; - aData : PffByteArray; - aLockType : TffSrLockType; - var aNewRefNr : TffInt64) : TffResult; -var - RefNr : TffInt64; -begin - RefNr.iLow := 0; - RefNr.iHigh := 0; - if not Dictionary.CheckRequiredRecordFields(aData) then - Result := DBIERR_REQDERR - else begin - {we need to add the default field values} - if Dictionary.DefaultFieldCount > 0 then - Dictionary.SetDefaultFieldValues(aData); - - { Updating the autoinc value obtains an exclusive lock on block 0 which - prevents other cursors from inserting the same or additional records - until we are done. } - btUpdateAutoInc(aTI, aData); - FFTblAddRecord(Files[0], aTI, RefNr, aData); - {initialize result to an invalid value} - Result := -1; - try - aNewRefNr := RefNr; - Result := stInsertKeysForRecord(aTI, RefNr, aData); - if (Result = DBIERR_NONE) then - FFAcqRecordLock(Files[0], aTI, aNewRefNr, aLockType, {!!.10} - aTI^.tirTrans.DatabaseID, aCursorID, false); {!!.10} - finally - { If the insertion of the keys was not successful and we - are to cleanup after ourselves then remove the inserted record. } - if (Result <> DBIERR_NONE) then begin {!!.11} - FFTblDeleteRecord(Files[0], aTI, RefNr); - RefNr.iLow := 0; - RefNr.iHigh := 0; - end; - end; - end; -end; -{--------} -function TffSrTable.InsertRecordNoDefault(aTI : PffTransInfo; {!!.10} - aCursorID : TffCursorID; - aData : PffByteArray; - aLockType : TffSrLockType; - var aNewRefNr : TffInt64) : TffResult; -var - RefNr : TffInt64; -begin - RefNr.iLow := 0; - RefNr.iHigh := 0; - if not Dictionary.CheckRequiredRecordFields(aData) then - Result := DBIERR_REQDERR - else begin - { Updating the autoinc value obtains an exclusive lock on block 0 which - prevents other cursors from inserting the same or additional records - until we are done. } - btUpdateAutoInc(aTI, aData); - FFTblAddRecord(Files[0], aTI, RefNr, aData); - {initialize result to an invalid value} - Result := -1; - try - aNewRefNr := RefNr; - Result := stInsertKeysForRecord(aTI, RefNr, aData); - if (Result = DBIERR_NONE) then - FFAcqRecordLock(Files[0], aTI, aNewRefNr, aLockType, {!!.10} - aTI^.tirTrans.DatabaseID, aCursorID, false); {!!.10} - finally - { If the insertion of the keys was not successful and we - are to cleanup after ourselves then remove the inserted record. } - if (Result <> DBIERR_NONE) then begin {!!.11} - FFTblDeleteRecord(Files[0], aTI, RefNr); - RefNr.iLow := 0; - RefNr.iHigh := 0; - end; - end; - end; -end; -{--------} -procedure TffSrTable.MakeKIDForCursor(aIndexID : integer; var aKID : TffKeyIndexData); -begin - with Dictionary, aKID, kidCompareData^ do begin - kidFI := Files[IndexFileNumber[aIndexID]]; - kidIndex := aIndexID; - if (aIndexID = 0) then begin - kidCompare := FFKeyCompareI64; - kidIndexType := itUserDefined; - end - else if (IndexType[aIndexID] = itComposite) then begin - kidCompare := FFKeyCompareComposite; - kidIndexType := itComposite; - end - else begin - kidCompare := stGetUserCompareKey(aIndexID); - kidIndexType := itUserDefined; - end; - cdKeyLen := IndexKeyLength[aIndexID]; - cdDict := pointer(Dictionary); - cdIndex := aIndexID; - cdFldCnt := 0; {for completeness} - cdPartLen := 0; {for completeness} - cdAscend := IndexIsAscending[aIndexID]; - cdNoCase := IndexIsCaseInsensitive[aIndexID]; - end; -end; -{--------} -function TffSrTable.PutRecord(aTI : PffTransInfo; - aCursorID : TffCursorID; - aRefNr : TffInt64; - aData : PffByteArray; - aRelLock : boolean; {!!.05} - var aKeyChanged : Boolean) : TffResult; {!!.05} -var - OldData: PffByteArray; - RecLen : integer; -begin - - { Assumption: By the time we have reached this point, the transaction has - acquired a content lock on the table and we are the only ones who can - modify the record. } - - RecLen := 0; - if not Dictionary.CheckRequiredRecordFields(aData) then begin - Result := DBIERR_REQDERR; - Exit; - end; - - Result := DBIERR_NONE; - try -// try {!!.11} - RecLen := Dictionary.RecordLength; - FFGetMem(OldData, RecLen); - - FFTblReadRecord(Files[0], aTI, aRefNr, OldData); - - { Acquire an exclusive lock. } - FFAcqRecordLock(Files[0], aTI, aRefNr, ffsltExclusive, {!!.10} - aTI^.tirTrans.DatabaseID, aCursorID, false); {!!.10} - try {!!.11} - { There's no need to update index 0, the refnr has not changed. } - Result := stUpdateKeysForRecord(aCursorID, aTI, aRefNr, aData, OldData, aKeyChanged); {!!.05} - if (Result <> DBIERR_NONE) then - Exit; - FFTblUpdateRecord(Files[0], aTI, aRefNr, aData); - except - FFRelRecordLock(Files[0], aTI, aRefNr, aTI^.tirTrans.DatabaseID, {!!.10} - aCursorID); {!!.10} - raise; {!!.01} - end; - finally - FFFreeMem(OldData, RecLen); - end;{try..finally} -end; -{--------} -procedure TffSrTable.RemoveDynamicLinks; -var - i : Integer; - KeyProcItem : TffKeyProcItem; - Inx : Integer; -begin - {unlink user-defined indexes} - with btEngine.Configuration do begin - for i := 1 to pred(Dictionary.IndexCount) do begin - if (Dictionary.IndexType[i] <> itComposite) then begin - Inx := KeyProcList.KeyProcIndex(Folder.Path, BaseName, i); - if (Inx <> -1) then begin - KeyProcItem := KeyProcList[Inx]; - KeyProcItem.Unlink; - end; - end; - end; - end; -end; -{--------} -procedure TffSrTable.ResolveDynamicLinks; -var - i : integer; - KeyProcItem : TffKeyProcItem; - Inx : integer; -begin - stUserBuildKey.Clear; - stUserCompareKey.Clear; - {add nil pointers for index 0 as this can never be a user-defined - index} - stUserBuildKey.Add(nil); - stUserCompareKey.Add(nil); - {fill the arrays with data for each index} - for i := 1 to pred(Dictionary.IndexCount) do begin - if (Dictionary.IndexType[i] = itComposite) then begin - stUserBuildKey.Add(nil); - stUserCompareKey.Add(nil); - end - else {it's a user-defined index} begin - with btEngine.Configuration do begin - Inx := KeyProcList.KeyProcIndex(Folder.Path, BaseName, i); - if (Inx <> -1) then begin - KeyProcItem := KeyProcList[Inx]; - if KeyProcItem.Link then begin - stUserBuildKey.Add(pointer(@KeyProcItem.BuildKey)); - stUserCompareKey.Add(pointer(@KeyProcItem.CompareKey)); - end - else - FFRaiseExceptionNoData(EffServerException, - ffStrResServer, - fferrResolveTableLinks); - end else - FFRaiseExceptionNoData(EffServerException, ffStrResServer, fferrResolveTableLinks); - end; - end; - end; -end; -{--------} -function TffSrTable.stGetBuiltCompositeKey(aIndexID : integer; - aData : PffByteArray; - aKeyLen : Longint; - var aKey : PffByteArray) : TffResult; -var - WorkKey : PffByteArray; -begin - FFGetMem(WorkKey, aKeyLen); - try - Result := stBuildCompositeKey(aIndexID, aData, WorkKey, 0, 0); - if (Result <> DBIERR_NONE) then - FFFreeMem(WorkKey, aKeyLen) {!!.06} - else - aKey := WorkKey; - except - FFFreeMem(WorkKey, aKeyLen); - raise; - end;{try..except} -end; -{--------} -function TffSrTable.stBuildCompositeKey(aIndexID : integer; - aData : PffByteArray; - aKey : PffByteArray; - aFieldCount : integer; - aLastFldLen : integer) : TffResult; -var - KeyOffset : integer; - IndexDscrptr: PffIndexDescriptor; - FieldDesc : PffFieldDescriptor; - FieldNumber : integer; - LenToUse : integer; - FldCnt : integer; -begin - Result := DBIERR_NONE; - KeyOffset := 0; - IndexDscrptr := Dictionary.IndexDescriptor[aIndexID]; - with IndexDscrptr^ do begin - {clear the entire key} - FFInitKey(aKey, idKeyLen, idCount); - {calculate the number of complete fields we can use} - if (aFieldCount = 0) then - if (aLastFldLen = 0) then - FldCnt := idCount - else {partial key} - FldCnt := 0 - else - if (aLastFldLen = 0) then - FldCnt := FFMinI(aFieldCount, idCount) - else {partial key} - FldCnt := FFMinI(aFieldCount, pred(idCount)); - - {build using complete fields} - if (FldCnt > 0) then - for FieldNumber := 0 to pred(FldCnt) do begin - FieldDesc := Dictionary.FieldDescriptor[idFields[FieldNumber]]; - with FieldDesc^ do begin - if not Dictionary.IsRecordFieldNull(idFields[FieldNumber], aData) then begin - Move(aData^[fdOffset], aKey^[KeyOffset], fdLength); - FFSetKeyFieldNonNull(aKey, idKeyLen, idCount, FieldNumber); - end; - inc(KeyOffset, fdLength); - end; - end; - - {add the last partial field if required - must be string} - if (aLastFldLen <> 0) then begin - FieldNumber := idFields[FldCnt]; - if not Dictionary.IsRecordFieldNull(FieldNumber, aData) then begin - FieldDesc := Dictionary.FieldDescriptor[FieldNumber]; - with FieldDesc^ do - if (fdType >= fftShortString) then begin - if (fdType = fftWideString) then - LenToUse := sizeof(WideChar) * aLastFldLen - else - LenToUse := aLastFldLen; - if (fdType = fftShortString) or - (fdType = fftShortAnsiStr) then begin - Move(aData^[fdOffset], aKey^[KeyOffset], LenToUse+1); - aKey^[KeyOffset] := LenToUse; - end - else - Move(aData^[fdOffset], aKey^[KeyOffset], LenToUse); - FFSetKeyFieldNonNull(aKey, idKeyLen, idCount, FldCnt); - end - else - Result := DBIERR_INVALIDFLDTYPE; - end; - end; - end; -end; -{--------} -function TffSrTable.stDeleteKeyPrim(aInxFile : Integer; - aTI : PffTransInfo; - aRefNr : TffInt64; - aKey : PffByteArray; - aCompare : TffKeyCompareFunc; - aCmpData : PffCompareData; - var aBTreeChanged : Boolean) {!!.05} - : Boolean; -var - KID : TffKeyIndexData; -begin - with KID do begin - kidFI := Files[aInxFile]; - kidIndex := aCmpData^.cdIndex; - kidCompare := aCompare; - kidCompareData := aCmpData; - end; - Result := FFTblDeleteKey(aTI, aKey, aRefNr, KID, aBTreeChanged); {!!.05} -end; -{--------} -function TffSrTable.stDeleteKeysForRecord(aTI : PffTransInfo; - aRefNr : TffInt64; - aData : PffByteArray; - var aBTreeChanged : Boolean) {!!.05} - : TffResult; -var - IndexNumber : integer; - IndexDscrptr: PffIndexDescriptor; - Key : PffByteArray; - BuildKey : TffKeyBuildFunc; - Compare : TffKeyCompareFunc; - CmpData : TffCompareData; - tmpBtreeChanged : Boolean; {!!.05} -begin - Result := DBIERR_NONE; - with CmpData do begin - cdDict := pointer(Dictionary); - cdIndex := 0; - cdFldCnt := 0; - cdPartLen := 0; - cdAscend := true; {for index 0} - cdNoCase := true; {for index 0} - end; - aBTreeChanged := True; {!!.05} - with Dictionary do begin - if not stDeleteKeyPrim(0, aTI, aRefNr, PffByteArray(@aRefNr), - FFKeyCompareI64, @CmpData, - tmpBTreeChanged) then begin {!!!.05} - Result := DBIERR_KEYVIOL; - Exit; - end; - aBTreeChanged := tmpBtreeChanged; {!!.05} - for IndexNumber := 1 to pred(IndexCount) do begin - IndexDscrptr := IndexDescriptor[IndexNumber]; - with IndexDscrptr^ do begin - if (idCount <> -1) then begin {a composite index} - CmpData.cdIndex := IndexNumber; - CmpData.cdAscend := idAscend; - CmpData.cdNoCase := idNoCase; - CmpData.cdKeyLen := idKeyLen; - Result := stGetBuiltCompositeKey(IndexNumber, aData, idKeyLen, Key); - if (Result <> DBIERR_NONE) then - Exit; - try - if not stDeleteKeyPrim(idFile, aTI, aRefNr, - Key, FFKeyCompareComposite, - @CmpData, tmpBTreeChanged) then begin {!!.05} - Result := DBIERR_KEYVIOL; - Exit; - end; - if tmpBtreeChanged then {!!.05} - aBTreeChanged := true; {!!.05} - finally - FFFreeMem(Key, CmpData.cdKeyLen); - end;{try..finally} - end - else {a user-defined index} begin - CmpData.cdIndex := IndexNumber; - CmpData.cdAscend := idAscend; - CmpData.cdNoCase := idNoCase; - CmpData.cdKeyLen := idKeyLen; - FFGetMem(Key, CmpData.cdKeyLen); - try - BuildKey := stGetUserBuildKey(IndexNumber); - Compare := stGetUserCompareKey(IndexNumber); - if BuildKey(IndexNumber, aData, Key^, CmpData.cdKeyLen) then - if not stDeleteKeyPrim(idFile, aTI, aRefNr, - Key, Compare, @CmpData, - tmpBTreeChanged) then begin {!!.05} - Result := DBIERR_KEYVIOL; - Exit; - end; - if tmpBtreeChanged then {!!.05} - aBTreeChanged := true; {!!.05} - finally - FFFreeMem(Key, CmpData.cdKeyLen); - end;{try..finally} - end; - end; - end; - end; -end; -{--------} -function TffSrTable.stGetUserBuildKey(aIndexID : integer) : TffKeyBuildFunc; -begin - if (0 <= aIndexID) and (aIndexID < stUserBuildKey.Count) then - @Result := stUserBuildKey[aIndexID] - else - Result := nil; -end; -{--------} -function TffSrTable.stGetUserCompareKey(aIndexID : integer) : TffKeyCompareFunc; -begin - if (0 <= aIndexID) and (aIndexID < stUserCompareKey.Count) then - @Result := stUserCompareKey[aIndexID] - else - Result := nil; -end; -{--------} -function TffSrTable.stInsertKeyPrim(aInxFile: integer; - aTI : PffTransInfo; - aRefNr : TffInt64; - aKey : PffByteArray; - aCompare: TffKeyCompareFunc; - aCmpData: PffCompareData) : boolean; -var - KID : TffKeyIndexData; -begin - with KID do begin - kidFI := Files[aInxFile]; - kidIndex := aCmpData^.cdIndex; - kidCompare := aCompare; - kidCompareData := aCmpData; - end; - Result := FFTblInsertKey(KID, aRefNr, aTI, aKey); -end; -{--------} -function TffSrTable.stInsertKeysForRecord(aTI : PffTransInfo; - aRefNr : TffInt64; - aData : PffByteArray) : TffResult; -var - IndexNumber : integer; - IndexDscrptr : PffIndexDescriptor; - Key : PffByteArray; - BuildKey : TffKeyBuildFunc; - Compare : TffKeyCompareFunc; - CmpData : TffCompareData; - BTreeChanged : Boolean; {!!.05} - -Procedure RollBackInsertKeys(LastIndexAdded : integer); -var - IndexNumber : integer; - Key2 : PffByteArray; {!!.03} -begin - { Remove any keys that were successfully added before the error occurred. } - with Dictionary do begin - for IndexNumber := LastIndexAdded downto 1 do begin - IndexDscrptr := IndexDescriptor[IndexNumber]; - with IndexDscrptr^ do begin - if (idCount <> -1) then begin {a composite index} - CmpData.cdIndex := IndexNumber; - CmpData.cdAscend := idAscend; - CmpData.cdNoCase := idNoCase; - CmpData.cdKeyLen := idKeyLen; - Result := stGetBuiltCompositeKey(IndexNumber, aData, - idKeyLen, Key2); {!!.03} - if (Result = DBIERR_NONE) then try - stDeleteKeyPrim(idFile, aTI, aRefNr, Key2, {!!.03} - FFKeyCompareComposite, @CmpData, - BTreeChanged); {!!.05} - finally - FFFreeMem(Key2, CmpData.cdKeyLen); {!!.03} - end;{try..finally} - end - else {a user-defined index} begin - CmpData.cdIndex := IndexNumber; - CmpData.cdAscend := idAscend; - CmpData.cdNoCase := idNoCase; - CmpData.cdKeyLen := idKeyLen; - FFGetMem(Key, CmpData.cdKeyLen); - try - BuildKey := stGetUserBuildKey(IndexNumber); - Compare := stGetUserCompareKey(IndexNumber); - if BuildKey(IndexNumber, aData, Key2^, CmpData.cdKeyLen) then {!!.03} - stInsertKeyPrim(idFile, aTI, aRefNr, - Key2, Compare, @CmpData); {!!.03} - finally - FFFreeMem(Key2, CmpData.cdKeyLen); {!!.03} - end;{try..finally} - end; - end; - end; - {delete the internal RefNr key} - with CmpData do begin - cdDict := pointer(Dictionary); - cdIndex := 0; - cdFldCnt := 0; - cdPartLen := 0; - cdAscend := true; {for index 0} - cdNoCase := true; {for index 0} - end; - stDeleteKeyPrim(0, aTI, aRefNr, PffByteArray(@aRefNr), - FFKeyCompareI64, @CmpData, BTreeChanged); {!!.05} - end; -end; - -begin - Result := DBIERR_NONE; - with CmpData do begin - cdDict := pointer(Dictionary); - cdIndex := 0; - cdFldCnt := 0; - cdPartLen := 0; - cdAscend := true; {for index 0} - cdNoCase := true; {for index 0} - end; - with Dictionary do begin - if not stInsertKeyPrim(0, aTI, aRefNr, PffByteArray(@aRefNr), - FFKeyCompareI64, @CmpData) then begin - Result := DBIERR_KEYVIOL; - Exit; - end; - for IndexNumber := 1 to pred(IndexCount) do begin - IndexDscrptr := IndexDescriptor[IndexNumber]; - with IndexDscrptr^ do begin - if (idCount <> -1) then begin {a composite index} - CmpData.cdIndex := IndexNumber; - CmpData.cdAscend := idAscend; - CmpData.cdNoCase := idNoCase; - CmpData.cdKeyLen := idKeyLen; - Result := stGetBuiltCompositeKey(IndexNumber, aData, idKeyLen, Key); - if (Result <> DBIERR_NONE) then - Exit; - try - if not stInsertKeyPrim(idFile, aTI, aRefNr, Key, - FFKeyCompareComposite, @CmpData) then begin -// if UseInternalRollBack then {Deleted !!.11} - RollBackInsertKeys(Pred(IndexNumber)); - Result := DBIERR_KEYVIOL; - Exit; - end; - finally - FFFreeMem(Key, idKeyLen); {!!.06} - end;{try..finally} - end - else {a user-defined index} begin - CmpData.cdIndex := IndexNumber; - CmpData.cdAscend := idAscend; - CmpData.cdNoCase := idNoCase; - CmpData.cdKeyLen := idKeyLen; - FFGetMem(Key, CmpData.cdKeyLen); - try - BuildKey := stGetUserBuildKey(IndexNumber); - Compare := stGetUserCompareKey(IndexNumber); - if BuildKey(IndexNumber, aData, Key^, CmpData.cdKeyLen) then - if not stInsertKeyPrim(idFile, aTI, aRefNr, - Key, Compare, @CmpData) then begin -// if UseInternalRollBack then {Deleted !!.11} - RollBackInsertKeys(Pred(IndexNumber)); - Result := DBIERR_KEYVIOL; - Exit; - end; - finally - FFFreeMem(Key, CmpData.cdKeyLen); - end;{try..finally} - end; - end; - end; - end; -end; -{--------} -function TffSrTable.stUpdateKeysForRecord(aCursorID : TffCursorID; - aTI : PffTransInfo; - aRefNr : TffInt64; - aData, - aOldData : PffByteArray; {!!.05} - var aKeyChanged : Boolean) : TffResult; {!!.05} -{Reorganized !!.10} -var - IndexNumber : Integer; - CurrentIndexNum : Integer; {!!.05} - IndexDscrptr : PffIndexDescriptor; - OldKey : PffByteArray; - NewKey : PffByteArray; - CompResult : Integer; - BuildKey : TffKeyBuildFunc; - Compare : TffKeyCompareFunc; - CmpData : TffCompareData; - OldKeyBuilt : Boolean; - NewKeyBuilt : Boolean; - IndexChanged : array [1..255] of Boolean; - -Procedure RollbackUpdateKeys( LastIndexUpdated : Integer; - DoLastInsertOnly : Boolean); -var - OldKey2 : PffByteArray; - NewKey2 : PffByteArray; - IndexNumber2 : Integer; -begin - for IndexNumber2 := LastIndexUpdated downto 1 do begin - IndexDscrptr := Dictionary.IndexDescriptor[IndexNumber2]; - OldKey2 := nil; - NewKey2 := nil; - CmpData.cdIndex := IndexNumber2; - CmpData.cdAscend := IndexDscrptr^.idAscend; - CmpData.cdNoCase := IndexDscrptr^.idNoCase; - CmpData.cdKeyLen := IndexDscrptr^.idKeyLen; - with IndexDscrptr^ do - try - if (idCount <> -1) then begin {a composite index} - Result := stGetBuiltCompositeKey(IndexNumber2, aOldData, - idKeyLen, OldKey2); - if (Result = DBIERR_NONE) then - Result := stGetBuiltCompositeKey(IndexNumber2, aData, - idKeyLen, NewKey2); - if (Result <> DBIERR_NONE) then - Continue; {carry on with the next index in case of error} - CompResult := FFKeyCompareComposite(OldKey2^, NewKey2^, @CmpData); - if (CompResult <> 0) then begin - if (not DoLastInsertOnly) then - {Remove the NewKey on this index} - stDeleteKeyPrim(idFile, aTI, aRefNr, NewKey2, - FFKeyCompareComposite, @CmpData, - IndexChanged[IndexNumber2]); {!!.05} - {Restore the OldKey value on this index} - stInsertKeyPrim(idFile, aTI, aRefNr, OldKey2, - FFKeyCompareComposite, @CmpData); - end; - end - else {a user-defined index} begin - BuildKey := stGetUserBuildKey(IndexNumber2); - Compare := stGetUserCompareKey(IndexNumber2); - FFGetMem(OldKey2, CmpData.cdKeyLen); - FFGetMem(NewKey2, CmpData.cdKeyLen); - OldKeyBuilt := BuildKey(IndexNumber2, aOldData, - OldKey2^, CmpData.cdKeyLen); - NewKeyBuilt := BuildKey(IndexNumber2, aData, - NewKey2^, CmpData.cdKeyLen); - if OldKeyBuilt and NewKeyBuilt then - CompResult := Compare(OldKey2^, NewKey2^, @CmpData) - else if (OldKeyBuilt or NewKeyBuilt) then - CompResult := 1 {value doesn't matter so long as it's <> 0} - else - CompResult := 0; - if (CompResult <> 0) then begin - if NewKeyBuilt and (not DoLastInsertOnly) then - {Remove the NewKey on this index} - stDeleteKeyPrim(idFile, aTI, aRefNr, - NewKey2, Compare, @CmpData, - IndexChanged[IndexNumber2]); {!!.05} - if OldKeyBuilt then - {Restore the OldKey value on this index} - stInsertKeyPrim(idFile, aTI, aRefNr, - OldKey2, Compare, @CmpData); - end; - end; { if } - finally - if Assigned(NewKey2) then - FFFreeMem(NewKey2, CmpData.cdKeyLen); - if Assigned(OldKey2) then - FFFreeMem(OldKey2, CmpData.cdKeyLen); - end;{try..finally} - end; { for } -end; -begin - Result := DBIERR_NONE; - CurrentIndexNum := TffSrBaseCursor(aCursorID).IndexID; {!!.05} - aKeyChanged := False; {!!.05} - with CmpData do begin - cdDict := pointer(Dictionary); - cdFldCnt := 0; - cdPartLen := 0; - end; - with Dictionary do try - for IndexNumber := 1 to pred(IndexCount) do begin - IndexChanged[IndexNumber] := False; - IndexDscrptr := IndexDescriptor[IndexNumber]; - OldKey := nil; - NewKey := nil; - CmpData.cdIndex := IndexNumber; - CmpData.cdAscend := IndexDscrptr^.idAscend; - CmpData.cdNoCase := IndexDscrptr^.idNoCase; - CmpData.cdKeyLen := IndexDscrptr^.idKeyLen; - with IndexDscrptr^ do - try - if (idCount <> -1) then begin {a composite index} - Result := stGetBuiltCompositeKey(IndexNumber, aOldData, idKeyLen, OldKey); - if (Result = DBIERR_NONE) then - Result := stGetBuiltCompositeKey(IndexNumber, aData, idKeyLen, NewKey); - if (Result <> DBIERR_NONE) then - Exit; - CompResult := FFKeyCompareComposite(OldKey^, NewKey^, @CmpData); - if (CompResult <> 0) then begin - if (IndexNumber = CurrentIndexNum) then {!!.05} - aKeyChanged := True; {!!.05} - if not stDeleteKeyPrim(idFile, aTI, aRefNr, OldKey, - FFKeyCompareComposite, @CmpData, - IndexChanged[IndexNumber]) then begin {!!.05} - Result := DBIERR_KEYVIOL; - Exit; - end; - if not stInsertKeyPrim(idFile, aTI, aRefNr, NewKey, - FFKeyCompareComposite, @CmpData) then begin -// if UseInternalRollBack then {Deleted !!.11} - RollbackUpdateKeys(IndexNumber,True); - Result := DBIERR_KEYVIOL; - Exit; - end; - IndexChanged[IndexNumber] := True; {!!.06} - end; - end - else {a user-defined index} begin - BuildKey := stGetUserBuildKey(IndexNumber); - Compare := stGetUserCompareKey(IndexNumber); - FFGetMem(OldKey, CmpData.cdKeyLen); - FFGetMem(NewKey, CmpData.cdKeyLen); - OldKeyBuilt := BuildKey(IndexNumber, aOldData, OldKey^, CmpData.cdKeyLen); - NewKeyBuilt := BuildKey(IndexNumber, aData, NewKey^, CmpData.cdKeyLen); - if OldKeyBuilt and NewKeyBuilt then - CompResult := Compare(OldKey^, NewKey^, @CmpData) - else if (OldKeyBuilt or NewKeyBuilt) then - CompResult := 1 {value doesn't matter so long as it's <> 0} - else - CompResult := 0; - if (CompResult <> 0) then begin - if (IndexNumber = CurrentIndexNum) then {!!.05} - aKeyChanged := True; {!!.05} - if OldKeyBuilt then - if not stDeleteKeyPrim(idFile, aTI, aRefNr, - OldKey, Compare, @CmpData, - IndexChanged[IndexNumber]) then begin {!!.05} -// if UseInternalRollBack then {Deleted !!.11} - RollbackUpdateKeys(Pred(IndexNumber),False); - Result := DBIERR_KEYVIOL; - Exit; - end; - if NewKeyBuilt then - if not stInsertKeyPrim(idFile, aTI, aRefNr, - NewKey, Compare, @CmpData) then begin -// if UseInternalRollBack then {Deleted !!.11} - RollbackUpdateKeys(IndexNumber,True); - Result := DBIERR_KEYVIOL; - Exit; - end; - IndexChanged[IndexNumber] := True; - end; - end; { if } - finally - if Assigned(NewKey) then - FFFreeMem(NewKey, idKeyLen); - if Assigned(OldKey) then - FFFreeMem(OldKey, idKeyLen); - end;{try..finally} - end; { for } - finally {with dictionary do try...} - {Inform other cursors at end when we are sure everything worked} - if Result = DBIERR_NONE then begin - for IndexNumber := 1 to pred(IndexCount) do - if IndexChanged[IndexNumber] then - btInformCursors(aCursorID, roModify, aRefNr, IndexNumber); - end; - end; { with dictionary do } -end; -{====================================================================} - -{===TffSrSystemTable=================================================} -function TffSrSystemTable.IsServerTable : boolean; -begin - Result := True; -end; -{====================================================================} - -{===TffSrTableList===================================================} -constructor TffSrTableList.Create; -begin - inherited Create; - tlList := TffThreadList.Create; -end; -{--------} -destructor TffSrTableList.Destroy; -begin - tlList.Free; - inherited Destroy; -end; -{--------} -procedure TffSrTableList.AddTable(aTable : TffSrBaseTable); -begin - tlList.Insert(aTable); -end; -{--------} -function TffSrTableList.BeginRead : TffSrTableList; -begin - tlList.BeginRead; - Result := Self; -end; -{--------} -function TffSrTableList.BeginWrite : TffSrTableList; -begin - tlList.BeginWrite; - Result := Self; -end; -{--------} -procedure TffSrTableList.DeleteTable(aTableID : Longint); -begin - tlList.Delete(aTableID); -end; -{--------} -procedure TffSrTableList.EndRead; -begin - tlList.EndRead; -end; -{--------} -procedure TffSrTableList.EndWrite; -begin - tlList.EndWrite; -end; -{--------} -function TffSrTableList.GetTableFromName(const aTableName : TffTableName) : TffSrBaseTable; -var - Inx : integer; -begin - for Inx := 0 to pred(tlList.Count) do begin - Result := TffSrTable(tlList[Inx]); - if (FFCmpShStrUC(Result.BaseName, aTableName, 255) = 0) then - Exit; - end; - Result := nil; -end; -{--------} -function TffSrTableList.GetTableItem(Find : TffListFindType; Value : Longint) : TffSrBaseTable; -var - Inx : integer; -begin - Result := nil; - if (Find = ftFromID) then begin - Inx := tlList.Index(Value); - if (Inx <> -1) then - Result := TffSrTable(tlList[Inx]); - end - else {Find = ftFromIndex} begin - if (0 <= Value) and (Value < tlList.Count) then - Result := TffSrTable(tlList[Value]); - end; -end; -{--------} -procedure TffSrTableList.RemoveIfUnused(aTable : TffSrBaseTable); -begin - { Assumption: TableList has not been write locked by the calling routine. } - tlList.BeginWrite; - try - if (aTable.CursorList.CursorCount = 0) and - (aTable.OpenIntents = 0) then begin - aTable.Free; - end; - finally - tlList.EndWrite; - end; -end; -{--------} -procedure TffSrTableList.RemoveUnusedTables; -var - Inx : Integer; - Table : TffSrTable; -begin - { Assumption: TableList has not been write locked by the calling routine. } - tlList.BeginWrite; - try - for Inx := pred(TableCount) downto 0 do begin - Table := TffSrTable(tlList[Inx]); - if (Table.CursorList.CursorCount = 0) and - (Table.OpenIntents = 0) then -{Begin !!.06} - try - Table.Free; - except - on E:Exception do - if FOwner <> nil then - FOwner.seForce('Exception removing unused table: %s', - [E.Message], - FOwner.bseGetReadOnly); - end; -{End !!.06} - end; - finally - tlList.EndWrite; - end; -end; -{--------} -function TffSrTableList.TableCount : integer; -begin - Result := tlList.Count; -end; -{=====================================================================} - -{== TffSrDatabase ====================================================} -constructor TffSrDatabase.Create(anEngine : TffServerEngine; - aSession : TffSrSession; - aFolder : TffSrFolder; - anAlias : TffName; - aOpenMode : TffOpenMode; - aShareMode : TffShareMode; - aTimeout : Longint; - aCheckSpace : Boolean); {!!.11} -var {!!.11} - OSVerInfo : TOSVersionInfo; {!!.11} -begin - inherited Create(aTimeout); - dbAlias := FFShStrAlloc(anAlias); - dbEngine := anEngine; - dbExtenders := nil; - soClient := aSession.Client; - dbCursorList := TffSrCursorList.Create; - dbFolder := aFolder; -// FDeadlocked := False; - dbOpenMode := aOpenMode; - dbSession := aSession; - dbShareMode := aShareMode; - dbStmtList := TffSrStmtList.Create; {!!.10} - { Initialize the transaction information. } - FFGetZeroMem(dbTI, SizeOf(TffTransInfo)); - with dbTI^ do begin - tirTrans := nil; - tirLockMgr := dbFolder.LockMgr; - end; - dbTrans := nil; - FreeOnRemove := True; - Session.DatabaseList.BeginWrite; - try - Session.DatabaseList.AddDatabase(Self); - finally - Session.DatabaseList.EndWrite; - end; - - OSVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo); {!!.11 - Start} - if ((aCheckSpace) and - (GetVersionEx(OSVerInfo))) then - dbCheckSpace := ((OSVerInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) or - ((OSVerInfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS) and - (OSVerInfo.dwBuildNumber > 1000))) - else - dbCheckSpace := False; {!!.11 - End} -end; -{--------} -destructor TffSrDatabase.Destroy; -var - anIndex : Longint; - anExtender : TffBaseEngineExtender; -begin - - { If a transaction is active then the transaction must be rolled back. } - if assigned(dbTrans) then - dbEngine.seTransactionRollback(Self); - - { Free all registered extenders. } - if assigned(dbExtenders) then begin - for anIndex := pred(dbExtenders.Count) downto 0 do begin - anExtender := TffBaseEngineExtender - (TffIntListItem(dbExtenders[anIndex]).KeyAsInt); - anExtender.Free; - end; - dbExtenders.Free; - end; - - FFShStrFree(dbAlias); -{Begin !!.10} - for anIndex := pred(dbStmtList.StmtCount) downto 0 do - dbEngine.SQLEngine.FreeStmt(dbStmtList.Stmt[ftFromIndex, anIndex].Handle); - dbStmtList.Free; -{End !!.10} - dbCursorList.Free; - Folder.DecRefCount; - dbFolder := nil; - FFFreeMem(dbTI, SizeOf(TffTransInfo)); - inherited Destroy; -end; -{--------} -function TffSrDatabase.CanClose(const Mark : boolean) : boolean; -begin - CursorList.BeginRead; - dbStmtList.BeginRead; {!!.10} - try - Result := (inherited CanClose(Mark)) and {!!.06} - CursorList.HasClosableState(Mark) and {!!.06}{!!.10} - dbStmtList.CanClose(Mark); {!!.10} - finally - dbStmtList.EndRead; {!!.10} - CursorList.EndRead; - end; -end; -{--------} -procedure TffSrDatabase.ForceClose; -begin - inherited ForceClose; - -{Begin !!.01} - { If a transaction is active then the transaction must be rolled back. } - if assigned(dbTrans) then - dbEngine.seTransactionRollback(Self); -{End !!.01} - - CursorList.BeginRead; - dbStmtList.BeginRead; {!!.10} - try - CursorList.ForceClose; - dbStmtList.ForceClose; {!!.10} - finally - dbStmtList.EndRead; {!!.10} - CursorList.EndRead; - end; -end; -{--------} -function TffSrDatabase.NotifyExtenders(const anAction : TffEngineAction; - const aFailAction : TffEngineAction) : TffResult; -var - anExtender : TffBaseEngineExtender; - anIndex : Longint; - anIndex2 : Longint; -begin - Result := DBIERR_NONE; - if assigned(dbExtenders) then - for anIndex := 0 to pred(dbExtenders.Count) do begin - anExtender := TffBaseEngineExtender - (TffIntListItem(dbExtenders[anIndex]).KeyAsInt); - if (anAction in anExtender.InterestedActions) or - (anExtender.InterestedActions = []) then begin - Result := anExtender.Notify(Self, anAction); {!!.06} - {since we aren't ignoring Notify's error code, we must - capture it. If an extender reports an error we will not - process the rest of the extenders and we will notify the - previous extenders that we are "undoing" the previous action} - if Result <> DBIERR_NONE then begin - for anIndex2 := 0 to pred(anIndex) do begin - anExtender := TffBaseEngineExtender - (TffIntListItem(dbExtenders[anIndex2]).KeyAsInt); - anExtender.Notify(self, aFailAction); - end; - break; - end; - end; - end; -end; -{--------} -procedure TffSrDatabase.dbAddExtender(anExtender : TffBaseEngineExtender); -var - anItem : TffIntListItem; -begin - if assigned(anExtender) then begin - if not assigned(dbExtenders) then - dbExtenders := TffThreadList.Create; - anItem := TffIntListItem.Create(Longint(anExtender)); - dbExtenders.Insert(anItem); - end; -end; -{--------} -function TffSrDatabase.dbGetAlias : TffName; -begin - Result := dbAlias^; -end; -{--------} -function TffSrDatabase.dbGetTransID : TffTransID; -begin - if assigned(dbTrans) then - Result := dbTrans.TransactionID - else - Result := 0; -end; -{--------} -function TffSrDatabase.dbGetTransLSN : TffWord32; -begin - if assigned(dbTrans) then - Result := dbTrans.LSN - else - Result := 0; -end; -{Begin !!.11} -{--------} -procedure TffSrDatabase.dbSetExistingTableVersion(const Version : Longint); -begin - dbFolder.ExistingTableVersion := Version; -end; -{--------} -procedure TffSrDatabase.dbSetNewTableVersion(const Version : Longint); -begin - dbFolder.NewTableVersion := Version; -end; -{--------} -procedure TffSrDatabase.dbSetPackSrcTableVersion(const Version : Longint); -begin - dbFolder.PackSrcTableVersion := Version; -end; -{End !!.11} -{--------} -procedure TffSrDatabase.dbSetTrans(aTransaction : TffSrTransaction); -begin - dbTrans := aTransaction; - dbTI^.tirTrans := aTransaction; -end; -{--------} -function TffSrDatabase.dbGetDatabaseID : TffDatabaseID; -begin - Result := TffDatabaseID(Self); -end; -{Begin !!.03} -{--------} -procedure TffSrDatabase.RequestClose; -begin - CursorList.BeginRead; - dbStmtList.BeginRead; {!!.10} - try - inherited RequestClose; - CursorList.RequestClose; - dbStmtList.RequestClose; {!!.10} - finally - dbStmtList.EndRead; {!!.10} - CursorList.EndRead; - end; -end; -{End !!.03} -{--------} -function TffSrDatabase.ShouldClose : boolean; -{Begin !!.01} -var - aCursor : TffSrBaseCursor; - aStmt : TffBasePreparedStmt; {!!.10} - anInx : Longint; -begin - Result := inherited ShouldClose; - { Database can close? } - if Result then begin - { Yes. Lock the cursor list for read-only access. } - CursorList.BeginRead; - dbStmtList.BeginRead; {!!.10} - try - { Is a transaction active? } - if assigned(dbTrans) then begin - { Yes. See if state of all cursors will allow us to rollback the - transaction. } -{Begin !!.10} - for anInx := 0 to pred(dbStmtList.StmtCount) do begin - aStmt := dbStmtList.Stmt[ftFromIndex, anInx]; - if aStmt.State <> ffosClosing then begin - Result := False; - Break; - end; - end; - if Result then -{End !!.10} - for anInx := 0 to pred(CursorList.CursorCount) do begin - aCursor := CursorList.Cursor[ftFromIndex, anInx]; - if aCursor.State <> ffosClosing then begin - Result := False; - Break; - end; - end; - if Result then - dbEngine.seTransactionRollback(Self); - end - else - { No transaction is active. See if cursors may be closed. } - Result := Result and CursorList.ShouldClose and {!!.10} - dbStmtList.ShouldClose; {!!.10} - finally - dbStmtList.EndRead; {!!.10} - CursorList.EndRead; - end; - end; -{End !!.01} -end; -{====================================================================} - -{===TffSrDatabaseList================================================} -procedure TffSrDatabaseList.AddDatabase(aDatabase : TffSrDatabase); -begin - solList.Insert(aDatabase); -end; -{--------} -function TffSrDatabaseList.DatabaseCount : integer; -begin - Result := solList.Count; -end; -{--------} -procedure TffSrDatabaseList.DeleteDatabase(aDatabaseID : Longint); -begin - solList.Delete(aDatabaseID); -end; -{--------} -function TffSrDatabaseList.GetDatabaseForFolder(aFolder : TffSrFolder) : TffSrDatabase; -var - Inx : integer; -begin - for Inx := 0 to pred(solList.Count) do begin - Result := TffSrDatabase(solList[Inx]); - if (Result.Folder = aFolder) then - Exit; - end; - Result := nil; -end; -{--------} -function TffSrDatabaseList.GetDatabaseItem(Find : TffListFindType; Value : Longint) : TffSrDatabase; -var - Inx : integer; -begin - Result := nil; - if (Find = ftFromID) then begin - Inx := solList.Index(Value); - if (Inx <> -1) then - Result := TffSrDatabase(solList[Inx]); - end - else {Find = ftFromIndex} begin - if (0 <= Value) and (Value < solList.Count) then - Result := TffSrDatabase(solList[Value]); - end; -end; -{====================================================================} - - -{===TffSrSession===============================================} -constructor TffSrSession.Create(aClient : TffSrClient; - const aIsDef : boolean; - const aTimeout : Longint); -begin - inherited Create(aTimeout); - soClient := aClient; - ssDatabaseList := TffSrDatabaseList.Create; - ssIsDefault := aIsDef; - FreeOnRemove := true; - aClient.SessionList.BeginWrite; - try - aClient.SessionList.AddSession(Self); - finally - aClient.SessionList.EndWrite; - end; -end; -{--------} -destructor TffSrSession.Destroy; -begin - ssDatabaseList.Free; - inherited Destroy; -end; -{--------} -function TffSrSession.CanClose(const Mark : boolean) : boolean; -begin - DatabaseList.BeginRead; - try - Result := (inherited CanClose(Mark)) and DatabaseList.CanClose(Mark); - finally - DatabaseList.EndRead; - end; -end; -{--------} -procedure TffSrSession.ForceClose; -begin - inherited ForceClose; - DatabaseList.BeginRead; - try - DatabaseList.ForceClose; - finally - DatabaseList.EndRead; - end; -end; -{--------} -function TffSrSession.ssGetSessionID : TffSessionID; -begin - Result := TffSessionID(Self); -end; -{Begin !!.03} -{--------} -procedure TffSrSession.RequestClose; -begin - DatabaseList.BeginRead; - try - inherited RequestClose; - DatabaseList.RequestClose; - finally - DatabaseList.EndRead; - end; -end; -{End !!.03} -{--------} -function TffSrSession.ShouldClose : boolean; -begin - DatabaseList.BeginRead; - try - Result := (inherited ShouldClose) and DatabaseList.ShouldClose; - finally - DatabaseList.EndRead; - end; -end; -{====================================================================} - -{Begin !!.10} -{===TffSrStmtList====================================================} -procedure TffSrStmtList.AddStmt(aStmt : TffBasePreparedStmt); -begin - solList.Insert(aStmt); -end; -{--------} -function TffSrStmtList.StmtCount : integer; -begin - Result := solList.Count; -end; -{--------} -procedure TffSrStmtList.DeleteStmt(aStmtID : TffSQLStmtID); -begin - solList.Delete(aStmtID); -end; -{--------} -function TffSrStmtList.GetStmt(Find : TffListFindType; Value : Longint) : TffBasePreparedStmt; -var - Inx : integer; -begin - Result := nil; - if (Find = ftFromID) then begin - Inx := solList.Index(Value); - if (Inx <> -1) then - Result := TffBasePreparedStmt(solList[Inx]); - end - else {Find = ftFromIndex} begin - if (0 <= Value) and (Value < solList.Count) then - Result := TffBasePreparedStmt(solList[Value]); - end; -end; -{--------} -procedure TffSrStmtList.RemoveForClient(const aClientID : TffClientID); -var - anInx : Longint; -begin - with solList.BeginWrite do - try - for anInx := Pred(solList.Count) downto 0 do begin - if TffBasePreparedStmt(solList[anInx]).ClientID = aClientID then - solList.DeleteAt(anInx); - end; - finally - solList.EndWrite; - end; -end; -{====================================================================} -{End !!.10} - -{===TffSrSessionList====================================================} -procedure TffSrSessionList.AddSession(aSession : TffSrSession); -begin - solList.Insert(aSession); -end; -{--------} -procedure TffSrSessionList.DeleteSession(aSessionID : Longint); -begin - solList.Delete(aSessionID); -end; -{--------} -function TffSrSessionList.slGetCurSess : TffSrSession; -begin - Result := slCurSess; -end; -{--------} -function TffSrSessionList.slGetSessionItem(Find : TffListFindType; Value : Longint) : TffSrSession; -var - Inx : Longint; -begin - Result := nil; - if (Find = ftFromID) then begin - Inx := solList.Index(Value); - if (Inx <> -1) then - Result := TffSrSession(solList[Inx]); - end - else {Find = ftFromIndex} - if (0 <= Value) and (Value < solList.Count) then - Result := TffSrSession(solList[Value]); -end; -{--------} -function TffSrSessionList.SessionCount : integer; -begin - Result := solList.Count; -end; -{--------} -procedure TffSrSessionList.slSetCurSess(CS : TffSrSession); -begin - if (slCurSess = nil) then - slCurSess := slDefSess; - if (slCurSess <> CS) then - if (CS = nil) then {CS=nil means the default session} - slCurSess := slDefSess - else - slCurSess := CS; -end; -{--------} -procedure TffSrSessionList.SetDefaultSession(aSession : TffSrSession); -begin - slDefSess := aSession; - CurrentSession := nil; -end; -{====================================================================} - - -{===TffSrClient=====================================================} -constructor TffSrClient.Create(aClientID : Longint; - const aClientName : TffNetName; - const aTimeout : Longint; - const aClientVersion : Longint; {!!.11} - aUser : TffUserItem; - anEngine : TffServerEngine); -//var {Deleted !!.03} -// DefSess : TffSrSession; {Deleted !!.03} -begin - inherited Create(aTimeout); - clAccepted := False; - clClientName := FFShStrAlloc(aClientName); - clClientVersion := aClientVersion; {!!.11} - clEngine := anEngine; - clExtenders := nil; - soLock := TffPadLock.Create; - clSessionList := TffSrSessionList.Create; - clFirstSession := TffSrSession.Create(Self, true, timeout); {!!.03} - SessionList.BeginWrite; - try - SessionList.SetDefaultSession(clFirstSession); {!!.03} - finally - SessionList.EndWrite; - end; - FreeOnRemove := true; - {Note: we do NOT save the reference to the user object, these get - destroyed and rebuilt ad hoc} - if (aUser <> nil) then - with aUser do begin - clUserID := UserID; - clFirst := FirstName; - clLast := LastName; - clRights := Rights; - end; -end; -{--------} -destructor TffSrClient.Destroy; -var - anExtender : TffBaseEngineExtender; - anIndex : Longint; -begin - - try {!!.03} - { Notify the extenders. } - if clAccepted then - NotifyExtenders(ffeaBeforeRemoveClient, ffeaNoAction); - - { Get rid of the rebuild status info associated with this client. } - clEngine.seCleanRebuildList(ClientID); - - { Free all registered extenders. } - if assigned(clExtenders) then begin - for anIndex := pred(clExtenders.Count) downto 0 do begin - anExtender := TffBaseEngineExtender - (TffIntListItem(clExtenders[anIndex]).KeyAsInt); - anExtender.Free; - end; - clExtenders.Free; - end; - - {Begin !!.03} - { Remove any SQL prepared statements associated with this client. } -// if Assigned(clEngine.seSQLEngine) then {Deleted !!.10} -// clEngine.seSQLEngine.RemoveForClient(ClientID); {Deleted !!.10} - {End !!.03} - - clSessionList.Free; - FFShStrFree(clClientName); - soLock.Free; - finally {!!.03} - inherited Destroy; - end; {!!.03} -end; -{--------} -procedure TffSrClient.AddClientExtender(anExtender : TffBaseEngineExtender); -var - anItem : TffIntListItem; -begin - if assigned(anExtender) then begin - if not assigned(clExtenders) then - clExtenders := TffThreadList.Create; - anItem := TffIntListItem.Create(Longint(anExtender)); - clExtenders.Insert(anItem); - end; -end; -{--------} -function TffSrClient.CanClose(const Mark : boolean) : boolean; -begin - SessionList.BeginRead; - try - Result := (inherited CanClose(Mark)) and SessionList.CanClose(Mark); - finally - SessionList.EndRead; - end; -end; -{--------} -function TffSrClient.clGetClientID : TffClientID; -begin - result := TffClientID(Self); -end; -{--------} -procedure TffSrClient.ForceClose; -begin - inherited ForceClose; - SessionList.BeginRead; - try - SessionList.ForceClose; - finally - SessionList.EndRead; - end; -end; -{--------} -function TffSrClient.clGetClientName : TffNetName; -begin - Result := clClientName^; -end; -{--------} -function TffSrClient.NotifyExtenders(const anAction : TffEngineAction; - const aFailAction : TffEngineAction) : TffResult; -var - anExtender : TffBaseEngineExtender; - anIndex : Longint; - anIndex2 : Longint; -begin - Result := DBIERR_NONE; - if assigned(clExtenders) then - for anIndex := 0 to pred(clExtenders.Count) do begin - anExtender := TffBaseEngineExtender - (TffIntListItem(clExtenders[anIndex]).KeyAsInt); - if (anAction in anExtender.InterestedActions) or - (anExtender.InterestedActions = []) then begin - Result := anExtender.Notify(Self, anAction); - { If an extender reports a failure, subsequent extenders will not be - notified of the action. } - if Result <> DBIERR_NONE then begin - for anIndex2 := 0 to pred(anIndex) do begin - anExtender := TffBaseEngineExtender(TffIntListItem(clExtenders[anIndex2]).KeyAsInt); - anExtender.Notify(self, aFailAction); - end; - break; - end; - end; - end; -end; -{Begin !!.03} -{--------} -procedure TffSrClient.RequestClose; -begin - SessionList.BeginRead; - try - inherited RequestClose; - SessionList.RequestClose; - finally - SessionList.EndRead; - end; -end; -{End !!.03} -{--------} -function TffSrClient.ShouldClose : boolean; -begin - SessionList.BeginRead; - try - Result := (inherited ShouldClose) and SessionList.ShouldClose; - finally - SessionList.EndRead; - end; -end; -{====================================================================} - - -{===TffSrClientList====================================================} -procedure TffSrClientList.AddClient(aClient : TffSrClient); -begin - solList.Insert(aClient) -end; -{--------} -function TffSrClientList.ClientCount : integer; -begin - Result := solList.Count; -end; -{--------} -procedure TffSrClientList.DeleteClient(aClientID : Longint); -begin - solList.Delete(aClientID); -end; -{--------} -function TffSrClientList.GetClientItem(Find : TffListFindType; Value : Longint) : TffSrClient; -var - Inx : integer; -begin - Result := nil; - if (Find = ftFromID) then begin - Inx := solList.Index(Value); - if (Inx <> -1) then - Result := TffSrClient(solList[Inx]); - end - else {Find = ftFromIndex} - if (0 <= Value) and (Value < solList.Count) then - Result := TffSrClient(solList[Value]); -end; -{--------} -procedure TffSrClientList.SetClientItem(Inx : integer; CI : TffSrClient); -begin - solList[Inx] := CI; -end; -{=====================================================================} - - -{===TffServerEngine===================================================} -constructor TffServerEngine.Create(aOwner : TComponent); -begin - inherited Create(aOwner); - CursorClass := TffSrCursor; {!!.06} - - FileProcsInitialize; - - seCanLog := False; - - seClientHash := TffHash.Create(ffc_Size127); {!!.02} - - {create the configuration object} - seConfig := TffServerConfiguration.Create; - seConfigLoaded := False; - - {create the client list, the open database list, the open table - list, the transaction list} - seClientList := TffSrClientList.Create; - seSessionList := TffSrSessionList.Create; - seDatabaseList := TffSrDatabaseList.Create; - seTableList := TffSrTableList.Create; - seTableList.Owner := Self; {!!.06} - seCursorList := TffSrCursorList.Create; - - seConfigDir := ''; - seFolderList := TffSrFolderList.Create; - seRebuildList := TffSrRebuildStatusList.Create; - - { Create the buffer manager. Temporary storage size will be updated after - reading FFSINFO. } - seBufMgr := TffBufferManager.Create(ConfigDir, ffcl_TempStorageSize); - - { Ensure the seEvtClientDone is set to nil. } - seEvtClientDone := nil; - seOnRecoveryCheck := nil; - seScriptFile := ''; - -end; -{--------} -destructor TffServerEngine.Destroy; -begin - { Tell garbage collector to end. } - if assigned(seGarbageThread) then begin - seGarbageThread.DieDieDie; - seGarbageThread.WaitFor; - seGarbageThread.Free; - end; - - { Make sure we are shutdown. } - State := ffesInactive; - - FFNotifyDependents(ffn_Destroy); {!!.01}{!!.11 moved} - if Assigned(seSQLEngine) then {!!.11} - seSQLEngine.FFRemoveDependent(Self); {!!.11} - - seCursorList.Free; - seTableList.Free; - seDatabaseList.Free; - seSessionList.Free; - seClientList.Free; - seFolderList.Free; - seConfig.Free; - seBufMgr.Free; - seRebuildList.Free; - seClientHash.Free; {!!.02} - - inherited Destroy; -end; -{--------} -{Rewritten !!.11} -procedure TffServerEngine.FFNotificationEx(const AOp : Byte; AFrom : TffComponent; - const AData : TffWord32); -var - RecalcLogFlag : boolean; -begin - RecalcLogFlag := (AFrom = FEventLog); - inherited; - if (AFrom = seSQLEngine) and (AOp in [ffn_Destroy, ffn_Remove]) then begin - seSQLEngine.FFRemoveDependent(Self); - seSQLEngine := nil; - end; - - if RecalcLogFlag then - seSetLoggingState; -end; -{--------} -procedure TffServerEngine.scInitialize; -begin - LogAll(['FF Server initializing...', - format(' Version: %5.4f %s', - [ffVersionNumber / 10000, - ffSpecialString])]); - seLoadConfig; - -{Begin !!.06} - Log('Performing recovery check...'); - if assigned(seOnRecoveryCheck) then - seOnRecoveryCheck(Self) - else - with FFRecoveryClass.Create do - try - Check(Self); - finally - Free; - end; - Log('Finished recovery check...'); -{End !!.06} - - { Perform garbage collection? } - if Configuration.GeneralInfo^.giCollectEnabled then - { Yes. Start the garbage collector thread. } - seGarbageThread := TffTimerThread.Create - (Configuration.GeneralInfo^.giCollectFreq, - seCollectGarbage, 0, false); - - seLastFlush := GetTickCount; {!!.01} - - {$IFDEF DebugDelCount} - FFTBDATA.aLog := FEventLog; - {$ENDIF} - {$IFDEF RAMPageCheck} - FFSRBASE.aLog := FEventLog; - {$ENDIF} -end; -{--------} -procedure TffServerEngine.scPrepareForShutdown; -var - aClient : TffSrClient; - ClientDoneEvent : TffEvent; - i : Integer; -begin - Log('FF Server preparing for shutdown.'); - - { Kill the garbage collection thread. } {!!.01} - if assigned(seGarbageThread) then {!!.01} - seGarbageThread.DieDieDie; {!!.01} - - {Begin !!.03} - { Ask the SQL engine to get rid of any remaining prepared statements. } - if Assigned(seSQLEngine) then - seSQLEngine.RequestClose; - {End !!.03} - - if ClientList.ClientCount > 0 then - { Attempt to clear out those clients in a "closing" state. } - seCollectGarbage(0); - - FFNotifyDependents(ffn_Deactivate); {!!.03} - - if ClientList.ClientCount > 0 then begin - {Create an event to wait on the clients to finish what they're - doing. We will give them a chance to signal us that they're done - and then we'll just cut them off.} - ClientDoneEvent := TffEvent.Create; - try - seEvtClientDone := ClientDoneEvent; - try - ClientDoneEvent.WaitFor(ffc_ClientShutdownTime); - except - for i := Pred(ClientList.ClientCount) downto 0 do begin - aClient := ClientList.Client[ftFromIndex, i]; - aClient.ForceClose; - seClientRemovePrim(aClient); - end; - end; - finally - seEvtClientDone := nil; - ClientDoneEvent.Free; - end; - end; -end; -{--------} -procedure TffServerEngine.scStartup; -begin - Log('FF Server started.'); - - seStartTime := GetTickCount; {!!.10} - CoCreateGUID(seUniqueID); {!!.10} -end; -{--------} -procedure TffServerEngine.scShutDown; -begin - Log('FF Server shutting down.'); -end; -{--------} -procedure TffServerEngine.seCleanRebuildList(const aClientID : TffClientID); -begin - if assigned(seRebuildList) then - seRebuildList.DeleteAllForClient(aClientID); -end; -{--------} -procedure TffServerEngine.seCollectGarbage(const aTimerEventCookie : Longint); -begin - try {!!.01} - if assigned(seSQLEngine) then {!!.01} - seSQLEngine.CollectGarbage; {!!.01} - ClientList.RemoveUnused; -// SessionList.RemoveUnused; {Deleted !!.10} -// DatabaseList.RemoveUnused; {Deleted !!.10} -// CursorList.RemoveUnused; {Deleted !!.10} - TableList.RemoveUnusedTables; - FolderList.RemoveUnusedFolders; - { Time to flush pools? } {!!.01} - if (GetTickCount - seLastFlush) >= ffcl_FlushRate then begin {!!.01} - FFLockContainerPool.Flush; {!!.01} - FFSemPool.Flush; {!!.01} -{Begin !!.05} - seBufMgr.Lock; - try - seBufMgr.FlushPools([]); {!!.01} - finally - seBufMgr.Unlock; - end; -{End !!.05} - seLastFlush := GetTickCount; {!!.01} - end; - except {!!.01} - on E:EffException do {!!.01} - seForce('Error in garbage collection: %s', {!!.01}{!!.06 - Start} - [E.Message], {!!.01} - bseGetReadOnly); {!!.01}{!!.06 - End} - end; {!!.01} -end; -{--------} -function TffServerEngine.seDatabaseAddAliasPrim(const aAlias : TffName; - const aPath : TffPath; - aCheckSpace : Boolean) {!!.11} - : TffResult; -begin - { Assumption: Thread-safeness enforced at a higher level. } - - { Does the alias already exist? } - if seConfig.AliasList.AliasExists(aAlias) then - { No. Return error code. } - Result := DBIERR_NAMENOTUNIQUE - else begin - { Yes. Add the new Alias and its path. } - seConfig.AddAlias(aAlias, aPath, aCheckSpace); {!!.11} - Result := DBIERR_NONE; - end; -end; -{--------} -function TffServerEngine.seDeleteTable(const aDB : TffSrDatabase; - const aTableName : TffTableName) - : TffResult; -var - Dict : TffDataDictionary; -begin - Dict := TffDataDictionary.Create(4096);; - try - Result := seGetDictionary(aDB, aTableName, Dict); - { Retrieved the dictionary? } - if Result = DBIERR_NONE then begin - { Yes. Delete the files specified by the dictionary. } - FFTblHlpDelete(aDB.Folder.Path, aTableName, Dict); - Result := DBIERR_NONE; - end - else if (Result <> DBIERR_INVALIDTABLENAME) and - (Result <> DBIERR_NOSUCHTABLE) then - { No. Assuming the result code is not one of the above errors then the - file exists but has no dictionary. Delete the data file. } - FFDeleteFile(FFMakeFullFileName(aDB.Folder.Path, - FFMakeFileNameExt(aTableName, - ffc_ExtForData))); - finally - Dict.Free; - end; -end; -{--------} -function TffServerEngine.seGetCollectFrequency : Longint; -begin - Result := Configuration.GeneralInfo^.giCollectFreq; -end; -{--------} -function TffServerEngine.seGetCollectGarbage : Boolean; -begin - Result := Configuration.GeneralInfo^.giCollectEnabled; -end; -{--------} -function TffServerEngine.seGetConfig : TffServerConfiguration; -begin - if (not seConfigLoaded) then - seLoadConfig; - Result := seConfig; -end; -{Begin !!.01} -{--------} -function TffServerEngine.seGetMaxRAM : Longint; -begin - Result := Configuration.GeneralInfo^.giMaxRAM; -end; -{End !!.01} -{--------} -function TffServerEngine.seGetScriptFile : string; {!!.11} -begin - Result := seScriptFile; -end; -{--------} -function TffServerEngine.seIsServerTable(const aTableName : TffTableName) : boolean; -var - aPrefix, aSuffix : TffTableName; -begin - Result := False; - aPrefix := Uppercase(Copy(aTableName, 1, 3)); - { Is this prefixed with characters normally used for server tables? } - if (aPrefix = ffc_SavPrefix) or - (aPrefix = ffc_StdPrefix) or - (aPrefix = ffc_TmpPrefix) then begin - aSuffix := Uppercase(Copy(aTableName, 4, 5)); - Result := (aSuffix = ffc_AliasSuffix) or - (aSuffix = ffc_IndexSuffix) or - (aSuffix = ffc_InfoSuffix) or - (aSuffix = ffc_UserSuffix); - end; -end; -{--------} -function TffServerEngine.seGetDictionary(const aDB : TffSrDatabase; - const aTableName : TffTableName; - var aDict : TffDataDictionary) : TffResult; -var - Table : TffSrTable; - TableDataFile : TffFileNameExt; -begin - Result := DBIERR_NONE; - Assert(assigned(aDB)); - try - Table := TffSrTable(GetTableInstance(aDB.Folder, aTableName)); - if Table = nil then begin - if not FFVerifyFileName(aTableName) then begin - Result := DBIERR_INVALIDTABLENAME; - Exit; - end; - TableDataFile := FFMakeFileNameExt(aTableName, ffc_ExtForData); - if not FFFileExists(FFMakeFullFileName(aDB.Folder.Path, TableDataFile)) then begin - Result := DBIERR_NOSUCHTABLE; - Exit; - end; - Table := TffSrTable.Create(self, aTableName, aDB.Folder, seBufMgr, omReadOnly); - try - Table.OpenFiles(aDB.dbTI, seIsServerTable(aTableName), []); - aDict.Assign(Table.Dictionary); - finally - Table.Free; - end; - end else - aDict.Assign(Table.Dictionary); - except - on E: Exception do - Result := ConvertServerException(E, EventLog); - end; -end; -{--------} -function TffServerEngine.seGetServerName : TffNetName; -begin - Result := seConfig.GeneralInfo^.giServerName; -end; -{--------} -procedure TffServerEngine.seLoadConfig; -var {!!.01} - aRemainingTime : Longint; {!!.01} -begin - - if (not seConfigLoaded) and {!!.03} - (not (csLoading in ComponentState)) and {!!.03} - (not (csDestroying in ComponentState)) then {!!.03} - try - - aRemainingTime := FFGetRemainingTime; {!!.01} - - { Mark config as loaded. We must do this in order to avoid recursive - calls by CreateAdminUser. } - seConfigLoaded := True; - - { Read the general info. } - ReadGeneralInfo; - - { Update the buffer manager's Max RAM. } {!!.01} - seBufMgr.MaxRAM := Configuration.GeneralInfo^.giMaxRAM; {!!.01} - - { Do we need to update the temporary storage size? } - if Configuration.GeneralInfo^.giTempStoreSize <> - seBufMgr.TempStoreSize then - seBufMgr.TempStoreSize := Configuration.GeneralInfo^.giTempStoreSize; - - { Read the aliases. } - ReadAliasData; - - { Read the users. } - ReadUserData; - if (seConfig.UserList.Count = 0) then - CreateAdminUser(IsReadOnly); - - { Read the keyprocs. } - ReadKeyProcData; - - { Process alias script and full script (if present). } - ProcessAliasScript; - if seScriptFile <> '' then - ProcessFullScript(seScriptFile); - - { Save out the changes that may have been made via scripts. } - WriteGeneralInfo(false); - WriteAliasData; - - FFSetRetry(aRemainingTime); {!!.01} - - except - seConfigLoaded := False; - raise; - end; - -end; -{--------} -procedure TffServerEngine.seSetLoggingState; -begin - seCanLog := FLogEnabled and assigned(FEventLog) and (not IsReadOnly); -end; -{--------} -procedure TffServerEngine.seSetCollectFrequency(aFreq : Longint); -begin - Configuration.GeneralInfo^.giCollectFreq := aFreq; - if not ((csLoading in ComponentState) or {!!.01} - (csDesigning in ComponentState)) then {!!.01} - WriteGeneralInfo(False); -end; -{--------} -procedure TffServerEngine.seSetCollectGarbage(aValue : Boolean); -begin - Configuration.GeneralInfo^.giCollectEnabled := aValue; - if not ((csLoading in ComponentState) or {!!.01} - (csDesigning in ComponentState)) then {!!.01} - WriteGeneralInfo(False); -end; -{--------} -procedure TffServerEngine.seSetConfigDir(const aPath : string); {!!.10} -begin -// scCheckInactive; {Deleted !!.01} - seConfigDir := aPath; -end; -{Begin !!.01} -{--------} -procedure TffServerEngine.seSetMaxRAM(const aValue : Longint); -begin - Configuration.GeneralInfo^.giMaxRAM := aValue; - seBufMgr.MaxRAM := aValue; - if not ((csLoading in ComponentState) or - (csDesigning in ComponentState)) then - WriteGeneralInfo(False); -end; -{--------} -procedure TffServerEngine.seSetScriptFile(const aFile: string); {!!.11} -begin - seScriptFile := aFile; -end; -{--------} -function TffServerEngine.seGetConfigDir : string; {!!.10} -begin - if (csDesigning in ComponentState) then - Result := seConfigDir - else - { If we are not in design mode, then we want to make sure the Default - config dir setting is the application's path. } - if (seConfigDir = '') then begin {!!.06 - Start} - Result := FFExtractPath(Application.ExeName); - if (Result[Length(Result)] <> '\') then - Result := Result + '\'; - end else {!!.06 - End} - Result := seConfigDir; -end; -{--------} -procedure TffServerEngine.seSetSQLEngine(anEngine : TffBaseSQLEngine); -begin - if seSQLEngine = anEngine then Exit; - - if assigned(seSQLEngine) then - seSQLEngine.FFRemoveDependent(Self); {!!.11} - - if assigned(anEngine) then - anEngine.FFAddDependent(Self); {!!.11} - - seSQLEngine := anEngine; - -end; -{--------} -procedure TffServerEngine.Log(const aMsg : string); -begin - if seCanLog then - FEventLog.WriteString(aMsg); -end; -{--------} -procedure TffServerEngine.LogAll(const Msgs : array of string); -begin - if seCanLog then - FEventLog.WriteStrings(Msgs); -end; -{--------} -procedure TffServerEngine.LogFmt(const aMsg : string; args : array of const); -begin - if seCanLog then - FEventLog.WriteString(format(aMsg, args)); -end; -{--------} -procedure TffServerEngine.seForce(const aMsg : string; {!!.06 - Start} - args : array of const; - ReadOnly : Boolean); -begin - if ((FEventLog <> nil) and - (not ReadOnly)) then {!!.06 - End} - FEventLog.WriteString(Format(aMsg, args)); -end; -{--------} -function TffServerEngine.seTransactionCommit(aDB : TffSrDatabase) - : TffResult; -var - aContainer : TffTransContainer; - aInx : Longint; - aTable : TffSrTable; - aTableList : TffPointerList; - Nested : Boolean; - Committed : Boolean; {!!.05} -begin - Committed := False; {!!.05} - { Obtain a commit lock on all tables this transaction has modified. - We must do this to make sure the readers have finished. } - aTableList := TffPointerList.Create; - aContainer := TffTransContainer(aDB.Transaction.TransLockContainer); - Nested := aDB.Transaction.Nested; - try - if assigned(aContainer) and (not Nested) then - for aInx := 0 to pred(aContainer.ContentCount) do begin - if aContainer.ContentLockType[aInx] = ffsltExclusive then begin - aTable := TffSrTable(aContainer.ContentTable[aInx]); - aTable.BeginCommit; - aTableList.Append(Pointer(aTable)); - end; - end; - - Result := aDB.Folder.TransactionMgr.Commit(aDB.TransactionID, Nested); - Committed := (Result = DBIERR_NONE); {!!.05} - if (not Nested) then - aDB.Transaction := nil; - finally - if (not Nested) then - for aInx := 0 to pred(aTableList.Count) do begin - aTable := TffSrTable(aTableList.List[aInx]); - if (Committed) then {!!.05} - aTable.btCommitBLOBMgr; {!!.03} - aTable.EndCommit(aDB.DatabaseID); - end; - aTableList.Free; - end; - - if (not Nested) and Committed then begin {!!.05 - Start}{!!.10} - for aInx := Pred(aDB.dbCursorList.CursorCount) downto 0 do {!!.13} - if ((TffSrBaseCursor(aDB.dbCursorList.solList.Items[aInx]) <> nil) and - (TffSrBaseCursor(aDB.dbCursorList.solList.Items[aInx]).bcCloseWTrans)) then - TffSrBaseCursor(aDB.dbCursorList.solList.Items[aInx]).RemoveIfUnused; - end; {!!.05 - End} -end; -{--------} -function TffServerEngine.seTransactionRollback(aDB : TffSrDatabase) - : TffResult; -{Rewritten !!.03} -var - aContainer : TffTransContainer; - aInx : Longint; - aTable : TffSrTable; - aTableList : TffPointerList; - Nested : Boolean; -begin - Result := DBIERR_NONE; -// Assert(assigned(aDB.Transaction)); - if aDB.Transaction <> nil then begin {!!.05} - aTableList := TffPointerList.Create; - aContainer := TffTransContainer(aDB.Transaction.TransLockContainer); - Nested := aDB.Transaction.Nested; - try - { Determine which tables were affected by the transaction. We will rollback - the changes to their BLOB mgr's in-memory deleted chain. } - if assigned(aContainer) and (not Nested) then - for aInx := 0 to pred(aContainer.ContentCount) do - if aContainer.ContentLockType[aInx] = ffsltExclusive then begin - aTable := TffSrTable(aContainer.ContentTable[aInx]); - aTableList.Append(Pointer(aTable)); - end; - - { Tell the transaction manager to rollback. } - aDB.Folder.TransactionMgr.Rollback(aDB.TransactionID, Nested); - - { Nested transaction? } - if (not Nested) then begin - { No. For each table involved, rollback the changes to the BLOB resource - manager's in-memory deleted chain. } - for aInx := 0 to pred(aTableList.Count) do begin - aTable := TffSrTable(aTableList.List[aInx]); - aTable.btRollbackBLOBMgr; - end; - aDB.Transaction := nil; - for aInx := Pred(aDB.dbCursorList.CursorCount) downto 0 do {!!.13} - if ((TffSrBaseCursor(aDB.dbCursorList.solList.Items[aInx]) <> nil) and - (TffSrBaseCursor(aDB.dbCursorList.solList.Items[aInx]).bcCloseWTrans)) then - TffSrBaseCursor(aDB.dbCursorList.solList.Items[aInx]).RemoveIfUnused; - {!!.05 - End} - end; - finally - aTableList.Free; - end; - end; {!!.05} -end; -{--------} -function TffServerEngine.BLOBCreate(aCursorID : TffCursorID; - var aBLOBNr : TffInt64) : TffResult; -{Restructured !!.10} -var - Cursor : TffSrBaseCursor; - StartedTrans : boolean; - TransID : TffTransID; -begin - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if Result = DBIERR_NONE then - try - StartedTrans := False; - try - FFSetRetry(Cursor.Timeout); - if Result = DBIERR_NONE then begin - Result := Cursor.EnsureWritable(False, False); {!!.02} - if (Result = DBIERR_NOACTIVETRAN) or - Cursor.NeedNestedTransaction then begin {!!.03} - Result := seTransactionStart(Cursor.Database, False, - ffcl_TrImplicit, TransID); - StartedTrans := (Result = DBIERR_NONE); - end; - - if (Result = DBIERR_NONE) then begin - Result := Cursor.BLOBAdd(aBLOBNr); - if StartedTrans then - if Result = DBIERR_NONE then - seTransactionCommit(Cursor.Database) - else - seTransactionRollback(Cursor.Database); - end; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} - finally - Cursor.Deactivate; - end; -end; -{--------} -function TffServerEngine.BLOBDelete(aCursorID : TffCursorID; aBLOBNr : TffInt64) : TffResult; -var - Cursor : TffSrBaseCursor; - StartedTrans : boolean; - TransID : TffTransID; -{Restructured !!.10} -begin - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - StartedTrans := False; - try - FFSetRetry(Cursor.Timeout); - if Result = DBIERR_NONE then begin - Result := Cursor.EnsureWritable(False, False); {!!.02} - - if (Result = DBIERR_NOACTIVETRAN) or - Cursor.NeedNestedTransaction then begin {!!.03} - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - StartedTrans := (Result = DBIERR_NONE); - end; - if (Result = DBIERR_NONE) then begin - Result := Cursor.BLOBDelete(aBLOBNr); - if StartedTrans then - if Result = DBIERR_NONE then - seTransactionCommit(Cursor.Database) - else - seTransactionRollback(Cursor.Database); - end; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} - finally - Cursor.Deactivate; - end; -end; -{--------} -function TffServerEngine.BLOBFree(aCursorID : TffCursorID; - aBLOBNr : TffInt64; - ReadOnly : boolean) : TffResult; -{Restructured !!.10} -var - Cursor : TffSrBaseCursor; - StartedTrans : boolean; - TransID : TffTransID; -begin - { If the BLOB was opened in read-only mode then nothing to do. } - if readOnly then begin - Result := DBIERR_NONE; - Exit; - end; - - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - StartedTrans := False; - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.EnsureWritable(False, False); {!!.02} - if (Result = DBIERR_NOACTIVETRAN) or - Cursor.NeedNestedTransaction then begin {!!.03} - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - StartedTrans := (Result = DBIERR_NONE); - end; - - if (Result = DBIERR_NONE) then begin - Result := Cursor.BLOBFree(aBLOBNr); - if StartedTrans then - if (Result = DBIERR_NONE) or {!!.01} - (Result = DBIERR_BLOBMODIFIED) then {!!.01} - seTransactionCommit(Cursor.Database) - else - seTransactionRollback(Cursor.Database); - end; { if } - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} - finally - Cursor.Deactivate; - end; -end; -{--------} -function TffServerEngine.BLOBGetLength(aCursorID : TffCursorID; aBLOBNr : TffInt64; - var aLength : Longint) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if Result = DBIERR_NONE then - try - FFSetRetry(Cursor.Timeout); - if (Result = DBIERR_NONE) then - aLength := Cursor.BLOBGetLength(aBLOBNr, Result); - finally - Cursor.Deactivate; - end; { try..finally } - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{Begin !!.03} -{--------} -function TffServerEngine.BLOBListSegments(aCursorID : TffCursorID; - aBLOBNr : TffInt64; - aStream : TStream) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - if Result = DBIERR_NONE then - Result := Cursor.BLOBListSegments(aBLOBNr, aStream); - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{End !!.03} -{--------} -function TffServerEngine.BLOBRead(aCursorID : TffCursorID; - aBLOBNr : TffInt64; - aOffset : TffWord32; {!!.06} - aLen : TffWord32; {!!.06} - var aBLOB; - var aBytesRead : TffWord32) {!!.06} - : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - if Result = DBIERR_NONE then - Result := Cursor.BLOBRead(aBLOBNr, aOffset, aLen, aBLOB, aBytesRead); - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.BLOBTruncate(aCursorID : TffCursorID; - aBLOBNr : TffInt64; - aBLOBLength : Longint) : TffResult; -{Restructured !!.10} -var - Cursor : TffSrBaseCursor; - StartedTrans : boolean; - TransID : TffTransID; -begin - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if Result = DBIERR_NONE then - try - StartedTrans := False; - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.EnsureWritable(False, False); {!!.02} - if (Result = DBIERR_NOACTIVETRAN) or - Cursor.NeedNestedTransaction then begin {!!.03} - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - StartedTrans := (Result = DBIERR_NONE); - end; - if (Result = DBIERR_NONE) then begin - Result := Cursor.BLOBTruncate(aBLOBNr, aBLOBLength); - if StartedTrans then - if Result = DBIERR_NONE then - seTransactionCommit(Cursor.Database) - else - seTransactionRollback(Cursor.Database); - end; { if } - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} - finally - Cursor.Deactivate; - end; -end; -{--------} -function TffServerEngine.BLOBWrite(aCursorID : TffCursorID; - aBLOBNr : TffInt64; - aOffset : Longint; - aLen : Longint; - var aBLOB) : TffResult; -{Restructured !!.10} -var - Cursor : TffSrBaseCursor; - StartedTrans : boolean; - TransID : TffTransID; -begin - Result := DBIERR_NONE; {!!.01 - Start} - if aLen = 0 then - Exit; {!!.01 - End} - - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if Result = DBIERR_NONE then - try - StartedTrans := False; - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.EnsureWritable(False, False); {!!.02} - if (Result = DBIERR_NOACTIVETRAN) or - Cursor.NeedNestedTransaction then begin {!!.03} - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - StartedTrans := (Result = DBIERR_NONE); - end; - if (Result = DBIERR_NONE) then begin - Result := Cursor.BLOBWrite(aBLOBNr, aOffset, aLen, aBLOB); - if StartedTrans then - if Result = DBIERR_NONE then - seTransactionCommit(Cursor.Database) - else - seTransactionRollback(Cursor.Database); - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} - finally - Cursor.Deactivate; - end; -end; -{--------} -function TffServerEngine.FileBLOBAdd(aCursorID : TffCursorID; - const aFileName : TffFullFileName; - var aBLOBNr : TffInt64) : TffResult; -{Restructured !!.10} -var - Cursor : TffSrBaseCursor; - StartedTrans : boolean; - TransID : TffTransID; -begin - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if Result = DBIERR_NONE then - try - StartedTrans := False; - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.EnsureWritable(False, False); {!!.02} - if (Result = DBIERR_NOACTIVETRAN) or - Cursor.NeedNestedTransaction then begin {!!.03} - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - StartedTrans := (Result = DBIERR_NONE); - end; - if (Result = DBIERR_NONE) then begin - Result := Cursor.FileBLOBAdd(aFileName, aBLOBNr); - if StartedTrans then - if Result = DBIERR_NONE then - seTransactionCommit(Cursor.Database) - else - seTransactionRollback(Cursor.Database); - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} - finally - Cursor.Deactivate; - end; -end; -{--------} -function TffServerEngine.CheckClientIDAndGet(aClientID : TffClientID; - var aClient : TffSrClient) : TffResult; -begin - if State <> ffesStarted then begin - Result := DBIERR_FF_ServerUnavail; - Exit; - end; - - Result := seCheckClientIDAndGet(aClientID, aClient); - if Result = DBIERR_NONE then begin - Result := DBIERR_FF_UnknownClient; - if aClient.Activate then - Result := DBIERR_NONE; - end; -end; -{--------} -function TffServerEngine.seCheckClientIDAndGet(aClientID : TffClientID; - var aClient : TffSrClient) : TffResult; -begin - Result := DBIERR_FF_UnknownClient; - try - if TObject(aClientID) is TffSrClient then begin - aClient := TffSrClient(aClientID); - Result := DBIERR_NONE; - end; - except - { An exception may be raised if the ID is bogus. Swallow the exception.} - end; -end; -{--------} -function TffServerEngine.CheckCursorIDAndGet(aCursorID : TffCursorID; - var aCursor : TffSrBaseCursor) : TffResult; -begin - if State <> ffesStarted then begin - Result := DBIERR_FF_ServerUnavail; - Exit; - end; - - Result := seCheckCursorIDAndGet(aCursorID, aCursor); - if Result = DBIERR_NONE then begin - Result := DBIERR_FF_UnknownCursor; - if aCursor.Activate then - Result := DBIERR_NONE; - end; -end; -{--------} -function TffServerEngine.seCheckCursorIDAndGet(aCursorID : TffCursorID; - var aCursor : TffSrBaseCursor) : TffResult; -begin - Result := DBIERR_FF_UnknownCursor; - try - if TObject(aCursorID) is TffSrBaseCursor then begin - aCursor := TffSrBaseCursor(aCursorID); - Result := DBIERR_NONE; - end; - except - { An exception may be raised if the ID is bogus. Swallow the exception.} - end; -end; -{--------} -function TffServerEngine.CheckDatabaseIDAndGet(aDatabaseID : TffDatabaseID; - var aDatabase : TffSrDatabase) : TffResult; -begin - if State <> ffesStarted then begin - Result := DBIERR_FF_ServerUnavail; - Exit; - end; - - Result := seCheckDatabaseIDAndGet(aDatabaseID, aDatabase); - if Result = DBIERR_NONE then begin - Result := DBIERR_FF_UnknownDB; - if aDatabase.Activate then - Result := DBIERR_NONE; - end; -end; -{--------} -function TffServerEngine.seCheckDatabaseIDAndGet(aDatabaseID : TffDatabaseID; - var aDatabase : TffSrDatabase) : TffResult; -begin - Result := DBIERR_FF_UnknownDB; - try - if TObject(aDatabaseID) is TffSrDatabase then begin - aDatabase := TffSrDatabase(aDatabaseID); - Result := DBIERR_NONE; - end; - except - { An exception may be raised if the ID is bogus. Swallow the exception.} - end; -end; -{--------} -function TffServerEngine.CheckTransactionIDAndGet(aTransactionID : TffTransID; - var aTrans : TffSrTransaction) : TffResult; -begin - if State <> ffesStarted then begin - Result := DBIERR_FF_ServerUnavail; - Exit; - end; - - Result := DBIERR_INVALIDHNDL; - try - if TObject(aTransactionID) is TffSrTransaction then begin - aTrans := TffSrTransaction(aTransactionID); - Result := DBIERR_NONE; - end; - except - { An exception may be raised if the ID is bogus. Swallow the exception.} - end; -end; -{Begin !!.11} -{--------} -function TffServerEngine.ClientAdd( var aClientID : TffClientID; - const aClientName : TffNetName; - const aUserID : TffName; - const aTimeout : Longint; - var aHash : TffWord32) : TffResult; -begin - Result := seClientAddPrim(aClientID, aClientName, aUserID, aTimeout, - FFVersionNumber, aHash); -end; -{--------} -function TffServerEngine.ClientAddEx(var aClientID : TffClientID; - const aClientName : TffNetName; - const aUserID : TffName; - const aTimeout : Longint; - const aClientVersion : Longint; - var aHash : TffWord32) : TffResult; -begin - Result := seClientAddPrim(aClientID, aClientName, aUserID, aTimeout, - aClientVersion, aHash); -end; -{--------} -function TffServerEngine.seClientAddPrim( var aClientID : TffClientID; - const aClientName : TffNetName; - const aUserID : TffName; - const aTimeout : Longint; - const aClientVersion : Longint; - var aHash : TffWord32) : TffResult; -var - aMonitor : TffBaseEngineMonitor; - anExtender : TffBaseEngineExtender; - anIndex : Longint; - MonitorList : TffList; - NewClient : TffSrClient; - User : TffUserItem; -begin - FFSetRetry(aTimeout); { Probably not needed but let's do it just in case. } - aClientID := ffc_NoClientID; - try - if seConfig.GeneralInfo^.giIsSecure and - (seConfig.UserList.Count <> 0) then begin - if not seConfig.UserList.UserExists(aUserID) then begin - Result := DBIERR_INVALIDUSRPASS; - Exit; - end; - with seConfig.UserList do begin - User := UserItem[UserIndex(aUserID)]; - aHash := PasswordHash[aUserID]; - end; - end - else begin - User := nil; - aHash := 0; - end; - NewClient := TffSrClient.Create(aClientID, aClientName, aTimeout, - aClientVersion, User, Self); - - { If there are any monitors interested in client then see if they - are interested in this client. } - MonitorList := GetInterestedMonitors(TffSrClient); - if assigned(MonitorList) then begin - for anIndex := 0 to pred(MonitorList.Count) do begin - aMonitor := TffBaseEngineMonitor - (TffIntListItem(MonitorList[anIndex]).KeyAsInt); - try - anExtender := aMonitor.Interested(NewClient); - if assigned(anExtender) then - NewClient.AddClientExtender(anExtender); - except - on E:Exception do - seForce('Monitor [%s] exception, ClientAdd: %s', {!!.06 - Start} - [aMonitor.ClassName, E.message], - bseGetReadOnly); {!!.06 - End} - end; - end; - MonitorList.Free; - end; - - { Now notify the extenders about the client. If somebody complains - then disallow the client. } - Result := NewClient.NotifyExtenders(ffeaAfterCreateClient, ffeaNoAction); - if Result <> DBIERR_NONE then begin - NewClient.Free; - exit; - end else begin - NewClient.Accepted := True; - try - ClientList.BeginWrite; - try - ClientList.AddClient(NewClient); - seClientHash.Add(NewClient.ClientID, nil); {!!.02} - finally - ClientList.EndWrite; - end; - {add the default session to our session list} - SessionList.BeginWrite; - try - { Assumption: No need to lock NewClient.SessionList since - we have not confirmed creation of client to the client. } - SessionList.AddSession(NewClient.SessionList.Session[ftFromIndex, 0]); - finally - SessionList.EndWrite; - end; - except - NewClient.Free; - raise; - end;{try..except} - aClientID := NewClient.ClientID; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -procedure TffServerEngine.seClientRemovePrim(const aClient : TffSrClient); -begin - if aClient.CanClose(True) then begin - ClientList.DeleteClient(aClient.ClientID); - TableList.RemoveUnusedTables; - FolderList.RemoveUnusedFolders; - {If the server is waiting on us to finish, let it know we're - done so it can move on.} - if ((Assigned(seEvtClientDone)) and - (ClientList.ClientCount = 0)) then - seEvtClientDone.SignalEvent; - end else - aClient.RequestClose; -end; -{--------} -function TffServerEngine.ClientRemove(aClientID : TffClientID) : TffResult; -var - Client : TffSrClient; -begin - try - { Note: We lock the client list because we may have 2 threads trying to - do a remove for the same client. Thread A could be processing the - RemoveClient request from the remote client while thread B could be - processing a remote client hangup (i.e., initiated from transport level).} - ClientList.BeginWrite; - try -{Begin !!.02} - { Is the client is listed in the hash table? } - if not seClientHash.Remove(aClientID) then begin - { No. The client has already been removed. } - Result := DBIERR_FF_UnknownClient; - Exit; - end; -{End !!.02} - - { Find the client object. Note that we will always get an exception on - the 2nd removal request for each client. The exception is swallowed - in seCheckClientIDAndGet. We get the exception because the client is - already freed. We live with the exception because we don't want to - pay the cost of doing a sequential scan through the list of clients. - This could be onerous when hundreds of clients are connected to the - server. } - Result := seCheckClientIDAndGet(aClientID, Client); - if Result = DBIERR_NONE then begin - FFSetRetry(Client.Timeout); - seClientRemovePrim(Client); - end; - finally - ClientList.EndWrite; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.ClientSetTimeout(const aClientID : TffClientID; - const aTimeout : Longint) : TffResult; -var - Client : TffSrClient; -begin - try - Result := CheckClientIDAndGet(aClientID, Client); - if Result = DBIERR_NONE then - try - Client.Timeout := aTimeout; - finally - Client.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.seBLOBCopy(aSrc, - aTgt : TffSrBaseCursor; - aSourceBLOBNr, - aTargetBLOBNr : TffInt64; - aBuffer : Pointer; - aBufLen : Longint) - : TffResult; -var - SourceLen : Longint; - SegmentLen : Longint; - BytesRead : TffWord32; {!!.06} - Offset : Longint; - FileName : TffFullFileName; -begin - - with aSrc.Table do begin - - { Assumption: Transaction has already been started by a calling routine. } - - { See if we have a file BLOB } - if FFTblGetFileNameBLOB(Files[Dictionary.BLOBFileNumber], - aSrc.Database.TransactionInfo, - aSourceBLOBNr, FileName) then begin - FFTblAddFileBLOB(Files[Dictionary.BLOBFileNumber], - aSrc.Database.TransactionInfo, - FileName, aTargetBLOBNr); - Result := DBIERR_NONE; - end - else begin - - { Otherwise copy the BLOB in segments based on the size of the - given transfer buffer } - SourceLen := aSrc.BLOBGetLength(aSourceBLOBNr, Result); - if Result <> DBIERR_NONE then Exit; - - Offset := 0; - SegmentLen := FFMinI(aBufLen, SourceLen); - while Offset < SourceLen do begin - Result := aSrc.BLOBRead(aSourceBLOBNr, Offset, SegmentLen, aBuffer^, - BytesRead); - if Result <> DBIERR_NONE then Exit; - - Result := aTgt.BLOBWrite(aTargetBLOBNr, Offset, BytesRead, aBuffer^); - if Result <> DBIERR_NONE then Exit; - - Inc(Offset, BytesRead); - end; { while } - end; - end; { with } -end; -{--------} -function TffServerEngine.SessionAdd(const aClientID : TffClientID; - const timeout : Longint; - var aSessionID : TffSessionID) : TffResult; -var - Client : TffSrClient; - Session : TffSrSession; -begin - try - Result := CheckClientIDAndGet(aClientID, Client); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Client.Timeout); { Just in case } -// Session := TffSrSession.Create(Client, false, timeout); {Deleted !!.03} - SessionList.BeginWrite; - try -{Begin !!.03} - if Assigned(Client.clFirstSession) then begin - Session := Client.clFirstSession; - Client.clFirstSession := nil; - end else begin - Session := TffSrSession.Create(Client, false, timeout); - SessionList.AddSession(Session); - end; -{End !!.03} - finally - SessionList.EndWrite; - end; - aSessionID := Session.SessionID; - finally - Client.Deactivate; - end - else - aSessionID := 0; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{Begin !!.06} -{--------} -function TffServerEngine.SessionCloseInactiveTables(aClientID : TffClientID) : TffResult; -var - Client : TffSrClient; -begin - try - Result := CheckClientIDAndGet(aClientID, Client); - if (Result = DBIERR_NONE) then - try - TableList.RemoveUnusedTAbles; - finally - Client.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.SessionCount(aClientID : TffClientID; - var aCount : integer) : TffResult; -var - Client : TffSrClient; -begin - try - Result := CheckClientIDAndGet(aClientID, Client); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Client.Timeout); { Just in case } - Client.SessionList.BeginRead; - try - aCount := Client.SessionList.SessionCount - finally - Client.SessionList.EndRead; - end - finally - Client.Deactivate; - end - else - aCount := 0; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.SessionGetCurrent(aClientID : TffClientID; - var aSessionID : TffSessionID) : TffResult; -var - Client : TffSrClient; - aSession : TffSrSession; -begin - try - aSessionID := 0; - Result := CheckClientIDAndGet(aClientID, Client); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Client.Timeout); { just in case } - Client.SessionList.BeginRead; - try - aSession := Client.SessionList.CurrentSession; - finally - Client.SessionList.EndRead; - end; - if assigned(aSession) then - aSessionID := aSession.SessionID; - finally - Client.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.SessionRemove(aClientID : TffClientID; - aSessionID : TffSessionID) : TffResult; -var - Session : TffSrSession; -begin - try - Result := seCheckSessionIDAndGet(aSessionID, Session); - if (Result = DBIERR_NONE) then begin - FFSetRetry(Session.Timeout); { just in case } - if Session.CanClose(True) then begin - Session.Free; - TableList.RemoveUnusedTables; - end else - Session.RequestClose; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.SessionSetCurrent(aClientID : TffClientID; - aSessionID : TffSessionID) : TffResult; -var - Client : TffSrClient; - aSession : TffSrSession; -begin - try - Result := CheckSessionIDAndGet(aClientID, aSessionID, Client, aSession); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Client.Timeout); { just in case } - Client.SessionList.BeginWrite; - try - Client.SessionList.CurrentSession := aSession; - finally - Client.SessionList.EndWrite; - end; - finally - Client.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.SessionSetTimeout(const aClientID : TffClientID; - const aSessionID : TffSessionID; - const aTimeout : Longint) : TffResult; -var - Client : TffSrClient; - Session : TffSrSession; -begin - try - Result := CheckSessionIDAndGet(aClientID, aSessionID, Client, Session); - if Result = DBIERR_NONE then - try - Session.Timeout := aTimeout; - finally - Client.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorClone(aCursorID : TffCursorID; - aOpenMode : TffOpenMode; - var aNewCursorID : TffCursorID) - : TffResult; - -var - aCursor, {!!.03} - aNewCursor : TffSrBaseCursor; {!!.03} -begin - try - Result := CheckCursorIDAndGet(aCursorID, aCursor); - if (Result = DBIERR_NONE) then begin {!!.06 - Start} - FFSetRetry(aCursor.Timeout); - aNewCursor := aCursor.CloneCursor(aOpenMode); {!!.03} - CursorList.BeginWrite; - try - CursorList.AddCursor(aNewCursor); {!!.03} - aNewCursorID := aNewCursor.CursorID; {!!.03} - finally - CursorList.EndWrite; - aCursor.Deactivate; - end; { try..finally } - end; { if } {!!.06 - End} - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorClose(aCursorID : TffCursorID) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := seCheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then begin - FFSetRetry(Cursor.Timeout); - if Cursor.CanClose(True) then - Cursor.Free - else - Cursor.RequestClose; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorCompareBookmarks(aCursorID : TffCursorID; - aBookmark1, - aBookmark2 : PffByteArray; - var aCompResult : Longint) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.NotifyExtenders(ffeaBeforeTabRead, ffeaNoAction); - if Result = DBIERR_NONE then - Result := Cursor.CompareBookmarks(aBookmark1, aBookmark2, aCompResult); - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{Begin !!.02} -{--------} -function TffServerEngine.CursorCopyRecords(aSrcCursorID, - aDestCursorID : TffCursorID; - aCopyBLOBs : Boolean) : TffResult; -var - aBLOBCopyMode : TffBLOBCopyMode; - SrcCursor, - DestCursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aSrcCursorID, SrcCursor); - if (Result = DBIERR_NONE) then - try - Result := CheckCursorIDAndGet(aDestCursorID, DestCursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(DestCursor.Timeout); {!!.10} - if aCopyBLOBs then - aBLOBCopyMode := ffbcmCopyFull - else - aBLOBCopyMode := ffbcmNoCopy; - Result := DestCursor.CopyRecords(SrcCursor, aBLOBCopyMode, nil, - 0, 0); - finally - DestCursor.Deactivate; - end; - finally - SrcCursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{End !!.02} -{Begin !!.06} -{--------} -function TffServerEngine.CursorDeleteRecords(aCursorID : TffCursorID) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); {!!.10} - Result := Cursor.DeleteRecords; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{End !!.02} -{--------} -function TffServerEngine.CursorGetBookmark(aCursorID : TffCursorID; - aBookmark : PffByteArray) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); { just in case } - Result := Cursor.GetBookmark(aBookmark); - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorGetBookmarkSize(aCursorID : TffCursorID; - var aSize : integer) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); { just in case } - aSize := Cursor.GetBookmarkSize; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{Begin !!.03} -{--------} -function TffServerEngine.CursorListBLOBFreeSpace(aCursorID : TffCursorID; - const aInMemory : Boolean; - aStream : TStream) : TffResult; -var - Cursor : TffSrBaseCursor; - StartedTrans : Boolean; - TransID : TffTransID; -begin - StartedTrans := False; - try - {get the cursor} - Result := CheckCursorIDAndGet(aCursorID, Cursor); - - if (Result = DBIERR_NONE) then - try - if Cursor.Database.Transaction = nil then begin - Result := seTransactionStart(Cursor.Database, False, - ffcl_TrImplicit, TransID); - StartedTrans := (Result = DBIERR_NONE); - end; - FFSetRetry(Cursor.Timeout); - Cursor.ListBLOBFreeSpace(Cursor.Database.TransactionInfo, aInMemory, - aStream); - finally - if StartedTrans then - seTransactionRollback(Cursor.Database); - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{End !!.03} -{--------} -function TffServerEngine.CursorOverrideFilter(aCursorID : Longint; - aExpression : pCANExpr; - aTimeout : TffWord32) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - {get the cursor} - Result := CheckCursorIDAndGet(aCursorID, Cursor); - - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.OverrideFilter(aExpression, aTimeout); - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorResetRange(aCursorID : TffCursorID) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - if (Cursor.IndexID = 0) then - Result := DBIERR_NOASSOCINDEX - else begin - FFSetRetry(Cursor.Timeout); { just in case } - Cursor.ResetRange; - end; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorRestoreFilter(aCursorID : Longint) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - {get the cursor} - Result := CheckCursorIDAndGet(aCursorID, Cursor); - - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.RestoreFilter; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorSetFilter(aCursorID : TffCursorID; - aExpression : pCANExpr; - aTimeout : TffWord32) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - {get the cursor} - Result := CheckCursorIDAndGet(aCursorID, Cursor); - - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - if aExpression^.iTotalSize <= SizeOf(CANExpr) then {!!.01} - aExpression:= nil; {!!.01} - Result := Cursor.SetFilter(aExpression, aTimeout); - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorSetRange(aCursorID : TffCursorID; - aDirectKey : boolean; - aFieldCount1 : integer; - aPartialLen1 : integer; - aKeyData1 : PffByteArray; - aKeyIncl1 : boolean; - aFieldCount2 : integer; - aPartialLen2 : integer; - aKeyData2 : PffByteArray; - aKeyIncl2 : boolean) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - if (Cursor.IndexID = 0) then - Result := DBIERR_NOASSOCINDEX - else begin - FFSetRetry(Cursor.Timeout); { just in case } - Result := Cursor.SetRange(aDirectKey, - aFieldCount1, aPartialLen1, aKeyData1, aKeyIncl1, - aFieldCount2, aPartialLen2, aKeyData2, aKeyIncl2); - end; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorSetTimeout(const aCursorID : TffCursorID; - const aTimeout : Longint) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if Result = DBIERR_NONE then - try - Cursor.Timeout := aTimeout; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorSetToBegin(aCursorID : TffCursorID) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Cursor.SetToBegin; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorSetToBookmark(aCursorID : TffCursorID; - aBookmark : PffByteArray) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.SetToBookmark(aBookmark); - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorSetToCursor(aDestCursorID : TffCursorID; aSrcCursorID : TffCursorID) : TffResult; -var - DestCursor : TffSrBaseCursor; - SrcCursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aDestCursorID, DestCursor); - if (Result = DBIERR_NONE) then - try - Result := seCheckCursorIDAndGet(aSrcCursorID, SrcCursor); - { We call the primitive seCheckCursorIDAndGet here because - the client was just locked by the call to get the destination - cursor. } - if (Result = DBIERR_NONE) then begin - FFSetRetry(DestCursor.Timeout); - Result := DestCursor.SetToCursor(SrcCursor); - end; - finally - DestCursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorSetToEnd(aCursorID : TffCursorID) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Cursor.SetToEnd; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorSetToKey(aCursorID : TffCursorID; - aSearchAction : TffSearchKeyAction; - aDirectKey : boolean; - aFieldCount : integer; - aPartialLen : integer; - aKeyData : PffByteArray) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - if (Cursor.IndexID = 0) then - Result := DBIERR_NOASSOCINDEX - else begin - FFSetRetry(Cursor.Timeout); - Result := Cursor.SetToKey(aSearchAction, aDirectKey, - aFieldCount, aPartialLen, aKeyData); - end; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.CursorSwitchToIndex(aCursorID : TffCursorID; - aIndexName : TffDictItemName; - aIndexID : integer; - aPosnOnRec : boolean) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - {get the cursor} - Result := CheckCursorIDAndGet(aCursorID, Cursor); - - if (Result = DBIERR_NONE) then - try - {validate the index information; if the index name is non-blank - it must exist and will supercede the index number; if the index - name is blank the index number must exist} - if (aIndexName <> '') then begin - aIndexID := Cursor.Table.Dictionary.GetIndexFromName(aIndexName); - if (aIndexID = -1) then - Result := DBIERR_NOSUCHINDEX; - end - else if (0 > aIndexID) or - (aIndexID >= Cursor.Table.Dictionary.IndexCount) then - Result := DBIERR_NOSUCHINDEX; - - {switch indexes} - if (Result = DBIERR_NONE) then - if (aIndexID <> Cursor.IndexID) then begin - FFSetRetry(Cursor.Timeout); - Result := Cursor.SwitchToIndex(aIndexID, aPosnOnRec); - end; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.DatabaseAddAlias(const aAlias : TffName; - const aPath : TffPath; - aCheckSpace : Boolean; {!!.11} - const aClientID : TffClientID) - : TffResult; -var - Client : TffSrClient; -begin - try - Result := CheckClientIDAndGet(aClientID, Client); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Client.Timeout); - Result := Client.NotifyExtenders(ffeaBeforeDBInsert, ffeaDBInsertFail); - if (Result = DBIERR_NONE) then begin - seConfig.AliasList.BeginWrite; - try - Result := seDatabaseAddAliasPrim(aAlias, - aPath, - aCheckSpace); {!!.11} - if (Result = DBIERR_NONE) then - WriteAliasData - else - Client.NotifyExtenders(ffeaDBInsertFail, ffeaNoAction); - finally - seConfig.AliasList.EndWrite; - end; - end; - finally - Client.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.seDatabaseAliasListPrim(aList : TList) : TffResult; -var - Inx : integer; - AliasItem : TffAliasItem; - TempDescr : PffAliasDescriptor; -begin - { Assumption: Thread-safeness enforced at a higher level. } - Result := DBIERR_NONE; - for Inx := 0 to pred(seConfig.AliasList.Count) do begin - FFGetMem(TempDescr, sizeOf(TffAliasDescriptor)); - AliasItem := seConfig.AliasList[Inx]; - with AliasItem do begin - TempDescr^.adAlias := KeyAsStr; - TempDescr^.adPath := Path; - end; - aList.add(TempDescr); - end; -end; -{--------} -function TffServerEngine.DatabaseAliasList(aList : TList; - aClientID : TffClientID) : TffResult; -var - Client : TffSrClient; -begin - try - Result := CheckClientIDandGet(aClientID, Client); - if Result = DBIERR_NONE then - try - FFSetRetry(Client.Timeout); - Result := Client.NotifyExtenders(ffeaBeforeDBRead, ffeaNoAction); - if Result = DBIERR_NONE then begin - seConfig.AliasList.BeginRead; - try - Result := seDatabaseAliasListPrim(aList); - finally - seConfig.AliasList.EndRead; - end; - end; { if } - finally - Client.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.RecoveryAliasList(aList : TList; - aClientID : TffClientID) : TffResult; -var - Client : TffSrClient; -begin - try - Result := seCheckClientIDandGet(aClientID, Client); - if Result = DBIERR_NONE then begin - FFSetRetry(Client.Timeout); - Result := Client.NotifyExtenders(ffeaBeforeDBRead, ffeaNoAction); - if Result = DBIERR_NONE then begin - seConfig.AliasList.BeginRead; - try - Result := seDatabaseAliasListPrim(aList); - finally - seConfig.AliasList.EndRead; - end; - end; { if } - end; { if } - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.DatabaseChgAliasPath(aAlias : TffName; - aNewPath : TffPath; - aCheckSpace : Boolean; {!!.11} - aClientID : TffClientID) - : TffResult; -var - Client : TffSrClient; -begin - try - Result := CheckClientIDandGet(aClientID, Client); - if Result = DBIERR_NONE then - try - FFSetRetry(Client.Timeout); - {check whether the alias exists} - seConfig.AliasList.BeginWrite; - try - if not seConfig.AliasList.AliasExists(aAlias) then begin - Result := DBIERR_UNKNOWNDB; - Exit; - end; - {delete the old alias} - seConfig.AliasList.DeleteAlias(aAlias); - - {add the Alias again and its new path} - seConfig.AddAlias(aAlias, aNewPath, aCheckSpace); {!!.11} - WriteAliasData; - finally - seConfig.AliasList.EndWrite; - end; - Result := DBIERR_NONE; - finally - Client.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.DatabaseClose(aDatabaseID : TffDatabaseID) : TffResult; -var - DB : TffSrDatabase; -begin - try - Result := seCheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result = DBIERR_NONE) then begin - FFSetRetry(DB.Timeout); - { We can free the database if there are no open cursors - & if the database is not active. - Note: We are protected by the TableOpen method's behavior. - If a table is in the process of being opened - then DB's state will be ffosActive & we won't free the - database. } - if DB.CanClose(True) then begin - DB.Free; - TableList.RemoveUnusedTables; - end else - DB.RequestClose; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.seDatabaseDeleteAliasPrim(aAlias : TffName) : TffResult; -begin - { Assumption: Thread-safeness enforced at a higher level. } - Result := DBIERR_NONE; - - { Does the alias exist? } - if not seConfig.AliasList.AliasExists(aAlias) then - { No. Notify client. } - Result := DBIERR_UNKNOWNDB - else - { Delete the old alias} - seConfig.AliasList.DeleteAlias(aAlias); -end; -{--------} -function TffServerEngine.DatabaseDeleteAlias(aAlias : TffName; - aClientID : TffClientID) : TffResult; -var - Client : TffSrClient; -begin - try - Result := CheckClientIDandGet(aClientID, Client); - if Result = DBIERR_NONE then - try - FFSetRetry(Client.Timeout); - Result := Client.NotifyExtenders(ffeaBeforeDBDelete, ffeaDBDeleteFail); - if Result = DBIERR_NONE then begin - seConfig.AliasList.BeginWrite; - try - Result := seDatabaseDeleteAliasPrim(aAlias); - if Result = DBIERR_NONE then - WriteAliasData - else - Client.NotifyExtenders(ffeaDBDeleteFail, ffeaNoAction); - finally - seConfig.AliasList.EndWrite; - end; - Result := DBIERR_NONE; - end; { if } - finally - Client.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.DatabaseOpen(aClientID : TffClientID; - const aAlias : TffName; - const aOpenMode : TffOpenMode; - const aShareMode : TffShareMode; - const aTimeout : Longint; - var aDatabaseID : TffDatabaseID) - : TffResult; -var - aDatabase : TffSrDatabase; - aSession : TffSrSession; - Folder : TffSrFolder; - Client : TffSrClient; - DB : TffSrDatabase; - UNCPath : TffPath; - CheckSpace : Boolean; {!!.11} -begin - aDatabase := nil; - Folder := nil; - try - {the client must exist} - Result := CheckClientIDAndGet(aClientID, Client); - if (Result <> DBIERR_NONE) then - Exit; - - try - FFSetRetry(Client.Timeout); - Result := Client.NotifyExtenders(ffeaBeforeDBRead, ffeaNoAction); - - if Result = DBIERR_NONE then begin - {get the current session} - Client.SessionList.BeginRead; - try - aSession := Client.SessionList.CurrentSession; - finally - Client.SessionList.EndRead; - end; - {check to see whether the Alias exists} - seConfig.AliasList.BeginRead; - try - if not seConfig.AliasList.AliasExists(aAlias) then begin - Result := DBIERR_UNKNOWNDB; - Exit; - end; - {get the Alias path} - UNCPath := seConfig.AliasList.Path[aAlias]; - CheckSpace := seConfig.AliasList.CheckDiskSpace(aAlias); {!!.11} - finally - seConfig.AliasList.EndRead; - end; - {check to see whether the directory exists} - if not FFDirectoryExists(UNCPath) then begin - Result := DBIERR_INVALIDDIR; - Exit; - end; - {get a path id for this path} - FolderList.BeginWrite; - try - Folder := FolderList.AddFolder(UNCPath, IsReadOnly, seBufMgr); - finally - FolderList.EndWrite; - end; - UNCPath := Folder.Path; - - {check to see whether this Alias has already been opened and in - a non-compatible state (ie we or some other client/session - wants it opened exclusively)} - DatabaseList.BeginWrite; - try - DB := DatabaseList.GetDatabaseForFolder(Folder); - if assigned(DB) then begin - if ((DB.ShareMode = smExclusive) or (aShareMode = smExclusive)) and - ((TffSrClient(DB.Client).ClientID <> aClientID) or - (DB.Session <> aSession)) then begin - Result := DBIERR_NEEDEXCLACCESS; - Exit; - end; - end; - {create a new database object, add it to the global list} - aDatabase := seDatabaseOpenPrim(aSession, - Folder, - aAlias, - aOpenMode, - aShareMode, - aTimeout, - CheckSpace); {!!.11} - aDatabaseID := aDatabase.DatabaseID; - finally - DatabaseList.EndWrite; - end; - end; - finally - Client.Deactivate; - end; - except - on E : Exception do begin - if (aDatabase <> nil) then - aDatabase.Free - else {aDatabase was never created} - if (Folder <> nil) then begin - FolderList.BeginWrite; - try - FolderList.DeleteFolderByID(Folder.FolderID); - finally - FolderList.EndWrite; - end; - end; - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.DatabaseOpenNoAlias(aClientID : TffClientID; - const aPath : TffPath; - const aOpenMode : TffOpenMode; - const aShareMode : TffShareMode; - const aTimeout : Longint; - var aDatabaseID : TffDatabaseID) - : TffResult; -var - aDatabase : TffSrDatabase; - anAlias : TffName; - aSession : TffSrSession; - Folder : TffSrFolder; - Client : TffSrClient; - DatabaseExists : Boolean; - DB : TffSrDatabase; - UNCPath : TffPath; - CheckSpace : Boolean; {!!.11} -begin - aDatabase := nil; - Folder := nil; - try - { The path cannot be empty. } - if (aPath = '') then begin - Result := DBIERR_INVALIDDIR; - Exit; - end; - - { The client must exist. } - Result := CheckClientIDAndGet(aClientID, Client); - if (Result <> DBIERR_NONE) then - Exit; - - try - FFSetRetry(Client.Timeout); - Result := Client.NotifyExtenders(ffeaBeforeDBRead, ffeaNoAction); - - if Result = DBIERR_NONE then begin - {get the current session} - Client.SessionList.BeginRead; - try - aSession := Client.SessionList.CurrentSession; - finally - Client.SessionList.EndRead; - end; - {check to see whether the directory exists} - if not FFDirectoryExists(aPath) then begin - Result := DBIERR_INVALIDDIR; - Exit; - end; - {get a folder for this path} - FolderList.BeginWrite; - try - Folder := FolderList.AddFolder(aPath, IsReadOnly, seBufMgr); - finally - FolderList.EndWrite; - end; - UNCPath := Folder.Path; - {check to see whether this path has already been opened and in - a non-compatible state (ie we or some other client/session - wants it opened exclusively)} - anAlias := ''; - CheckSpace := True; {!!.11} - DatabaseList.BeginWrite; - try - DB := DatabaseList.GetDatabaseForFolder(Folder); - DatabaseExists := assigned(DB); - if DatabaseExists then begin - CheckSpace := DB.CheckSpace; {!!.11} - if ((DB.ShareMode = smExclusive) or (aShareMode = smExclusive)) and - ((TffSrClient(DB.Client).ClientID <> aClientID) or - (DB.Session <> aSession)) then begin - Result := DBIERR_NEEDEXCLACCESS; - Exit; - end; - anAlias := DB.Alias; - end; - { Create a new database object, add it to the global list. } - aDatabase := seDatabaseOpenPrim(aSession, - Folder, - anAlias, - aOpenMode, - aShareMode, - aTimeout, - CheckSpace); {!!.11} - aDatabaseID := aDatabase.DatabaseID; - finally - DatabaseList.EndWrite; - end; - end; - finally - Client.Deactivate; - end; - except - on E : Exception do begin - if assigned(aDatabase) then - aDatabase.Free - else {database was never created} - if (Folder <> nil) then begin - FolderList.BeginWrite; - try - FolderList.DeleteFolderByID(Folder.FolderID); - finally - FolderList.EndWrite; - end; - end; - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.DatabaseSetTimeout(const aDatabaseID : TffDatabaseID; - const aTimeout : Longint) : TffResult; -var - DB : TffSrDatabase; -begin - try - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if Result = DBIERR_NONE then - try - DB.Timeout := aTimeout; - finally - DB.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.DatabaseTableExists(aDatabaseID : TffDatabaseID; - const aTableName : TffTableName; - var aExists : Boolean) : TffResult; -var - DB : TffSrDatabase; - SearchPath : TffPath; -begin - try - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result <> DBIERR_NONE) then - Exit; - - try - FFSetRetry(DB.Timeout); - Result := DB.NotifyExtenders(ffeaBeforeTabRead, ffeaNoAction); - - if Result = DBIERR_NONE then begin - SearchPath := DB.Folder.Path; - if (SearchPath[length(SearchPath)] <> '\') then - FFShStrAddChar(SearchPath, '\'); - aExists := FFFileExists(SearchPath + FFForceExtension(aTableName, ffc_ExtForData)); - end; - - finally - DB.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} - -end; -{Begin !!.11} -{--------} -function TffServerEngine.seTableExistsPrim(aDB : TffSrDatabase; - const aTableName: TffTableName) : Boolean; -var - SearchPath : TffPath; -begin - { The table name must be a valid file name without extension. } - if not FFVerifyFileName(aTableName) then - FFRaiseException(EffException, ffstrResServer, - fferrInvalidTableName, [aTableName]); - - SearchPath := aDB.Folder.Path; - if (SearchPath[length(SearchPath)] <> '\') then - FFShStrAddChar(SearchPath, '\'); - Result := FFFileExists(SearchPath + - FFForceExtension(aTableName, ffc_ExtForData)); -end; -{End !!.11} -{--------} -function TffServerEngine.DatabaseTableList(aDatabaseID : TffDatabaseID; - const aMask : TffFileNameExt; - aList : TList) : TffResult; -var - DB : TffSrDatabase; - FindRes : integer; - TableDesc : PffTableDescriptor; - SearchRec : TffSearchRec; - SearchMask : TffPath; -begin - try - - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result <> DBIERR_NONE) then - exit; - - try - FFSetRetry(DB.Timeout); - Result := DB.NotifyExtenders(ffeaBeforeTabRead, ffeaNoAction); - - if Result = DBIERR_NONE then begin - SearchMask := DB.Folder.Path; - if (SearchMask[length(SearchMask)] <> '\') then - FFShStrAddChar(SearchMask, '\'); - if (aMask = '') then begin - FFShStrConcat(SearchMask, '*.'); - FFShStrConcat(SearchMask, ffc_ExtForData); - end - else begin {BEGIN !!.01} - FFShStrConcat(SearchMask, aMask); - {$IFDEF OnlyRetrieveTables} - FFForceExtension(SearchMask, ffc_ExtForData); - {$ENDIF} - end; {END !!.01} - FindRes := FFFindFirst(SearchMask, [ditFile], diaAnyAttr, SearchRec); - while (FindRes = 0) do begin - FFGetMem(TableDesc, sizeOf(TffTableDescriptor)); - with SearchRec do begin - TableDesc^.tdTableName := FFExtractFileName(srName); - TableDesc^.tdExt := FFExtractExtension(srName); - TableDesc^.tdSizeLo := srSize; - TableDesc^.tdSizeHi := srSizeHigh; - TableDesc^.tdTimeStamp := srTime; - end; - aList.Add(TableDesc); - FindRes := FFFindNext(SearchRec); - end; - FFFindClose(SearchRec); - end; - finally - DB.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.DatabaseTableLockedExclusive(aDatabaseID : TffDatabaseID; - const aTableName : TffTableName; - var aLocked : Boolean) : TffResult; -var - DB : TffSrDatabase; - Table : TffSrBaseTable; -begin - aLocked := False; - try - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result <> DBIERR_NONE) then - exit; - - try - FFSetRetry(DB.Timeout); - Result := DB.NotifyExtenders(ffeaBeforeTabRead, ffeaNoAction); - - Table := GetTableInstance(DB.Folder, aTableName); - - { Is the table open? } - if Assigned(Table) then - aLocked := Table.Folder.LockMgr.TableLockGranted(Table.TableID) = ffsltExclusive; - finally - DB.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.GetTableInstance(aFolder : TffSrFolder; - const aTableName : TffTableName) : TffSrBaseTable; -var - Inx : integer; -begin - { Assumption: Calling routine has locked TableList appropriately. } - for Inx := 0 to pred(TableList.TableCount) do begin - Result := TableList[ftFromIndex, Inx]; - with Result do - if (Folder = aFolder) and - (FFCmpShStrUC(BaseName, aTableName, 255) = 0) then - Exit; - end; - Result := nil; -end; -{--------} -function TffServerEngine.IndexClear(aCursorID : TffCursorID) : TffResult; -{Restructured !!.01} -var - Cursor : TffSrBaseCursor; - StartedTrans : boolean; - TransID : TffTransID; -begin - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - StartedTrans := false; - try - FFSetRetry(Cursor.Timeout); - { Make sure a read-only transaction is active. } - if not assigned(Cursor.Database.Transaction) then begin - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - StartedTrans := (Result = DBIERR_NONE); - end; - if Result = DBIERR_NONE then begin - Cursor.ClearIndex; - if StartedTrans then - seTransactionCommit(Cursor.Database); - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} - finally - Cursor.Deactivate; - end; -end; -{--------} -function TffServerEngine.IsTableNameOpen(aFolder : TffSrFolder; - const aTableName : TffTableName) : boolean; -var - Inx : integer; -begin - Result := true; - TableList.BeginRead; - try - for Inx := 0 to pred(TableList.TableCount) do - with TableList[ftFromIndex, Inx] do - if (Folder = aFolder) and - (FFCmpShStrUC(BaseName, aTableName, 255) = 0) then - Exit; - finally - TableList.EndRead; - end; - Result := false; -end; -{--------} -function TffServerEngine.seCheckSessionIDAndGet(aSessionID : TffSessionID; - var aSession : TffSrSession) : TffResult; -begin - Result := DBIERR_FF_UnknownSession; - try - if TObject(aSessionID) is TffSrSession then begin - aSession := TffSrSession(aSessionID); - Result := DBIERR_NONE; - end; - except - { An exception may be raised if the ID is bogus. Swallow the exception.} - end; -end; -{--------} -function TffServerEngine.CheckSessionIDAndGet(aClientID : TffClientID; - aSessionID : TffSessionID; - var aClient : TffSrClient; - var aSession : TffSrSession) : TffResult; -begin - if State <> ffesStarted then begin - Result := DBIERR_FF_ServerUnavail; - Exit; - end; - - Result := CheckClientIDAndGet(aClientID, aClient); - if (Result = DBIERR_NONE) then - Result := seCheckSessionIDAndGet(aSessionID, aSession); -end; -{--------} -procedure TffServerEngine.lcSetEventLog(anEventLog : TffBaseLog); -begin - inherited lcSetEventLog(anEventLog); - seSetLoggingState; -end; -{--------} -procedure TffServerEngine.lcSetLogEnabled(const aEnabled : boolean); -begin - inherited lcSetLogEnabled(aEnabled); - seSetLoggingState; -end; -{--------} -function TffServerEngine.RebuildRegister(aClientID : TffClientID; - aTotalRecords : Longint) : TffSrRebuildStatus; -begin - Result := seRebuildList.AddRebuildStatus(aClientID, aTotalRecords); -end; -{--------} -procedure TffServerEngine.RebuildDeregister(aRebuildID : Longint); -begin - seRebuildList.MarkRebuildStatusFinished(aRebuildID); -end; -{--------} -function TffServerEngine.RebuildGetStatus(aRebuildID : Longint; - const aClientID : TffClientID; - var aIsPresent : boolean; - var aStatus : TffRebuildStatus) : TffResult; -var - Client : TffSrClient; -begin - Result := seCheckClientIDAndGet(aClientID, Client); - if Result = DBIERR_NONE then begin - aIsPresent := seRebuildList.GetRebuildStatus(aRebuildID, aStatus); - Result := DBIERR_NONE; - end; -end; -{--------} -function TffServerEngine.RecordDelete(aCursorID : TffCursorID; aData : PffByteArray) : TffResult; -var - Cursor : TffSrBaseCursor; - Trans : TffSrTransaction; - TransID : TffTransID; - StartedTrans : boolean; -begin - StartedTrans := false; - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if Result = DBIERR_NONE then - try - FFSetRetry(Cursor.Timeout); - if (Result = DBIERR_NONE) then begin - Result := Cursor.EnsureWritable(True, True); {!!.02} - if (Result = DBIERR_NOACTIVETRAN) or Cursor.NeedNestedTransaction then begin {!!.03} - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - StartedTrans := Result = DBIERR_NONE; - end; - try - if (Result = DBIERR_NONE) then begin - Result := Cursor.DeleteRecord(aData); - if (Result <> DBIERR_NONE) and not StartedTrans then begin - Trans := Cursor.Database.Transaction; - Trans.IsCorrupt := true; - end; - end; - finally - if StartedTrans then - if (Result = DBIERR_NONE) then - Result := seTransactionCommit(Cursor.Database) - else - seTransactionRollback(Cursor.Database); - end;{try..finally} - end; - finally - Cursor.Deactivate; - end; - except - on E : Exception do - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end;{try..except} -end; -{--------} -function TffServerEngine.RecordDeleteBatch(aCursorID : TffCursorID; - aBMCount : Longint; - aBMLen : Longint; - aData : PffByteArray; - aErrors : PffLongintArray - ) : TffResult; -{Restructured !!.10} -var - Cursor : TffSrBaseCursor; - TransID : TffTransID; - Offset : Longint; - IRRes : TffResult; - RecInx : integer; - StartedTrans : boolean; -begin - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - StartedTrans := false; - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.EnsureWritable(False, False); {!!.02} - if (Result = DBIERR_NOACTIVETRAN) or - Cursor.NeedNestedTransaction then begin {!!.03} - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - StartedTrans := true; - end; - if (Result = DBIERR_NONE) then begin - try - Offset := 0; - for RecInx := 0 to pred(aBMCount) do begin - IRRes := CursorSetToBookmark(aCursorID, {!!.10} - PffByteArray(@aData^[Offset])); {!!.10} - if IRRes = DBIERR_NONE then - IRRes := RecordDelete(aCursorID, nil); - aErrors^[RecInx] := IRRes; - inc(Offset, aBMLen); - end; - finally - if StartedTrans then - Result := seTransactionCommit(Cursor.Database); - end;{try..finally} - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} - finally - Cursor.Deactivate; - end; -end; -{--------} -function TffServerEngine.RecordExtractKey(aCursorID : TffCursorID; - aData : PffByteArray; - aKey : PffByteArray) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.NotifyExtenders(ffeaBeforeRecRead, ffeaNoAction); - if Result = DBIERR_NONE then - if (Cursor.IndexID = 0) then - Result := DBIERR_NOASSOCINDEX - else begin - Result := Cursor.ExtractKey(aData, aKey); - if Result = DBIERR_NONE then - Cursor.NotifyExtenders(ffeaAfterRecRead, ffeaNoAction); - end; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.RecordGet(aCursorID : TffCursorID; - aLockType : TffLockType; - aData : PffByteArray) : TffResult; -var - Cursor : TffSrBaseCursor; - ServerLockType : TffSrLockType; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if Result = DBIERR_NONE then - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.NotifyExtenders(ffeaBeforeRecRead, ffeaNoAction); - if (Result = DBIERR_NONE) then begin - ServerLockType := FFMapLock(aLockType, false); - Result := Cursor.GetRecord(aData, ServerLockType); - if Result = DBIERR_NONE then - Cursor.NotifyExtenders(ffeaAfterRecRead, ffeaNoAction); - end; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.RecordGetBatch(aCursorID : TffCursorID; - aRecCount : Longint; - aRecLen : Longint; - var aRecRead : Longint; - aData : PffByteArray; - var aError : TffResult) : TffResult; -var - Cursor : TffSrBaseCursor; - Offset : Longint; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - if Result = DBIERR_NONE then begin - Offset := 0; - aError := Cursor.GetNextRecord(PffByteArray(@aData^[Offset]), ffsltNone); - if (aError = DBIERR_NONE) then - aRecRead := 1 - else - aRecRead := 0; - if aError = DBIERR_FF_FilterTimeout then - Result := aError; - while (aError = DBIERR_NONE) and (aRecRead < aRecCount) do begin - inc(Offset, aRecLen); - aError := Cursor.GetNextRecord(PffByteArray(@aData^[Offset]), ffsltNone); - if (aError = DBIERR_NONE) then - inc(aRecRead); - end; {while} - end; {if} - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.RecordGetForKey(aCursorID : TffCursorID; - aDirectKey : boolean; - aFieldCount : integer; - aPartialLen : integer; - aKeyData : PffByteArray; - aData : PffByteArray; - aFirstCall : Boolean) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.NotifyExtenders(ffeaBeforeRecRead, ffeaNoAction); - if Result = DBIERR_NONE then begin - Result := Cursor.GetRecordForKey(aDirectKey, - aFieldCount, - aPartialLen, - aKeyData, - aData, - aFirstCall); - if Result = DBIERR_NONE then - Cursor.NotifyExtenders(ffeaAfterRecRead, ffeaNoAction); - end; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.RecordGetNext(aCursorID : TffCursorID; - aLockType : TffLockType; - aData : PffByteArray) : TffResult; -var - Cursor : TffSrBaseCursor; - ServerLockType : TffSrLockType; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.NotifyExtenders(ffeaBeforeRecRead, ffeaNoAction); - if Result = DBIERR_NONE then begin - ServerLockType := FFMapLock(aLockType, false); - Result := Cursor.GetNextRecord(aData, ServerLockType); - if Result = DBIERR_NONE then - Cursor.NotifyExtenders(ffeaAfterRecRead, ffeaNoAction); - end; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.RecordGetNextSeq(aCursorID : TffCursorID; - var aRefNr : TffInt64; - aData : PffByteArray) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - if Result = DBIERR_NONE then - Cursor.Table.GetNextRecordSeq(Cursor.Database.TransactionInfo, aRefNr, aData); - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.RecordGetPrior(aCursorID : TffCursorID; - aLockType : TffLockType; - aData : PffByteArray) : TffResult; -var - Cursor : TffSrBaseCursor; - ServerLockType : TffSrLockType; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.NotifyExtenders(ffeaBeforeRecRead, ffeaNoAction); - if Result = DBIERR_NONE then begin - ServerLockType := FFMapLock(aLockType, false); - Result := Cursor.GetPriorRecord(aData, ServerLockType); - if Result = DBIERR_NONE then - Cursor.NotifyExtenders(ffeaAfterRecRead, ffeaNoAction); - end; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.RecordInsert(aCursorID : TffCursorID; - aLockType : TffLockType; - aData : PffByteArray) : TffResult; -{Restructured !!.10} -var - Cursor : TffSrBaseCursor; - ServerLockType : TffSrLockType; - StartedTrans : boolean; - TransID : TffTransID; -begin - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - StartedTrans := False; - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.EnsureWritable(False, True); {!!.02} - { Need to start an implicit transaction? } - if (Result = DBIERR_NOACTIVETRAN) or {!!.03} - Cursor.NeedNestedTransaction then begin {!!.03} - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - StartedTrans := (Result = DBIERR_NONE); - end; -// else {Deleted !!.11} -// Cursor.Table.UseInternalRollback := True; {Deleted !!.11} - -// try {Deleted !!.11} - if (Result = DBIERR_NONE) then begin - ServerLockType := FFMapLock(aLockType, false); - Result := Cursor.InsertRecord(aData, ServerLockType); - end; -// finally {Deleted !!.11} -{Begin !!.05} -// Cursor.Table.UseInternalRollback := False; {Deleted !!.11} -// end; - if StartedTrans then begin - if (Result = DBIERR_NONE) then - Result := seTransactionCommit(Cursor.Database) - else - seTransactionRollback(Cursor.Database); - end; -{End !!.05} - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} - finally - Cursor.Deactivate; - end; -end; -{--------} -function TffServerEngine.RecordInsertBatch(aCursorID : TffCursorID; - aRecCount : Longint; - aRecLen : Longint; - aData : PffByteArray; - aErrors : PffLongintArray) : TffResult; -{Restructured !!.10} -var - Cursor : TffSrBaseCursor; - TransID : TffTransID; - Offset : Longint; - IRRes : TffResult; - RecInx : integer; - StartedTrans : boolean; -begin - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - StartedTrans := false; - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.EnsureWritable(False, False); {!!.02} - if (Result = DBIERR_NOACTIVETRAN) or - Cursor.NeedNestedTransaction then begin {!!.03} - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - StartedTrans := true; - end; - if (Result = DBIERR_NONE) then begin - try - Offset := 0; - for RecInx := 0 to pred(aRecCount) do begin - IRRes := RecordInsert( aCursorID, ffltWriteLock, - PffByteArray(@aData^[Offset])); - aErrors^[RecInx] := IRRes; - inc(Offset, aRecLen); - end; - finally - if StartedTrans then - Result := seTransactionCommit(Cursor.Database); - end;{try..finally} - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} - finally - Cursor.Deactivate; - end; -end; -{--------} -function TffServerEngine.RecordIsLocked(aCursorID : TffCursorID; aLockType : TffLockType; - var aIsLocked : boolean) : TffResult; -var - Cursor : TffSrBaseCursor; - ServerLockType : TffSrLockType; -begin - Result := DBIERR_NONE; - aIsLocked := false; - if (aLockType = ffltNoLock) then - Exit; - - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.NotifyExtenders(ffeaBeforeTabRead, ffeaNoAction); - if Result = DBIERR_NONE then begin - ServerLockType := FFMapLock(aLockType, true); - - aIsLocked := Cursor.IsRecordLocked(ServerLockType); - end; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.RecordModify(aCursorID : TffCursorID; - aData : PffByteArray; - aRelLock : boolean) : TffResult; -{Restructured !!.10} -var - Cursor : TffSrBaseCursor; - TransID : TffTransID; - StartedTrans : boolean; -begin - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - StartedTrans := false; - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.EnsureWritable(True, False); {!!.02} - { Need to start an implicit transaction? } - if (Result = DBIERR_NOACTIVETRAN) or {!!.03} - Cursor.NeedNestedTransaction then begin {!!.03} - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - StartedTrans := Result = DBIERR_NONE; -{Begin !!.03} - end; -// else {Deleted !!.11} -// Cursor.Table.UseInternalRollback := True; {Deleted !!.11} -{End !!.03} - -// try {Deleted !!.11} - if (Result = DBIERR_NONE) then begin - Result := Cursor.ModifyRecord(aData, aRelLock); - end; -{Begin !!.05} -// finally {Deleted !!.11} -// Cursor.Table.UseInternalRollback := False; {!!.03}{Deleted !!.11} -// end;{try..finally} {Deleted !!.11} - if StartedTrans then begin - if (Result = DBIERR_NONE) then - Result := seTransactionCommit(Cursor.Database) - else - seTransactionRollback(Cursor.Database); - end; { if } - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} -{End !!.05} - finally - Cursor.Deactivate; - end; -end; -{--------} -function TffServerEngine.RecordRelLock(aCursorID : TffCursorID; aAllLocks : boolean) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - { Assumption: Transaction is active. } - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Cursor.RelRecordLock(aAllLocks); - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.seDatabaseOpenPrim(Session : TffSrSession; - Folder : TffSrFolder; - anAlias : TffName; - aOpenMode : TffOpenMode; - aShareMode : TffShareMode; - aTimeout : Longint; - aCheckSpace : Boolean) {!!.11} - : TffSrDatabase; -var - aMonitor : TffBaseEngineMonitor; - anExtender : TffBaseEngineExtender; - anIndex : Longint; - MonitorList : TffList; -begin - Result := TffSrDatabase.Create(Self, - Session, - Folder, - anAlias, - aOpenMode, - aShareMode, - aTimeout, - aCheckSpace); {!!.11} - { Assumption: Calling routine has gained write access to the database list. } - DatabaseList.BeginWrite; - try - DatabaseList.AddDatabase(Result); - finally - DatabaseList.EndWrite; - end; - - { If there are any monitors interested in databases then see if they - are interested in this database. } - MonitorList := GetInterestedMonitors(TffSrDatabase); - if assigned(MonitorList) then begin - for anIndex := 0 to pred(MonitorList.Count) do begin - aMonitor := TffBaseEngineMonitor - (TffIntListItem(MonitorList[anIndex]).KeyAsInt); - try - anExtender := aMonitor.Interested(Result); - if assigned(anExtender) then - Result.dbAddExtender(anExtender); - except - on E:Exception do - seForce('Monitor [%s] exception, seDatabaseOpenPrim: %s', {!!.06 - Start} - [aMonitor.ClassName,E.message], - bseGetReadOnly); {!!.06 - End} - end; - end; - MonitorList.Free; - end; - -end; -{--------} -function TffServerEngine.SQLAlloc(aClientID : TffClientID; - aDatabaseID : TffDatabaseID; - aTimeout : Longint; - var aStmtID : TffSqlStmtID) : TffResult; -var - Client : TffSrClient; - DB : TffSrDatabase; -begin - try - Result := CheckClientIDAndGet(aClientID, Client); - if Result = DBIERR_NONE then - try - Result := seCheckDatabaseIDAndGet(aDatabaseID, DB); - if Result = DBIERR_NONE then begin - FFSetRetry(5000); - Result := DB.NotifyExtenders(ffeaBeforeTabRead, ffeaNoAction); - if Result = DBIERR_NONE then begin - if assigned(seSQLEngine) then - Result := seSQLEngine.Alloc(Self, aClientID, aDatabaseID, - aTimeout, aStmtID) - else - FFRaiseException(EffServerException, ffStrResServer, - fferrNoSQLEngine, [seGetServerName]); - end; - end; - finally - Client.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.SQLExec(aStmtID : TffSqlStmtID; - aOpenMode : TffOpenMode; - var aCursorID : TffCursorID; - aStream : TStream) : TffResult; -begin - Result := DBIERR_NONE; - try - { Note: Timeout set in SQLAlloc. } - if assigned(seSQLEngine) then - Result := seSQLEngine.Exec(aStmtID, aOpenMode, aCursorID, aStream) - else - FFRaiseException(EffServerException, ffStrResServer, - fferrNoSQLEngine, [seGetServerName]); - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.SQLExecDirect(aClientID : TffClientID; - aDatabaseID : TffDatabaseID; - aQueryText : PChar; - aTimeout : Longint; - aOpenMode : TffOpenMode; - var aCursorID : TffCursorID; - aStream : TStream) : TffResult; -var - Client : TffSrClient; - DB : TffSrDatabase; -begin - try - Result := CheckClientIDAndGet(aClientID, Client); - if Result = DBIERR_NONE then - try - Result := seCheckDatabaseIDAndGet(aDatabaseID, DB); - if Result = DBIERR_NONE then begin - FFSetRetry(aTimeout); - Result := DB.NotifyExtenders(ffeaBeforeTabRead, ffeaNoAction); - if Result = DBIERR_NONE then begin - if assigned(seSQLEngine) then - Result := seSQLEngine.ExecDirect(Self, aClientID, aDatabaseID, - aQueryText, aOpenMode, aTimeout, - aCursorID, aStream) - else - FFRaiseException(EffServerException, ffStrResServer, - fferrNoSQLEngine, [seGetServerName]); - end; - end; - finally - Client.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.SQLFree(aStmtID : TffSqlStmtID) : TffResult; -begin - Result := DBIERR_NONE; - try - FFSetRetry(5000); - if assigned(seSQLEngine) then - Result := seSQLEngine.FreeStmt(aStmtID) - else - FFRaiseException(EffServerException, ffStrResServer, - fferrNoSQLEngine, [seGetServerName]); - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.SQLPrepare(aStmtID : TffSqlStmtID; - aQueryText : PChar; - aStream : TStream) : TffResult; -begin - Result := DBIERR_NONE; - try - FFSetRetry(5000); - if assigned(seSQLEngine) then - Result := seSQLEngine.Prepare(aStmtID, aQueryText, aStream) - else - FFRaiseException(EffServerException, ffStrResServer, - fferrNoSQLEngine, [seGetServerName]); - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.SQLSetParams(aStmtID : TffSqlStmtID; - aNumParams : word; - aParamDescs : Pointer; - aDataBuffer : PffByteArray; - aDataLen : integer; - aStream : TStream) : TffResult; -begin - Result := DBIERR_NONE; - try - FFSetRetry(5000); - if assigned(seSQLEngine) then - Result := seSQLEngine.SetParams(aStmtID, aNumParams, aParamDescs, - aDataBuffer, aStream) - else - FFRaiseException(EffServerException, ffStrResServer, - fferrNoSQLEngine, [seGetServerName]); - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.TableAddIndex(const aDatabaseID : TffDatabaseID; - const aCursorID : TffCursorID; - const aTableName : TffTableName; - const aIndexDesc : TffIndexDescriptor) : TffResult; -{Restructured !!.10} -var - Cursor : TffSrBaseCursor; - DB : TffSrDatabase; - StartedTrans : boolean; - tmpCursorID : TffCursorID; - tmpTablename : string; - TransID : TffTransID; - FI : PffFileInfo; - FileHeader : PffBlockHeaderFile; - aRelMethod : TffReleaseMethod; -begin - {choice of two here: if the cursor ID is set, use it. Otherwise - use the databaseID/tablename} - if (aCursorID <> 0) then begin - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - StartedTrans := false; - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.NotifyExtenders(ffeaBeforeAddInx, ffeaTabAddInxFail); - if Result = DBIERR_NONE then begin - tmpTableName := Cursor.Table.BaseName; - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - if (Result = DBIERR_NONE) then begin - StartedTrans := true; - Result := Cursor.AddIndexToTable(aIndexDesc); -{Begin !!.13} - if (Result = DBIERR_NONE) then begin - {update the file header} - TableList.BeginRead; - try - FI := TableList.GetTableFromName(aTableName).Files[0]; - finally - TableList.EndRead; - end; - FileHeader := - PffBlockHeaderFile(BufferManager.GetBlock(FI, 0, DB.dbTI, - True, - aRelMethod)); - inc(FileHeader^.bhfIndexCount); - aRelMethod(PffBlock(FileHeader)); - seTransactionCommit(Cursor.Database) - end -{End !!.13} - else begin - Cursor.NotifyExtenders(ffeaTabAddInxFail, ffeaNoAction); - seTransactionRollback(Cursor.Database) - end; - end; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} - finally - Cursor.Deactivate; - end; - end - else {use databaseID/tablename} begin - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result = DBIERR_NONE) then - try - StartedTrans := False; - try - FFSetRetry(DB.Timeout); - Result := TableOpen(aDatabaseID, aTableName, - false, '', 0, omReadWrite, smExclusive, DB.Timeout, - tmpCursorID, nil); - if (Result = DBIERR_NONE) then - try - Result := seCheckCursorIDAndGet(tmpCursorID, Cursor); - if (Result = DBIERR_NONE) then begin - Result := Cursor.NotifyExtenders(ffeaBeforeAddInx, ffeaTabAddInxFail); - if Result = DBIERR_NONE then begin - Result := seTransactionStart(DB, false, ffcl_TrImplicit, - TransID); - if (Result = DBIERR_NONE) then begin - StartedTrans := true; - Result := Cursor.AddIndexToTable(aIndexDesc); - if (Result = DBIERR_NONE) then begin - {update the file header} - TableList.BeginRead; - try - FI := TableList.GetTableFromName(aTableName).Files[0]; - finally - TableList.EndRead; - end; - FileHeader := - PffBlockHeaderFile(BufferManager.GetBlock(FI, 0, DB.dbTI, - True, - aRelMethod)); - inc(FileHeader^.bhfIndexCount); - aRelMethod(PffBlock(FileHeader)); - seTransactionCommit(Cursor.Database) - end else begin - Cursor.NotifyExtenders(ffeaTabAddInxFail, ffeaNoAction); - seTransactionRollback(Cursor.Database) - end; - end; - end; - end; - finally - CursorClose(tmpCursorID); - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(DB); - end; - end;{try..except} - finally - DB.Deactivate; - end; - end; -end; -{--------} -function TffServerEngine.TableBuild(aDatabaseID : TffDatabaseID; - aOverWrite : boolean; - const aTableName : TffTableName; - aForServer : boolean; - aDictionary : TffDataDictionary) : TffResult; -var - DB : TffSrDatabase; -begin - if IsReadOnly then begin {!!.01 - Start} - Result := DBIERR_READONLYDB; - Exit; - end; {!!.01 - End} - try - {the database ID must exist} - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result <> DBIERR_NONE) then - exit; - - try - FFSetRetry(DB.Timeout); - Result := DB.NotifyExtenders(ffeaBeforeTabInsert, ffeaTabInsertFail); - - if Result = DBIERR_NONE then begin - {the database must be open in readwrite mode} - if (DB.OpenMode = omReadOnly) then begin - Result := DBIERR_READONLYDB; - Exit; - end; - Result := seTableBuildPrim(DB, aOverwrite, aTableName, aForServer, - aDictionary); - if Result <> DBIERR_NONE then - DB.NotifyExtenders(ffeaTabInsertFail, ffeaNoAction); - end; - finally - DB.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.seTableBuildPrim(aDB : TffSrDatabase; - aOverwrite : boolean; - const aTableName : TffTableName; - aForServer : boolean; - aDict : TffDataDictionary) : TffResult; -var - Table : TffSrBaseTable; - TableDataFile : TffFileNameExt; - TransID : TffTransID; -begin - { Obtain write access to the table list. Our purpose is to make sure - the table is not opened. We have to obtain write access, instead of read - access, just in case we need to call TableList.RemoveIfUnused. } - TableList.BeginWrite; - try - { Is the table open? } - Table := GetTableInstance(aDB.Folder, aTableName); - if (Table <> nil) then begin - { Yes. See if it can be closed. } - TableList.RemoveIfUnused(Table); - if GetTableInstance(aDB.Folder, aTableName) <> nil then begin - Result := DBIERR_TABLEOPEN; - Exit; - end; - end; - {the table name must be a valid file name without extension} - if not FFVerifyFileName(aTableName) then begin - Result := DBIERR_INVALIDTABLENAME; - Exit; - end; - {the table's data file connot exist within the database} - TableDataFile := FFMakeFileNameExt(aTableName, ffc_ExtForData); - if FFFileExists(FFMakeFullFileName(aDB.Folder.Path, TableDataFile)) then begin - if aOverWrite then begin - {we want to overwrite this table - we have to delete it first} - {table exists, is not open - we can delete the table and all files} - seDeleteTable(aDB, aTableName); - end - else begin - {table exists, and we're not going to overwrite it} - Result := DBIERR_TABLEEXISTS; - Exit; - end; - end; - - { Create the table. } - Table := TffSrTable.Create(Self, aTableName, aDB.Folder, seBufMgr, - omReadWrite); - - try - { Start a transaction. Note that if one is already active for this - database object, this will be a nested transaction. } - Result := seTransactionStart(aDB, false, ffcl_TrImplicit, TransID); - if Result <> DBIERR_NONE then - Exit; - - try - { Create files making up the table. } - Table.BuildFiles(aDB.TransactionInfo, aForServer, aDict, [], nil); - { Commit the transaction. } - seTransactionCommit(aDB); - - { If we are in a nested transaction then the table will not have - been written out to disk. Make sure the changes are written to - disk. } - if aDB.Transaction <> nil then - Table.CommitChanges(aDB.TransactionInfo); - except - on E:Exception do begin - seTransactionRollback(aDB); - raise; - end; - end;{try..except} - finally - { Destroy the table object. This will close all the files. } - Table.Free; - end;{try..finally} - finally - TableList.EndWrite; - end; -end; -{--------} -function TffServerEngine.seTableDeletePrim(DB : TffSrDatabase; - const aTableName : TffTableName) : TffResult; -var - Table : TffSrBaseTable; -begin - - Result := DBIERR_NONE; - - { If no tablename specified then exit otherwise a lower level routine - (FFFindClose) will go into an infinite loop. } - if aTableName = '' then begin - Result := DBIERR_INVALIDTABLENAME; - exit; - end; - - { Obtain write access to the table list. This is our way of making sure - nobody opens the table in between our determining the table is NOT open - and deleting the table. } - TableList.BeginWrite; - try - { Is the table open? } - Table := GetTableInstance(DB.Folder, aTableName); - if (Table <> nil) then begin - { Yes. Can it be closed? } - TableList.RemoveIfUnused(Table); - if GetTableInstance(DB.Folder, aTableName) <> nil then begin - { No. Return an error. } - Result := DBIERR_TABLEOPEN; - Exit; - end; - end; - seDeleteTable(DB, aTableName) - finally - TableList.EndWrite; - end; -end; -{--------} -function TffServerEngine.TableDelete(aDatabaseID : TffDatabaseID; - const aTableName : TffTableName) : TffResult; -var - DB : TffSrDatabase; -begin - if IsReadOnly then begin {!!.01 - Start} - Result := DBIERR_TABLEREADONLY; - Exit; - end; {!!.01 - End} - try - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if Result = DBIERR_NONE then - try - FFSetRetry(DB.Timeout); - Result := DB.NotifyExtenders(ffeaBeforeTabDelete, ffeaTabDeleteFail); - if (Result = DBIERR_NONE) then begin - Result := seTableDeletePrim(DB, aTableName); - if Result <> DBIERR_NONE then - DB.NotifyExtenders(ffeaTabDeleteFail, ffeaNoAction); - end; - finally - DB.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.TableDropIndex(aDatabaseID : TffDatabaseID; - aCursorID : TffCursorID; - const aTableName : TffTableName; - const aIndexName : TffDictItemName; - aIndexID : Longint) : TffResult; -{Restructured !!.10} -var - aTable : TffSrBaseTable; {!!.02} - Cursor : TffSrBaseCursor; - DB : TffSrDatabase; - StartedTrans : boolean; - TransID : TffTransID; -begin - { Assumption: Table has been opened for Exclusive use. This is verified - in Cursor.DropIndexFromTable. } - {choice of two here: if the cursor ID is set use that, otherwise - use the databaseID/tablename} - if (aCursorID <> 0) then begin - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - StartedTrans := false; - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.NotifyExtenders(ffeaBeforeTabDelete, ffeaTabDeleteFail); - if Result = DBIERR_NONE then begin - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - if (Result = DBIERR_NONE) then begin - StartedTrans := true; - Result := Cursor.DropIndexFromTable(aIndexName, aIndexID); - if (Result = DBIERR_NONE) then begin - seTransactionCommit(Cursor.Database); - end else begin - Cursor.NotifyExtenders(ffeaTabDeleteFail, ffeaNoAction); - seTransactionRollback(Cursor.Database); - end; { if } - end; { if } - end; { if } - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} - finally - Cursor.Deactivate; - end; - end - else {use databaseID/tablename} begin - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if Result = DBIERR_NONE then - try - StartedTrans := false; - try - FFSetRetry(DB.Timeout); - Result := TableOpen(aDatabaseID, aTableName, - false, '', 0, omReadWrite, smExclusive, DB.Timeout, - aCursorID, nil); - if (Result = DBIERR_NONE) then - try - Result := seCheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then begin - Result := Cursor.NotifyExtenders(ffeaBeforeTabDelete, ffeaTabDeleteFail); - if Result = DBIERR_NONE then begin - Result := seTransactionStart(DB, false, ffcl_TrImplicit, - TransID); - if (Result = DBIERR_NONE) then begin - StartedTrans := true; -{Begin !!.02} - try - Result := Cursor.DropIndexFromTable(aIndexName, aIndexID); - if (Result = DBIERR_NONE) then - seTransactionCommit(Cursor.Database) - else begin - Cursor.NotifyExtenders(ffeaTabDeleteFail, ffeaNoAction); - seTransactionRollback(Cursor.Database) - end; - except - Cursor.NotifyExtenders(ffeaTabDeleteFail, ffeaNoAction); - seTransactionRollback(Cursor.Database); - StartedTrans := False; - raise; - end; -{End !!.02} - end; - end; - end; { if } - finally - aTable := Cursor.Table; {!!.02} - CursorClose(aCursorID); - TableList.RemoveIfUnused(aTable); {!!.02} - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(DB); - end; - end;{try..except} - finally - DB.Deactivate; - end; - end; -end; -{--------} -function TffServerEngine.TableEmpty(aDatabaseID : TffDatabaseID; - aCursorID : TffCursorID; - const aTableName : TffTableName) : TffResult; -{Restructured !!.10} -var - Cursor : TffSrBaseCursor; - DB : TffSrDatabase; - Dict : TffDataDictionary; - Trans : TffSrTransaction; - TransID : TffTransID; -begin - if IsReadOnly then begin {!!.01 - Start} - Result := DBIERR_TABLEREADONLY; - Exit; - end; {!!.01 - End} - - { Choice of two here: if the cursor ID is set use that, otherwise - use the databaseID/tablename. } - if (aCursorID <> 0) then begin - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if Result = DBIERR_NONE then - try - Trans := nil; - try - FFSetRetry(Cursor.Timeout); - DB := Cursor.Database; - Result := Cursor.NotifyExtenders(ffeaBeforeTabDelete, ffeaTabDeleteFail); - - { Verify the cursor is writable & start an implicit transaction if - necessary. } - if (Result = DBIERR_NONE) then begin - Result := Cursor.EnsureWritable(False, False); {!!.02} - if Result = DBIERR_NOACTIVETRAN then - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - Trans := Cursor.Database.Transaction; - end; - if (Result = DBIERR_NONE) then begin - Result := Cursor.Empty; - { If this was an implicit transaction then commit/rollback. } - if (Result = DBIERR_NONE) and Trans.IsImplicit then - seTransactionCommit(DB) - else begin - Cursor.NotifyExtenders(ffeaTabDeleteFail, ffeaNoAction); - seTransactionRollback(DB); - end; { if } - end; { if } - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if assigned(Trans) and Trans.IsImplicit then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} - finally - Cursor.Deactivate; - end; - end - else {use databaseID/tablename} begin - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if Result = DBIERR_NONE then - try - Trans := nil; - try - FFSetRetry(DB.Timeout); - Result := DB.NotifyExtenders(ffeaBeforeTabDelete, ffeaTabDeleteFail); - if Result = DBIERR_NONE then begin - Dict := TffDataDictionary.Create(4096); - try - Result := seGetDictionary(DB, aTableName, Dict); - if (Result = DBIERR_NONE) then - Result := seTableBuildPrim(DB, true, aTableName, false, Dict); - if Result <> DBIERR_NONE then - DB.NotifyExtenders(ffeaTabDeleteFail, ffeaNoAction); - finally - Dict.Free; - end; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if assigned(Trans) and Trans.IsImplicit then - seTransactionRollback(DB); - end; - end;{try..except} - finally - DB.Deactivate; - end; - end; -end; -{--------} -function TffServerEngine.TableGetAutoInc(aCursorID : TffCursorID; - var aValue : TffWord32) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.NotifyExtenders(ffeaBeforeTabRead, ffeaNoAction); - if (Result = DBIERR_NONE) then - Cursor.ReadAutoIncValue(aValue); - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.TableGetDictionary(aDatabaseID : TffDatabaseID; - const aTableName : TffTableName; - aForServer : boolean; - aStream : TStream) : TffResult; -var - DB : TffSrDatabase; - Dict : TffDataDictionary; -begin - try - {the database ID must exist} - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result <> DBIERR_NONE) then - exit; - - try - FFSetRetry(DB.Timeout); - Result := DB.NotifyExtenders(ffeaBeforeTabRead, ffeaNoAction); - - if Result = DBIERR_NONE then begin - { We must obtain write access on the engine's table list. Why? - Because another thread may be looking for the table at the same - time. If the table has not been opened, we don't want that thread - to open the table while we are opening the table. } - Dict := TffServerDataDict.Create(4096); - TableList.BeginWrite; - try - Result := seGetDictionary(DB, aTableName, Dict); - if Result = DBIERR_NONE then - Dict.WriteToStream(aStream); - finally - TableList.EndWrite; - Dict.Free; - end; - end; - finally - DB.Deactivate; - end; - except - on E : Exception do - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end;{try..except} -end; -{--------} -function TffServerEngine.TableGetRecCount(aCursorID : TffCursorID; - var aRecCount : Longint) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.NotifyExtenders(ffeaBeforeTabRead, ffeaNoAction); - if Result = DBIERR_NONE then - Result := Cursor.GetRecordCount(aRecCount); - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.TableIsLocked(aCursorID : TffCursorID; - aLockType : TffLockType; - var aIsLocked : boolean) : TffResult; -var - Cursor : TffSrBaseCursor; - ServerLockType : TffSrLockType; -begin - Result := DBIERR_NONE; - aIsLocked := false; - if (aLockType = ffltNoLock) then - Exit; - - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.NotifyExtenders(ffeaBeforeTabRead, ffeaNoAction); - if Result = DBIERR_NONE then begin - ServerLockType := FFMapLock(aLockType, true); - aIsLocked := Cursor.Table.HasLock(Cursor.CursorID, ServerLockType); - end; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.TableLockAcquire(aCursorID : TffCursorID; - aLockType : TffLockType) : TffResult; -var - Cursor : TffSrBaseCursor; - ServerLockType : TffSrLockType; -begin - Result := DBIERR_NONE; - if (aLockType = ffltNoLock) then - Exit; - - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Result := Cursor.NotifyExtenders(ffeaBeforeTableLock, ffeaTableLockFail); - if Result = DBIERR_NONE then - try - ServerLockType := FFMapLock(aLockType, True); - Cursor.Table.AcqClientLock(aCursorID, ServerLockType, False); - Cursor.NotifyExtenders(ffeaAfterTableLock, ffeaNoAction); - except - Cursor.NotifyExtenders(ffeaTableLockFail, ffeaNoAction); - raise; - end; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.TableLockRelease(aCursorID : TffCursorID; aAllLocks : Boolean) : TffResult; -var - Cursor : TffSrBaseCursor; -begin - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - FFSetRetry(Cursor.Timeout); - Cursor.Table.RelClientLock(aCursorID, aAllLocks); - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.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 - Cursor : TffSrBaseCursor; {!!.06} - DB : TffSrDatabase; - IndexID : Longint; - OpenMode : TffOpenMode; -begin - try - { The database must exist. } - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result <> DBIERR_NONE) then - exit; - - try - FFSetRetry(DB.Timeout); - Result := DB.NotifyExtenders(ffeaBeforeTabRead, ffeaNoAction); - - { Change the open mode to ReadOnly if the Server is ReadOnly. } - if Result = DBIERR_NONE then begin - if seConfig.GeneralInfo^.giReadOnly then - OpenMode := omReadOnly - else - OpenMode := aOpenMode; - - { The database and table open and share modes must 'match'. } - if (DB.OpenMode = omReadOnly) and (OpenMode <> omReadOnly) then begin - Result := DBIERR_READONLYDB; - Exit; - end; - if (DB.ShareMode = smExclusive) then - aShareMode := smExclusive; - - { Create a cursor for the table and return it, add it to the - server's cursor list. } - Cursor := CursorClass.Create(Self, DB, aTimeout); {!!.06} - try - Cursor.Open(aTableName, aIndexName, aIndexID, OpenMode, aShareMode, - aForServer, False, []); - - CursorList.BeginWrite; - try - CursorList.AddCursor(Cursor); - finally - CursorList.EndWrite; - end; - - { Get the cursor ID. } - aCursorID := Cursor.CursorID; - - { Write the information out to the stream - caller's responsibility to - create and destroy the stream - also to rewind it. } - if (aStream <> nil) then begin - { First, the cursor ID. } - aStream.Write(aCursorID, sizeof(aCursorID)); - - { Next, the data dictionary. } - Cursor.Dictionary.WriteToStream(aStream); - - { Finally the IndexID for the cursor. } - IndexID := Cursor.IndexID; - aStream.Write(IndexID, sizeof(IndexID)); - end; - except - Cursor.Free; - raise; - end; - end; { if } - finally - DB.Deactivate; - end; - except - on E : Exception do - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end;{try..except} -end; -{--------} -function TffServerEngine.seTableRenamePrim(DB : TffSrDatabase; - const aOldName, aNewName : TffName) : TffResult; - -var - Dict : TffDataDictionary; - Table : TffSrBaseTable; -begin - Dict := TffDataDictionary.Create(4096); - TableList.BeginWrite; - try - { Is the table open? } - Table := GetTableInstance(DB.Folder, aOldName); - if (Table <> nil) then begin - { Yes. Can it be closed? } - TableList.RemoveIfUnused(Table); - if GetTableInstance(DB.Folder, aOldName) <> nil then begin - { No. Return an error. } - Result := DBIERR_TABLEOPEN; - Exit; - end; - end; - Result := seGetDictionary(DB, aOldName, Dict); - { Retrieved the dictionary? } - if Result = DBIERR_NONE then begin - { Yes. Delete the files specified by the dictionary. } - FFTblHlpRename(DB.Folder.Path, aOldName, aNewName, Dict); - Result := DBIERR_NONE; - end - finally - TableList.EndWrite; - Dict.Free; - end; -end; -{--------} -function TffServerEngine.TableRename(aDatabaseID : TffDatabaseID; - const aOldName, aNewName : TffName) : TffResult; -var - DB : TffSrDatabase; -begin - try - { The table name must be a valid file name without extension. } - if not FFVerifyFileName(aNewName) then begin - Result := DBIERR_INVALIDTABLENAME; - Exit; - end; - - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result = DBIERR_NONE) then - try - FFSetRetry(DB.Timeout); - Result := DB.NotifyExtenders(ffeaBeforeTabUpdate, ffeaTabUpdateFail); - if Result = DBIERR_NONE then begin - Result := seTableRenamePrim(DB, aOldName, aNewName); - if Result <> DBIERR_NONE then - DB.NotifyExtenders(ffeaTabUpdateFail, ffeaNoAction); - end; - finally - DB.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.TableSetAutoInc(aCursorID : TffCursorID; - aValue : TffWord32) : TffResult; -{Restructured !!.10} -var - Cursor : TffSrBaseCursor; - StartedTrans: Boolean; - TransID: TffTransID; -begin - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if (Result = DBIERR_NONE) then - try - StartedTrans := false; - try - FFSetRetry(Cursor.Timeout); - StartedTrans := False; - Result := Cursor.NotifyExtenders(ffeaBeforeTabUpdate, ffeaTabUpdateFail); - if Result = DBIERR_NONE then begin - Result := Cursor.EnsureWritable(False, False); {!!.02} - if (Result = DBIERR_NOACTIVETRAN) or - Cursor.NeedNestedTransaction then begin {!!.03} - Result := seTransactionStart(Cursor.Database, false, - ffcl_TrImplicit, TransID); - StartedTrans := (Result = DBIERR_NONE); - end; - - if (Result = DBIERR_NONE) then begin - try - Cursor.SetAutoIncValue(aValue); - except - Cursor.NotifyExtenders(ffeaTabUpdateFail, ffeaNoAction); - raise; - end; - if StartedTrans then - Result := seTransactionCommit(Cursor.Database); - end; - end; { if } - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - if StartedTrans then - seTransactionRollback(Cursor.Database); - end; - end;{try..except} - finally - Cursor.Deactivate; - end; -end; -{--------} -{Begin !!.11} -function TffServerEngine.TableVersion(aDatabaseID : TffDatabaseID; - const aTableName : TffTableName; - var aVersion : Longint) : TffResult; -var - DB : TffSrDatabase; - FI : TffFileInfo; - FileHandle : THandle; - Table : TffSrBaseTable; - TableDataFile : TffFullFileName; - PTableDataFile : PAnsiChar; - Header : TffBlockHeaderFile; -begin - PTableDataFile := nil; - try - {the database ID must exist} - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result <> DBIERR_NONE) then - exit; - - try - FFSetRetry(DB.Timeout); - Result := DB.NotifyExtenders(ffeaBeforeTabRead, ffeaNoAction); - if Result = DBIERR_NONE then begin - { If the table is already open then return the version number from the - internal file data structure. Otherwise, open the main file for the - table & retrieve the version number from its header block. } - seTableList.BeginWrite; - try - { Try & find the open table in the engine's table list. If it exists already - then reference the existing table. } - Table := GetTableInstance(DB.Folder, aTableName); - - { Is the table open? } - if assigned(Table) then - { Yes. Return version # from in-memory information. } - aVersion := Table.Files[0].fiFFVersion - else if seTableExistsPrim(DB, aTableName) then begin - { Table exists. Open the file directly & retrieve the version number - from its header block. } - TableDataFile := FFMakeFullFileName - (DB.Folder.Path, - FFMakeFileNameExt(aTableName, ffc_ExtForData)); - FFGetMem(PTableDataFile, Length(TableDataFile) + 1); - StrPCopy(PTableDataFile, TableDataFile); - FileHandle := FFOpenFilePrim(PTableDataFile, omReadOnly, - smShareRead, False, False); - try - FI.fiHandle := FileHandle; - FI.fiName := FFShStrAlloc(TableDataFile); - FFReadFilePrim(@FI, SizeOf(TffBlockHeaderFile), Header); - aVersion := Header.bhfFFVersion; - finally - FFCloseFilePrim(@FI); - FFShStrFree(FI.fiName); - end; - end - else - { The file does not exist. Raise an error. } - FFRaiseException(EffException, ffstrResServer, fferrUnknownTable, - [aTableName, DB.Alias]); - finally - if PTableDataFile <> nil then - FFFreeMem(PTableDataFile, StrLen(PTableDataFile) + 1); - seTableList.EndWrite; - end; - end; { if } - - finally - DB.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{End !!.11} -{--------} -function TffServerEngine.seConvertSingleField(aSourceBuf, - aTargetBuf: PffByteArray; - aSourceCursorID, - aTargetCursorID: Longint; - aSourceFldNr, - aTargetFldNr: Integer; - aBLOBBuffer: Pointer; - aBLOBBufLen: Longint): TffResult; -var - SourceValue: Pointer; - TargetValue: Pointer; - SourceType: TffFieldType; - TargetType: TffFieldType; - SourceLength: Longint; - TargetLength: Longint; - SourceCursor, - TargetCursor: TffSrBaseCursor; -begin - Result := DBIERR_NONE; - try - seCheckCursorIDAndGet(aSourceCursorID, SourceCursor); - seCheckCursorIDAndGet(aTargetCursorID, TargetCursor); - - SourceValue := nil; - TargetValue := nil; - - with SourceCursor.Table.Dictionary do begin - if Assigned(aSourceBuf) then begin - - { If input field is a null, then output is automatically a null - regardless of datatype. } - if IsRecordFieldNull(aSourceFldNr, aSourceBuf) then begin - TargetCursor.Table.Dictionary.SetRecordField(aTargetFldNr, aTargetBuf, nil); - Exit; - end; - - {Begin !!.10} - { also count input field as null if it's a stringtype, the field - conains the empty string, and output field is a blob. } - if (TargetCursor.Table.Dictionary.FieldType[aTargetFldNr] in [fftBLOB..ffcLastBlobType]) and - (((FieldType[aSourceFldNr] in [fftNullString, fftNullAnsiStr]) and - (Byte(aSourceBuf^[FieldOffset[aSourceFldNr]])=0)) or - ((FieldType[aSourceFldNr] in [fftShortString, fftShortAnsiStr]) and - (Byte(aSourceBuf^[FieldOffset[aSourceFldNr]+1])=0)) or - ((FieldType[aSourceFldNr] in [fftWideString]) and - (WideChar(aSourceBuf^[FieldOffset[aSourceFldNr]])=''))) then begin - TargetCursor.Table.Dictionary.SetRecordField(aTargetFldNr, aTargetBuf, nil); - Exit; - end; - {End !!.10} - - SourceValue := Addr(aSourceBuf^[FieldOffset[aSourceFldNr]]); - end; - SourceType := FieldType[aSourceFldNr]; - SourceLength := FieldLength[aSourceFldNr]; - end; - - with TargetCursor.Table.Dictionary do begin - if Assigned(aTargetBuf) then - TargetValue := Addr(aTargetBuf^[FieldOffset[aTargetFldNr]]); - - TargetType := FieldType[aTargetFldNr]; - TargetLength := FieldLength[aTargetFldNr]; - end; - - Result := FFConvertSingleField(SourceValue, TargetValue, - SourceType, TargetType, - SourceLength, TargetLength); - - if Assigned(aTargetBuf) and (Result = DBIERR_NONE) then begin - - { Field is not null } - with TargetCursor.Table.Dictionary do - FFClearBit(@aTargetBuf^[LogicalRecordLength], aTargetFldNr); - - { Handle BLOB targets } - if TargetType in [fftBLOB..ffcLastBLOBType] then begin - Result := BLOBCreate(TargetCursor.CursorID, TffInt64(TargetValue^)); - if Result = DBIERR_NONE then - if SourceType in [fftBLOB..ffcLastBLOBType] then - Result := seBLOBCopy(SourceCursor, - TargetCursor, - TffInt64(SourceValue^), - TffInt64(TargetValue^), - aBLOBBuffer, - aBLOBBufLen) - else - {Begin !!.10} - if SourceType in [fftShortString, fftShortAnsiStr] then begin - { skip lengthbyte } - SourceValue := Pointer(Succ(Integer(SourceValue))); - Result := TargetCursor.BLOBWrite(TffInt64(TargetValue^), - 0, - SourceLength-1, - SourceValue^); - end - else -// if SourceType in [fftShortString, fftShortAnsiStr] begin - {End !!.10} - Result := TargetCursor.BLOBWrite(TffInt64(TargetValue^), - 0, - SourceLength, - SourceValue^); - end; - end; - except - {Begin !!.13} - on E : EOverFlow do - Result := DBIERR_INVALIDFLDXFORM; - {$IFOPT R+} - on E : ERangeError do - Result := DBIERR_INVALIDFLDXFORM; - {$ENDIF} - {End !!.13} - on E : Exception do begin - if Result = DBIERR_NONE then - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end; -end; -{--------} -{ Include code for asynchronous requests. } -{$i ffsrridx.inc} -{$i ffsrpack.inc} -{$i ffsrrest.inc} -{$i ffsrrcnt.inc} {!!.10} -{--------} -function TffServerEngine.TransactionCommit(const aDatabaseID : TffDatabaseID) : TffResult; -var - DB : TffSrDatabase; -begin - try - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result = DBIERR_NONE) then - try - FFSetRetry(DB.Timeout); - if DB.Transaction = nil then - Result := DBIERR_NOACTIVETRAN - else if DB.Transaction.IsCorrupt then begin - DB.NotifyExtenders(ffeaBeforeRollback, ffeaNoAction); - seTransactionRollback(DB); - Result := DBIERR_FF_CorruptTrans; - DB.NotifyExtenders(ffeaAfterRollback, ffeaNoAction); - end - else begin - Result := DB.NotifyExtenders(ffeaBeforeCommit, ffeaCommitFail);{!!.06} - if Result = DBIERR_NONE then begin {!!.06} - seTransactionCommit(DB); {!!.06} - DB.NotifyExtenders(ffeaAfterCommit, ffeaNoAction); {!!.06} - end; {!!.06} - end; - finally - DB.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.TransactionCommitSubset(const aDatabaseID : TffDatabaseID) : TffResult; -var - DB : TffSrDatabase; -begin - try - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result = DBIERR_NONE) then - try - FFSetRetry(DB.Timeout); - Result := seTransactionCommitSubset(DB); - finally - DB.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{Begin !!.01 -{--------} -function TffServerEngine.TransactionCommitSQL(const aDatabaseID : TffDatabaseID; - const notifyExtenders : Boolean) : TffResult; -var - aDB : TffSrDatabase; -begin - aDB := TffSrDatabase(aDatabaseID); - if aDB.Transaction.IsCorrupt then begin - if notifyExtenders then - aDB.NotifyExtenders(ffeaBeforeRollback, ffeaNoAction); - seTransactionRollback(aDB); - Result := DBIERR_FF_CorruptTrans; - if notifyExtenders then - aDB.NotifyExtenders(ffeaAfterRollback, ffeaNoAction); - end - else begin - if notifyExtenders then - aDB.NotifyExtenders(ffeaBeforeCommit, ffeaNoAction); - Result := seTransactionCommit(aDB); - if notifyExtenders then - aDB.NotifyExtenders(ffeaAfterCommit, ffeaNoAction); - end; -end; -{End !!.01} -{--------} -function TffServerEngine.seTransactionCommitSubset(const aDB : TffSrDatabase) : TffResult; -{ Rewritten !!.03} -var - aContainer : TffTransContainer; - aInx : Longint; - aTable : TffSrTable; - aTableList : TffPointerList; - Nested : Boolean; -begin - Result := DBIERR_NONE; - if aDB.Transaction.IsCorrupt then begin - aDB.NotifyExtenders(ffeaBeforeRollback, ffeaNoAction); - seTransactionRollback(aDB); - Result := DBIERR_FF_CorruptTrans; - aDB.NotifyExtenders(ffeaAfterRollback, ffeaNoAction); - end - else begin - aTableList := TffPointerList.Create; - aContainer := TffTransContainer(aDB.Transaction.TransLockContainer); - Nested := aDB.Transaction.Nested; - - try - { Determine which tables were affected by the transaction. We will - commit the changes to their BLOB mgr's in-memory deleted chain. } - if assigned(aContainer) and (not Nested) then - for aInx := 0 to pred(aContainer.ContentCount) do - if aContainer.ContentLockType[aInx] = ffsltExclusive then begin - aTable := TffSrTable(aContainer.ContentTable[aInx]); - aTableList.Append(Pointer(aTable)); - end; - - aDB.NotifyExtenders(ffeaBeforeCommit, ffeaNoAction); - seBufMgr.CommitTransactionSubset(aDB.Transaction); - - { Nested transaction? } - if (not Nested) then begin - { No. Release transaction locks. For each table involved, commit the - changes to the BLOB resource manager's in-memory deleted chain. } - aDB.Folder.LockMgr.ReleaseTransactionLocks(aDB.Transaction, True); - for aInx := 0 to pred(aTableList.Count) do begin - aTable := TffSrTable(aTableList.List[aInx]); - aTable.btCommitBLOBMgr; - end; - end; - - aDB.NotifyExtenders(ffeaAfterCommit, ffeaNoAction); - finally - aTableList.Free; - end; - end; -end; -{--------} -function TffServerEngine.TransactionRollback(const aDatabaseID : TffDatabaseID) : TffResult; -var - DB : TffSrDatabase; -begin - try - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result = DBIERR_NONE) then - try - - if not assigned(DB.Transaction) then begin - Result := DBIERR_NOACTIVETRAN; - exit; - end; - - FFSetRetry(DB.Timeout); - - DB.NotifyExtenders(ffeaBeforeRollback, ffeaNoAction); - seTransactionRollback(DB); - DB.NotifyExtenders(ffeaAfterRollback, ffeaNoAction); - finally - DB.Deactivate; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{Begin !!.01} -{--------} -function TffServerEngine.TransactionRollbackSQL(const aDatabaseID : TffDatabaseID; - const notifyExtenders : Boolean) : TffResult; -var - aDB : TffSrDatabase; -begin - aDB := TffSrDatabase(aDatabaseID); - if notifyExtenders then - aDB.NotifyExtenders(ffeaBeforeRollback, ffeaNoAction); - Result := seTransactionRollback(aDB); - if notifyExtenders then - aDB.NotifyExtenders(ffeaAfterRollback, ffeaNoAction); -end; -{End !!.01} -{--------} -function TffServerEngine.bseGetAutoSaveCfg : Boolean; -begin - Result := seConfig.GeneralInfo^.giNoAutoSaveCfg; -end; -{--------} -function TffServerEngine.bseGetReadOnly : boolean; -begin - Result := seConfig.GeneralInfo^.giReadOnly; -end; -{--------} -procedure TffServerEngine.bseSetAutoSaveCfg(aValue : Boolean); {!!.01 - Start} -begin - seConfig.GeneralInfo^.giNoAutoSaveCfg := aValue; -end; -{--------} -procedure TffServerEngine.bseSetReadOnly(aValue : Boolean); -begin - seConfig.GeneralInfo^.giReadOnly := aValue; -end; -{--------} {!!.01 - End} -function TffServerEngine.TransactionStart(const aDatabaseID : TffDatabaseID; - const aFailSafe : Boolean) : TffResult; -var - DB : TffSrDatabase; - TransID : TffTransID; -begin - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result = DBIERR_NONE) then - try - FFSetRetry(DB.Timeout); - Result := seTransactionStart(DB, aFailSafe, ffcl_TrExplicit, - TransID); - if Result = DBIERR_NONE then - DB.NotifyExtenders(ffeaAfterStartTrans, ffeaNoAction); - finally - DB.Deactivate; - end; -end; -{Begin !!.01} -{--------} -function TffServerEngine.TransactionStartSQL(const aDatabaseID : TffDatabaseID; - const notifyExtenders : boolean) : TffResult; -var - aTransID : TffTransID; -begin - Result := seTransactionStart(TffSrDatabase(aDatabaseID), false, true, aTransID); -{Begin !!.06} - if (Result = DBIERR_NONE) then begin - TffSrDatabase(aDatabaseID).Transaction.IsReadOnly := True; - if notifyExtenders then - TffSrDatabase(aDatabaseID).NotifyExtenders(ffeaAfterStartTrans, ffeaNoAction); - end; -{End !!.06} -end; -{End !!.01} -{Begin !!.10} -{--------} -function TffServerEngine.TransactionStartWith(const aDatabaseID : TffDatabaseID; - const aFailSafe : Boolean; - const aCursorIDs : TffPointerList) : TffResult; -var - RetryUntil : DWORD; - DB : TffSrDatabase; - TransID : TffTransID; - Limit, - anIndex : Longint; - aCursorID : TffCursorID; - Cursor : TffSrBaseCursor; - Lock : TffPadlock; - GetCursorResult : TffResult; {!!.13} -begin - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result = DBIERR_NONE) then - try - FFSetRetry(DB.Timeout); - Result := seTransactionStart(DB, aFailSafe, ffcl_TrExplicit, - TransID); - if Result = DBIERR_NONE then - try - Lock := DB.Folder.LockMgr.StartWithLock; - { Retry this operation until it is successful or we reach the database - timeout limit. } - RetryUntil := FFGetRetry; - repeat - if Result <> DBIERR_NONE then - Sleep(ffc_StartTranWithDelay); - Limit := 0; - Lock.Lock; - try - for anIndex := 0 to pred(aCursorIDs.Count) do begin - aCursorID := TffCursorID(aCursorIDs[anIndex]); - Result := CheckCursorIDAndGet(aCursorID, Cursor); - if Result = DBIERR_NONE then - try - Result := Cursor.AcqExclContentLock; - if Result <> DBIERR_NONE then begin - Limit := pred(anIndex); - Break; - end; - finally - Cursor.Deactivate; - end - else - Break; - end; { for } - if Result <> DBIERR_NONE then - for anIndex := 0 to Limit do begin - aCursorID := TffCursorID(aCursorIDs[anIndex]); - GetCursorResult := CheckCursorIDAndGet(aCursorID, Cursor); {!!.13} - if GetCursorResult = DBIERR_NONE then begin {!!.13} - Cursor.RelContentLock(ffclmWrite); - end; - end; { for } - finally - Lock.Unlock; - end; - - until (Result = DBIERR_NONE) or - (RetryUntil <= (GetTickCount - 10)); - - if Result = DBIERR_NONE then - DB.NotifyExtenders(ffeaAfterStartTrans, ffeaNoAction) - else begin - seTransactionRollback(DB); - if Result = fferrLockRejected then - Result := DBIERR_LOCKED; - end; - - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, - bseGetReadOnly); - seTransactionRollback(DB); - end; - end; - finally - DB.Deactivate; - end; -end; -{End !!.10} -{--------} -function TffServerEngine.seTransactionStart(const aDB : TffSrDatabase; - const aFailSafe, aImplicit : boolean; - var aTransactionID : TffTransID) : TffResult; -var - aTrans : TffSrTransaction; -begin - try - Result := aDB.Folder.TransactionMgr.StartTransaction - (aDB.DatabaseID, aFailSafe, aImplicit, - false, aDB.Folder.Path, aTrans); - aDB.Transaction := aTrans; - aTransactionID := aTrans.TransactionID; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{===Script processing================================================} -function TffServerEngine.CalcPriorityIndex(const PriorityStr : TffShStr) : integer; -const - PriorityValues : array [0..6] of string[12] = ( - 'LOWEST', - 'BELOW NORMAL', - 'NORMAL', - 'ABOVE NORMAL', - 'HIGHEST', - 'BELOWNORMAL', - 'ABOVENORMAL'); -var - Inx : integer; -begin - for Inx := low(PriorityValues) to high(PriorityValues) do - if (PriorityStr = PriorityValues[Inx]) then begin - Result := Inx - 2; - if Result = 3 then - Result := -1 - else if Result = 4 then - Result := 1; - Exit; - end; - Result := 0; -end; -{--------} -function TffServerEngine.CalcKeyIndex(const KeyStr : TffShStr) : integer; -const - KeyValues : array [0..21] of string[13] = ( - 'SERVERNAME', - 'MAXRAM', - 'USESINGLEUSER', - 'USEIPXSPX', - 'USETCPIP', - 'USELOGIN', - 'AUTOUPSERVER', - 'AUTOMINIMIZE', - 'IPXSPXLFB', - 'TCPIPLFB', - 'ALLOWENCRYPT', - 'READONLY', - 'LASTMSGINTVAL', - 'ALIVEINTERVAL', - 'ALIVERETRIES', - 'PRIORITY', - 'DELETESCRIPT', - 'TCPINTERFACE', - 'NOAUTOSAVECFG', - 'TEMPSTORESIZE', - 'COLLECTENABLD', - 'COLLECTFREQ'); -var - Inx : integer; -begin - for Inx := low(KeyValues) to high(KeyValues) do - if (KeyStr = KeyValues[Inx]) then begin - Result := Inx; - Exit; - end; - Result := -1; -end; -{--------} -procedure TffServerEngine.GetServerNames(aList: TStrings; - aTimeout : Longint); -begin - aList.Clear; - aList.Add('Direct'); -end; -{--------} -function TffServerEngine.seDatabaseGetAliasPathPrim - (aAlias : TffName; var aPath :TffPath) : TffResult; -var - aList : TList; - Count : Integer; - AliasDes : PffAliasDescriptor; -begin - { Assumption: Thread-safeness enforced at a higher level. } - - { Retrieve the alias list, and return the path for the matching entry } - aPath := ''; - aList := TList.Create; - try - Result := seDatabaseAliasListPrim(aList); - if Result = DBIERR_NONE then - for Count := 0 to Pred(aList.Count) do begin - AliasDes := PffAliasDescriptor(aList.Items[Count]); - if FFAnsiCompareText(AliasDes^.adAlias, aAlias) = 0 then begin {!!.03, !!.10} - aPath := AliasDes^.adPath; - Break; - end; - end; - finally - aList.Free; - end; -end; -{--------} -function TffServerEngine.DatabaseGetAliasPath(aAlias : TffName; - var aPath : TffPath; - aClientID : TFFClientID) - : TffResult; -var - Client : TffSrClient; -begin - try - Result := CheckClientIDandGet(aClientID, Client); - if Result = DBIERR_NONE then begin - FFSetRetry(Client.Timeout); - try - seConfig.AliasList.BeginRead; - try - Result := Client.NotifyExtenders(ffeaBeforeDBRead, ffeaNoAction); - if Result = DBIERR_NONE then - Result := seDatabaseGetAliasPathPrim(aAlias, aPath); - finally - seConfig.AliasList.EndRead; - end; - finally - Client.Deactivate; - end; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.DatabaseGetFreeSpace(const aDatabaseID : TffDatabaseID; - var aFreeSpace : Longint) - : TffResult; -{!!.11 - Rewritten} -var - DB : TffSrDatabase; -begin - try - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if (Result = DBIERR_NONE) then begin - try - aFreeSpace := FFGetDiskFreeSpace(DB.dbFolder.Path); - finally - DB.Deactivate; - end; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end; -end; -{--------} -function TffServerEngine.DatabaseModifyAlias(const aClientID : TffClientID; - const aAlias : TffName; - const aNewName : TffName; - const aNewPath : TffPath; - aCheckSpace : Boolean) {!!.11} - : TffResult; -var - Client : TffSrClient; - Name : TffName; - Path : TffPath; -begin - try - Result := CheckClientIDandGet(aClientID, Client); - if Result = DBIERR_NONE then begin - FFSetRetry(Client.Timeout); - try - seConfig.AliasList.BeginWrite; - try - Result := Client.NotifyExtenders(ffeaBeforeDBDelete, - ffeaDBDeleteFail); - if Result = DBIERR_NONE then begin - Name := aAlias; - Result := seDatabaseGetAliasPathPrim(aAlias, Path); - if Result = DBIERR_NONE then begin - - { Does the alias have a new name? } - if aNewName <> '' then - Name := aNewName; - - { Does the alias have a new path? } - if aNewPath <> '' then - Path := aNewPath; - - Result := seDatabaseDeleteAliasPrim(aAlias); - - if (Result = DBIERR_NONE) then begin - Result := Client.NotifyExtenders(ffeaBeforeDBInsert, - ffeaDBInsertFail); - if Result = DBIERR_NONE then begin - Result := seDatabaseAddAliasPrim(Name, - Path, - aCheckSpace); {!!.11} - if Result = DBIERR_NONE then - WriteAliasData - else - Client.NotifyExtenders(ffeaDBInsertFail, - ffeaNoAction); - end; - end else - Client.NotifyExtenders(ffeaDBDeleteFail, ffeaNoAction); - end else { if got existing alias path } - Client.NotifyExtenders(ffeaDBDeleteFail, ffeaNoAction); - end; { if no clients complained about rights } - finally - seConfig.AliasList.EndWrite; - end; - finally - Client.Deactivate; - end; - end; - except - on E : Exception do begin - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - end;{try..except} -end; -{--------} -function TffServerEngine.GetServerDateTime(var aDateTime: TDateTime): TffResult; -begin - Result := DBIERR_NONE; - aDateTime := Now; -end; -{--------} {begin !!.10} -function TffServerEngine.GetServerSystemTime(var aSystemTime : TSystemTime) - : TffResult; -begin - Result := DBIERR_NONE; - GetSystemTime(aSystemTime); -end; -{--------} -function TffServerEngine.GetServerGUID(var aGUID : TGUID) : TffResult; -begin - Result := DBIERR_NONE; - CoCreateGuid(aGuid); -end; -{--------} -function TffServerEngine.GetServerID(var aUniqueID : TGUID) : TffResult; -begin - Result := DBIERR_NONE; - aUniqueID := seUniqueID; -end; -{--------} -function TffServerEngine.GetServerStatistics(var aStats : TffServerStatistics) - : TffResult; -begin - aStats.ssName := Configuration.ServerName; - aStats.ssVersion := ffVersionNumber; - aStats.ssState := FFMapStateToString(State); - aStats.ssClientCount := ClientList.ClientCount; - aStats.ssSessionCount := SessionList.SessionCount; - aStats.ssOpenDatabasesCount := DatabaseList.DatabaseCount; - aStats.ssOpenTablesCount := TableList.TableCount; - aStats.ssOpenCursorsCount := CursorList.CursorCount; - aStats.ssRamUsed := BufferManager.RAMUsed; - aStats.ssMaxRam := BufferManager.MaxRAM; - aStats.ssUpTimeSecs := (GetTickCount - seStartTime) div 1000; - aStats.ssCmdHandlerCount := CmdHandlerCount; - Result := DBIERR_NONE; -end; -{--------} -function TffServerEngine.GetCommandHandlerStatistics(const aCmdHandlerIdx : Integer; - var aStats : TffCommandHandlerStatistics) - : TffResult; -begin - if (aCmdHandlerIdx < 0) or - (aCmdHandlerIdx > Pred(CmdHandlerCount)) then - Result := DBIERR_OBJNOTFOUND - else begin - aStats.csTransportCount := CmdHandler[aCmdHandlerIdx].TransportCount; - Result := DBIERR_NONE; - end; -end; -{--------} -function TffServerEngine.GetTransportStatistics(const aCmdHandlerIdx : Integer; - const aTransportIdx : Integer; - var aStats : TffTransportStatistics) - : TffResult; -var - Trans : TffBaseTransport; -begin - if (aCmdHandlerIdx < 0) or - (aCmdHandlerIdx > Pred(CmdHandlerCount)) then - Result := DBIERR_OBJNOTFOUND - else begin - if (aTransportIdx < 0) or - (aTransportIdx > Pred(CmdHandler[aCmdHandlerIdx].TransportCount)) then - Result := DBIERR_OBJNOTFOUND - else begin - Trans := CmdHandler[aCmdHandlerIdx].Transports[aTransportIdx]; - aStats.tsName := Trans.GetName; - aStats.tsState := FFMapStateToString(Trans.State); - aStats.tsAddress := Trans.ServerName; - aStats.tsClientCount := Trans.ConnectionCount; - aStats.tsMessageCount := Trans.MsgCount; - aStats.tsMessagesPerSec := Trans.MsgCount / ((GetTickCount - seStartTime) div 1000); - Result := DBIERR_NONE; - end; - end; -end; -{--------} {end !!.10} -function TffServerEngine.ValBoolean(const BoolStr : TffShStr; - var BoolValue : boolean) : boolean; -var - UpperBoolStr : TffShStr; -begin - {only values allowed are 0, 1, YES, NO, TRUE, FALSE} - UpperBoolStr := FFShStrUpper(BoolStr); - Result := true; - BoolValue := false; - if (UpperBoolStr = '0') or - (UpperBoolStr = 'NO') or - (UpperBoolStr = 'FALSE') then - Exit; - BoolValue := true; - if (UpperBoolStr = '1') or - (UpperBoolStr = 'YES') or - (UpperBoolStr = 'TRUE') then - Exit; - Result := false; -end; -{--------} -procedure TffServerEngine.ProcessScriptCommand(const KeyStr, - ValueStr : TffShStr; - var DeleteScript : Boolean); -var - KeyInx : Integer; - WorkInt : Longint; - ec : Integer; - WorkBool : Boolean; - UpperStr : TffShStr; -begin - DeleteScript := False; - {uppercase the key} - UpperStr := FFShStrUpper(KeyStr); - {is it one of the strings we allow?} - KeyInx := CalcKeyIndex(UpperStr); - {if it is, process the command} - if (KeyInx >= 0) then begin - case KeyInx of - 0 : {server name} - begin - Configuration.GeneralInfo^.giServerName := ValueStr; - end; - 1 : {Max RAM} - begin - Val(ValueStr, WorkInt, ec); - if (ec = 0) and (WorkInt >= 1) then - Configuration.GeneralInfo^.giMaxRAM := WorkInt; - end; - 2 : {Use Single User Protocol} - begin {!!.01 - Start} - if ValBoolean(ValueStr, WorkBool) then - Configuration.GeneralInfo^.giSingleUser := WorkBool; - end; {!!.01 - End} - 3 : {Use IPX/SPX Protocol} - begin {!!.01 - Start} - if ValBoolean(ValueStr, WorkBool) then - Configuration.GeneralInfo^.giIPXSPX := WorkBool; - end; {!!.01 - End} - 4 : {Use TCP/IP Protocol} - begin {!!.01 - Start} - if ValBoolean(ValueStr, WorkBool) then - Configuration.GeneralInfo^.giTCPIP := WorkBool; - end; {!!.01 - End} - 5 : {Login security?} - begin - if ValBoolean(ValueStr, WorkBool) then - Configuration.GeneralInfo^.giIsSecure := WorkBool; - end; - 6 : {Auto Up?} - begin - if ValBoolean(ValueStr, WorkBool) then - Configuration.GeneralInfo^.giAutoUp := WorkBool; - end; - 7 : {Auto Minimize?} - begin - if ValBoolean(ValueStr, WorkBool) then - Configuration.GeneralInfo^.giAutoMini := WorkBool; - end; - 8 : {Enable IPX/SPX use broadcasts?} - begin - if ValBoolean(ValueStr, WorkBool) then - Configuration.GeneralInfo^.giIPXSPXLFB := WorkBool; - end; - 9 : {Enable TCP/IP use broadcasts?} - begin - if ValBoolean(ValueStr, WorkBool) then - Configuration.GeneralInfo^.giTCPIPLFB := WorkBool; - end; - - 10 : {Allow encrypted tables to be created?} - begin - {$IFDEF SecureServer} - if ValBoolean(ValueStr, WorkBool) then - Configuration.GeneralInfo^.giAllowEncrypt := WorkBool; - {$ENDIF} - end; - 11 : {ReadOnly?} - begin - if ValBoolean(ValueStr, WorkBool) then begin - Configuration.GeneralInfo^.giReadOnly := WorkBool; - seSetLoggingState; - end; - end; - 12 : {Last message interval} - begin - Val(ValueStr, WorkInt, ec); - if (ec = 0) and (WorkInt >= 1000) and (WorkInt <= 86400000) then - Configuration.GeneralInfo^.giLastMsgInterval := WorkInt; - end; - 13 : {keep alive interval} - begin - Val(ValueStr, WorkInt, ec); - if (ec = 0) and (WorkInt >= 1000) and (WorkInt <= 86400000) then - Configuration.GeneralInfo^.giKAInterval := WorkInt; - end; - 14 : {keep alive retries} - begin - Val(ValueStr, WorkInt, ec); - if (ec = 0) and (WorkInt >= 1) and (WorkInt <= 100) then - Configuration.GeneralInfo^.giKARetries := WorkInt; - end; - 15 : {Priority} - begin - UpperStr := FFShStrUpper(ValueStr); - Configuration.GeneralInfo^.giPriority := - CalcPriorityIndex(UpperStr); - end; - 16 : {Delete script} - begin {!!.01 - Start} - if ValBoolean(ValueStr, WorkBool) then - DeleteScript := WorkBool; - end; {!!.01 - End} - 17 : {TCP/IP Interface} - begin - Val(ValueStr, WorkInt, ec); - Configuration.GeneralInfo^.giTCPInterface := WorkInt; - end; - 18 : {NoAutoSaveCfg} - begin - if ValBoolean(ValueStr, WorkBool) then - Configuration.GeneralInfo^.giNoAutoSaveCfg := WorkBool; - end; - 19 : {giTempStoreSize} - begin - Val(ValueStr, WorkInt, ec); - {Temp storage must be between 1 meg and 2 gigs.} - if (ec = 0) and (WorkInt > 0) and (WorkInt < 2049) then - Configuration.GeneralInfo^.giTempStoreSize := WorkInt; - end; - 20 : {giCollectEnabled} - begin - if ValBoolean(ValueStr, WorkBool) then - Configuration.GeneralInfo^.giCollectEnabled := WorkBool; - end; - 21 : {giCollectFreq} - begin - Val(ValueStr, WorkInt, ec); - {Garbage collection frequency should be between 30 seconds - and 60 minutes.} - if (ec = 0) and (WorkInt > 30000) and (WorkInt < 3600000) then - Configuration.GeneralInfo^.giCollectFreq := WorkInt; - end; - end;{case} - end - {if it isn't it must be an alias definition} - else begin - if FFDirectoryExists(ValueStr) then - { Assumption: This routine happens on sever startup therefore we - do not need to ensure thread-safeness. } - seDatabaseAddAliasPrim(KeyStr, ValueStr, False); {!!.11} - end; -end; -{--------} -procedure TffServerEngine.ProcessAliasScript; -var - CurPath : TffPath; - ScriptFile : TffFullFileName; - ScriptItems : TStrings; - Alias : TffName; - Path : TffPath; - i, iPos, iLen : Integer; - DeleteScript : Boolean; -begin - { Get the application's directory. } - CurPath := FFExtractPath(FFGetExeName); - { Create the script filename. } - ScriptFile := FFMakeFullFileName(CurPath, ffc_AliasScript); - - { Does the alias script file (FFAlias.sc$) exist in the directory? } - if FFFileExists( ScriptFile ) then begin - { Yes. Process it. } - ScriptItems := TStringList.Create; - try - ScriptItems.LoadFromFile( ScriptFile ); - { For each item in the file, try to parse it. } - for i := 0 to pred( ScriptItems.Count ) do begin - { Only process lines with some length. } - iLen := Length( ScriptItems[i] ); - if iLen > 2 then begin - { Find the semicolon. } - iPos := Pos( ';', ScriptItems[i] ); - { Only process lines with length before and after the semicolon. } - if ( iPos > 1 ) and ( iPos < iLen )then begin - { Get the alias. } - Alias := Copy( ScriptItems[i], 1, pred( iPos ) ); - { Get the path. } - Path := Copy( ScriptItems[i], succ( iPos ), iLen - iPos ); - { Add the alias. } - ProcessScriptCommand(Alias, Path, DeleteScript); - end; - end; - end; - finally - ScriptItems.Free; - end; - end; -end; -{--------} -procedure TffServerEngine.ProcessFullScript(const ScriptFileName : TffFullFileName); -var - AfterStr : TffShStr; - AppliesToSelf : Boolean; - { If True then script command applies to this server. Becomes True when - encounters a section header bearing the same server name. Becomes False - when encounters a section header bearing a different server name. } - DeleteScript : Boolean; - Inx : Integer; - Len : Integer; - Line : TffShStr; - PosEquals : Integer; - ScriptItems : TStrings; - UServerName : TffShStr; -begin - AppliesToSelf := True; - { Default to True since the script may contain leading items that apply - to all server engines. } - DeleteScript := False; - UServerName := Uppercase(Self.Name); - { Does the script file exist? } - if FFFileExists(ScriptFileName) then begin - { Yes. Process it. } - ScriptItems := TStringList.Create; - try - ScriptItems.LoadFromFile(ScriptFileName); - { For each item in the file, try to parse it. } - for Inx := 0 to pred(ScriptItems.Count) do begin - { Only process lines with some length. } - Line := Trim(ScriptItems[Inx]); - Len := length(Line); - if (Len > 2) then begin - { Is this a section header? } - if (Pos('[', Line) = 1) and - (Pos(']', Line) = Len) then begin - { Yes. Does the section apply to us? } - AppliesToSelf := (UpperCase(Copy(Line, 2, Len - 2)) = UServerName); - end - else - { Not a section header. Does this item apply to this server - engine? } - if AppliesToSelf then begin - { Yes. Find the equals sign. } - PosEquals := Pos('=', Line); - { Only process lines with length before and after the = char. } - if (PosEquals > 1) and (PosEquals < Len) then begin - { Get the before and after strings. } - AfterStr := Copy(Line, succ(PosEquals), Len - PosEquals); - SetLength(Line, pred(PosEquals)); - { Process the script command. } - ProcessScriptCommand(Line, AfterStr, DeleteScript); - if (DeleteScript) then - DeleteFile(ScriptFileName); - end; - end; { if AppliesToSelf } - end; - end; - finally - ScriptItems.Free; - end; - end; -end; -{--------} -procedure TffServerEngine.ReadAliasData; -var - aClientID : TffClientID; - Alias : TffName; - Client : TffSrClient; - Cursor : TffSrBaseCursor; {!!.06} - DB : TffSrDatabase; - DBIResult : TffResult; - Dict : TffDataDictionary; - Folder : TffSrFolder; - Hash : TffWord32; - IsNull : Boolean; - MyRec : PffByteArray; - Path : TffPath; - SearchPath : TffPath; - CheckDisk : Boolean; {!!.11} -begin - Folder := nil; - DB := nil; - Client := nil; - Cursor := nil; - try - {create ourselves a client} - DBIResult := ClientAdd(aClientID, '', ffc_AdminUserID, 1000, Hash); - if (DBIResult <> DBIERR_NONE) then - Exit; - - {open a database to the server engine directory} - Client := TffSrClient(aClientID); - Folder := TffSrFolder.Create(ConfigDir, True, seBufMgr); - DB := seDatabaseOpenPrim(Client.clSessionList.CurrentSession, - Folder, - '', - omReadWrite, - smExclusive, - 1000, - False); {!!.11} - if (DBIResult = DBIERR_NONE) then - FFSetRetry(DB.Timeout) - else - Exit; - - { Read the records. } - Configuration.AliasList.BeginWrite; - try - Configuration.AliasList.Empty; - finally - Configuration.AliasList.EndWrite; - end; - - { If the table exists then read it. } - SearchPath := Folder.Path; - if (SearchPath[length(SearchPath)] <> '\') then - FFShStrAddChar(SearchPath, '\'); - if (FFFileExists(SearchPath + - FFForceExtension(ffc_AliasTableName, - ffc_ExtForData))) then begin - Cursor := CursorClass.Create(Self, DB, 1000); {!!.06} - FFSetRetry(Cursor.Timeout); {!!.01} - Cursor.Open(ffc_AliasTableName, - '', - 0, - omReadOnly, - smExclusive, - True, - False, []); - Cursor.CloseTable := True; - Dict := Cursor.Dictionary; - FFGetMem(MyRec, Dict.RecordLength); - try - FFSetRetry(Cursor.Timeout); - Cursor.SetToBegin; - FFSetRetry(Cursor.Timeout); {!!.01} - DBIResult := Cursor.GetNextRecord(MyRec, ffsltNone); - while (DBIResult = DBIERR_NONE) do begin - Dict.GetRecordField(0, MyRec, IsNull, @Alias); - Dict.GetRecordField(1, MyRec, IsNull, @Path); - if (Dict.FieldCount > 2) then {!!.11} - Dict.GetRecordField(2, MyRec, IsNull, @CheckDisk) {!!.11} - else {!!.11} - CheckDisk := False; {!!.11} - { Assumption: This is one of the first things happening when the - server starts so no thread-safeness need be enforced. } - Configuration.AddAlias(Alias, Path, CheckDisk); {!!.11} - FFSetRetry(Cursor.Timeout); {!!.01} - DBIResult := Cursor.GetNextRecord(MyRec, ffsltNone); - end; - finally - FFFreeMem(MyRec, Dict.RecordLength); - end;{try..finally} - end; - finally - - { Close the cursor. } - if assigned(Cursor) then - Cursor.Free; - - DB.Free; - Folder.Free; - - { Remove the client. } - seClientRemovePrim(Client); - - end; -end; -{--------} -function TffServerEngine.WriteAliasData : TffResult; -label - Cleanup, - InnerCleanup; -var - aClientID : TffClientID; - AliasItem : TffAliasItem; - Buffer : TffShStr; - Dict : TffDataDictionary; - Folder : TffSrFolder; - Hash : TffWord32; - i : integer; - MyRec : PffByteArray; - State : integer; - TransID : TffTransID; - Client : TffSrClient; - DB : TffSrDatabase; - Cursor : TffSrBaseCursor; {!!.06} -begin - Result := DBIERR_NONE; - with Configuration.GeneralInfo^ do - if giReadOnly or giNoAutoSaveCfg then - Exit; - - State := 0; - DB := nil; - Client := nil; - Dict := nil; - Folder := nil; - Cursor := nil; - try - - { Strategy: Create a temporary table and write the data to that - table. If that works, rename the existing table and replace it with - the temporary table. If that succeeds, get rid of the old table. - If a failure occurs at any point, the old table must be put back - in its original place. } - - {create ourselves a client} - Result := ClientAdd(aClientID, '', ffc_AdminUserID, 1000, Hash); - if (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 100; { client added } - - {open a database (no alias) to the server engine directory} - Client := TffSrClient(aClientID); - Folder := TffSrFolder.Create(ConfigDir, False, seBufMgr); - DB := seDatabaseOpenPrim(Client.clSessionList.CurrentSession, - Folder, - '', - omReadWrite, - smExclusive, - 1000, - False); {!!.11} - if (Result = DBIERR_NONE) then - FFSetRetry(DB.Timeout) - else - goto Cleanup; - - State := 200; { database opened } - - {Make sure prior instances of the saved and temporary tables are deleted. } - seTableDeletePrim(DB, ffc_SavedAliasTableName); - seTableDeletePrim(DB, ffc_TempAliasTableName); - - {Prepare a data dictionary.} - Dict := TffServerDataDict.Create(4096); - - State := 300; { dictionary created } - - {Create the new alias table as a temporary file. } - with Dict do begin - AddField('Alias', '', fftShortString, pred(sizeof(TffName)), 0, True, nil); - AddField('Path', '', fftShortString, pred(sizeof(TffPath)), 0, True, nil); - AddField('CheckDisk', '', fftBoolean, SizeOf(Boolean), 0, True, nil); {!!.11} - end; - Dict.IsEncrypted := Configuration.GeneralInfo^.giAllowEncrypt; - - Result := seTableBuildPrim(DB, - True, - ffc_TempAliasTableName, - True, - Dict); - if (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 400; { temporary table created } - - {start a transaction before opening the alias table} - Result := seTransactionStart(DB, False, ffcl_TrImplicit, TransID); - if (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 500; { transaction started for opening alias table } - - Configuration.AliasList.BeginRead; - - try - FFGetMem(MyRec, Dict.RecordLength); - - State := 600; - - Cursor := CursorClass.Create(Self, DB, 1000); {!!.06} - FFSetRetry(Cursor.Timeout); {!!.01} - Cursor.Open(ffc_TempAliasTableName, - '', - 0, - omReadWrite, - smExclusive, - True, - False, - []); - Cursor.CloseTable := True; - - {Insert new records.} - for i := 0 to pred(Configuration.AliasList.Count) do begin - Cursor.Dictionary.InitRecord(MyRec); - AliasItem := Configuration.AliasList[i]; - Buffer := AliasItem.Alias; - Cursor.Dictionary.SetRecordField(0, MyRec, @Buffer); - Buffer := AliasItem.Path; - Cursor.Dictionary.SetRecordField(1, MyRec, @Buffer); - Cursor.Dictionary.SetRecordField(2, MyRec, @AliasItem.CheckSpace); {!!.11} - FFSetRetry(Cursor.Timeout); {!!.01} - Result := Cursor.InsertRecord(MyRec, ffsltExclusive); - if (Result <> DBIERR_NONE) then - goto InnerCleanup; - end; - - State := 750; - - { Commit the transaction. } - FFSetRetry(Cursor.Timeout); {!!.01} - Result := seTransactionCommit(DB); - if Result = DBIERR_NONE then - State := 800; { transaction committed } - - InnerCleanup: - - finally - Configuration.AliasList.EndRead; - - { Rollback the transaction. } - if (State >= 500) and (State < 750) then - seTransactionRollback(DB); - - if State >= 600 then - FFFreeMem(MyRec, Dict.RecordLength); - - {close the cursor} - if assigned(Cursor) then - Cursor.Free; - - end;{try..finally} - - { If the record insertions did not complete then jump to cleanup. } - if State < 800 then - goto Cleanup; - - { Rename the existing table. } - Result := seTableRenamePrim(DB, ffc_AliasTableName, ffc_SavedAliasTableName); - if (Result <> DBIERR_NOSUCHTABLE) and (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 1000; { renamed system table to saved table } - - { Replace the original table with the temporary table. } - Result := seTableRenamePrim(DB, ffc_TempAliasTableName, ffc_AliasTableName); - if Result <> DBIERR_NONE then - goto Cleanup; - - State := 1100; { renamed temp table to system table } - - { The new alias table is now in place. Get rid of the saved, original - table. Ignore errors. } - if not IsTableNameOpen(DB.Folder, ffC_SavedAliasTableName) then - seDeleteTable(DB, ffC_SavedAliasTableName) - else - Result := DBIERR_TABLEOPEN; - - { The code jumps to this point if an error is detected in a ServerEngine - method. } - Cleanup: - - except - {If an exception occurs, get the error code and fall through to the - cleanup code below. The error code will be returned to the calling - object. } - on E : Exception do - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - - { Put System table back into its rightful place if a failure occurred - after it was renamed to the saved table. } - if (State >= 1000) and (State < 1100) then - seTableRenamePrim(DB, ffc_SavedAliasTableName, ffc_AliasTableName); - - {delete temporary table if it did not replace system table} - if (State >= 400) and (State < 1100) then - if not IsTableNameOpen(DB.Folder, ffc_TempAliasTableName) then - seDeleteTable(DB, ffc_TempAliasTableName) - else - Result := DBIERR_TABLEOPEN; - - Dict.Free; - DB.Free; - Folder.Free; - - {remove the client} - if State >= 100 then - seClientRemovePrim(Client); - -end; -{=====================================================================} - - -{== Read/Write User data from table ==================================} -procedure TffServerEngine.ReadUserData; -var - aClientID : TffClientID; - BufFirst : TffName; - BufHash : TffWord32; - BufLast : TffName; - BufRights : TffUserRights; - BufUserID : TffName; - Client : TffSrClient; - Cursor : TffSrBaseCursor; {!!.06} - DBIResult : TffResult; - DB : TffSrDatabase; - Dict : TffDataDictionary; - Folder : TffSrFolder; - IsNull : boolean; - MyRec : PffByteArray; - SearchPath : TffPath; -begin - Client := nil; - Folder := nil; - DB := nil; - Cursor := nil; - try - {create ourselves a client} - DBIResult := ClientAdd(aClientID, - '', - ffc_AdminUserID, - 1000, - BufHash); - if (DBIResult <> DBIERR_NONE) then - Exit; - - {open a database (no User) to the server engine directory} - Client := TffSrClient(aClientID); - Folder := TffSrFolder.Create(ConfigDir, True, seBufMgr); - DB := seDatabaseOpenPrim(Client.clSessionList.CurrentSession, - Folder, - '', - omReadWrite, - smExclusive, - 1000, - False); {!!.11} - if (DBIResult = DBIERR_NONE) then - FFSetRetry(DB.Timeout) - else - Exit; - - Configuration.UserList.Empty; - - { If the table exists then read it. } - SearchPath := Folder.Path; - if (SearchPath[length(SearchPath)] <> '\') then - FFShStrAddChar(SearchPath, '\'); - if FFFileExists(SearchPath + FFForceExtension(ffc_UserTableName, ffc_ExtForData)) then begin - Cursor := CursorClass.Create(Self, DB, 1000); {!!.06} - FFSetRetry(Cursor.Timeout); {!!.01} - Cursor.Open(ffc_UserTableName, '', 0, omReadOnly, smExclusive, - true, False, []); - Cursor.CloseTable := True; - Dict := Cursor.Dictionary; - FFGetMem(MyRec, Dict.RecordLength); - try - FFSetRetry(Cursor.Timeout); - Cursor.SetToBegin; - FFSetRetry(Cursor.Timeout); {!!.01} - DBIResult := Cursor.GetNextRecord(MyRec, ffsltNone); - while (DBIResult = DBIERR_NONE) do begin - Dict.GetRecordField(0, MyRec, IsNull, @BufUserID); - Dict.GetRecordField(1, MyRec, IsNull, @BufLast); - Dict.GetRecordField(2, MyRec, IsNull, @BufFirst); - Dict.GetRecordField(3, MyRec, IsNull, @BufHash); - Dict.GetRecordField(4, MyRec, IsNull, @BufRights); - Configuration.AddUser(BufUserID, BufLast, BufFirst, BufHash, BufRights); - FFSetRetry(Cursor.Timeout); {!!.01} - DBIResult := Cursor.GetNextRecord(MyRec, ffsltNone); - end; - finally - FFFreeMem(MyRec, Dict.RecordLength); - end;{try..finally} - end; - finally - - { Close the cursor. } - if assigned(Cursor) then - Cursor.Free; - - DB.Free; - Folder.Free; - - { Remove the client. } - seClientRemovePrim(Client); - - end; -end; -{--------} -function TffServerEngine.WriteUserData : TffResult; -label - Cleanup, - InnerCleanup; -var - aClientID : TffClientID; - BufHash : TffWord32; - BufRights : TffUserRights; - BufStr : TffShStr; - Dict : TffDataDictionary; - Folder : TffSrFolder; - Hash : TffWord32; - i : integer; - MyRec : PffByteArray; - State : integer; - TransID : TffTransID; - UserItem : TffUserItem; - Client : TffSrClient; - DB : TffSrDatabase; - Cursor : TffSrBaseCursor; {!!.06} -begin - Result := DBIERR_NONE; - with Configuration.GeneralInfo^ do - if giReadOnly or giNoAutoSaveCfg then - Exit; - - Client := nil; - DB := nil; - Dict := nil; - Folder := nil; - Cursor := nil; - State := 0; - - try - { Strategy: Create a temporary table and write the data to that - table. If that works, rename the existing table and replace it with - the temporary table. If that succeeds, get rid of the old table. - If a failure occurs at any point, the old table must be put back - in its original place. } - - {create ourselves a client} - Result := ClientAdd(aClientID, '', ffc_AdminUserID, 1000, Hash); - if (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 100; { client added } - - {open a database (no alias) to the server engine directory} - Client := TffSrClient(aClientID); - Folder := TffSrFolder.Create(ConfigDir, False, seBufMgr); - DB := seDatabaseOpenPrim(Client.clSessionList.CurrentSession, - Folder, - '', - omReadWrite, - smExclusive, - 1000, - False); {!!.11} - if (Result = DBIERR_NONE) then - FFSetRetry(DB.Timeout) - else - goto Cleanup; - - State := 200; { database opened } - - {Make sure prior instances of the saved and temporary tables are deleted. } - seTableDeletePrim(DB, ffc_SavedUserTableName); - seTableDeletePrim(DB, ffc_TempUserTableName); - - {create a dictionary} - Dict := TffServerDataDict.Create(4096); - - State := 300; { dictionary created } - - with Dict do begin - AddField('User', '', fftShortString, pred(sizeof(TffName)), 0, true, nil); - AddField('LastName', '', fftShortString, pred(sizeof(TffName)), 0, true, nil); - AddField('FirstName', '', fftShortString, pred(sizeof(TffName)), 0, true, nil); - AddField('PwdHash', '', fftWord32, 0, 0, true, nil); - AddField('Rights', '', fftByteArray, sizeof(TffUserRights), 0, true, nil); - end; - Dict.IsEncrypted := Configuration.GeneralInfo^.giAllowEncrypt; - - {Create the new table as a temporary file. } - Result := seTableBuildPrim(DB, true, ffc_TempUserTableName, True, Dict); - if (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 400; { temporary table created } - - {start a transaction before opening the table} - Result := seTransactionStart(DB, false, ffcl_TrImplicit, TransID); - if (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 500; { transaction started for opening table } - - try - FFGetMem(MyRec, Dict.RecordLength); - - State := 600; - - {Insert new records.} - Cursor := CursorClass.Create(Self, DB, 1000); {!!.06} - FFSetRetry(Cursor.Timeout); {!!.01} - Cursor.Open(ffc_TempUserTableName, '', 0, omReadWrite, smExclusive, - True, False, []); - Cursor.CloseTable := True; - for i := 0 to pred(Configuration.UserList.Count) do begin - Cursor.Dictionary.InitRecord(MyRec); - UserItem := Configuration.UserList[i]; - BufStr := UserItem.UserID; - Cursor.Dictionary.SetRecordField(0, MyRec, @BufStr); - BufStr := UserItem.LastName; - Cursor.Dictionary.SetRecordField(1, MyRec, @BufStr); - BufStr := UserItem.FirstName; - Cursor.Dictionary.SetRecordField(2, MyRec, @BufStr); - BufHash := UserItem.PasswordHash; - Cursor.Dictionary.SetRecordField(3, MyRec, @BufHash); - BufRights := UserItem.Rights; - Cursor.Dictionary.SetRecordField(4, MyRec, @BufRights); - FFSetRetry(Cursor.Timeout); {!!.01} - Cursor.InsertRecord(MyRec, ffsltExclusive); - if (Result <> DBIERR_NONE) then - goto InnerCleanup; - end; - - State := 750; - - { Commit the transaction. } - FFSetRetry(Cursor.Timeout); {!!.01} - Result := seTransactionCommit(DB); - if Result = DBIERR_NONE then - State := 800; { transaction committed } - - InnerCleanup: - - finally - { Rollback the transaction. } - if (State >= 500) and (State < 750) then - seTransactionRollback(DB); - - if State >= 600 then - FFFreeMem(MyRec, Dict.RecordLength); - - {close the cursor} - if assigned(Cursor) then - Cursor.Free; - - end;{try..finally} - - { If the record insertions did not complete then jump to cleanup. } - if State < 800 then - goto Cleanup; - - { Rename the existing table. } - Result := seTableRenamePrim(DB, ffc_UserTableName, ffc_SavedUserTableName); - if (Result <> DBIERR_NOSUCHTABLE) and (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 1000; { renamed system table to saved table } - - { Replace the original table with the temporary table. } - Result := seTableRenamePrim(DB, ffc_TempUserTableName, ffc_UserTableName); - if Result <> DBIERR_NONE then - goto Cleanup; - - State := 1100; { renamed temp table to system table } - - { The new table is now in place. Get rid of the saved, original - table. Ignore errors. } - if not IsTableNameOpen(DB.Folder, ffc_SavedUserTableName) then - seDeleteTable(DB, ffc_SavedUserTableName) - else - Result := DBIERR_TABLEOPEN; - - { The code jumps to this point if an error is detected in a ServerEngine - method. } - Cleanup: - - except - {If an exception occurs, get the error code and fall through to the - cleanup code below. The error code will be returned to the calling - object. } - on E : Exception do - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - - { Put System table back into its rightful place if a failure occurred - after it was renamed to the saved table. } - if (State >= 1000) and (State < 1100) then - seTableRenamePrim(DB, ffc_SavedUserTableName, ffc_UserTableName); - - {delete temporary table if it did not replace system table} - if (State >= 400) and (State < 1100) then - if not IsTableNameOpen(DB.Folder, ffc_TempUserTableName) then - seDeleteTable(DB, ffc_TempUserTableName) - else - Result := DBIERR_TABLEOPEN; - - Dict.Free; - DB.Free; - Folder.Free; - - {remove the client} - if State >= 100 then - seClientRemovePrim(Client); - -end; -{=====================================================================} - - -{== Read/write general info from tables ==============================} -const - ffc_GeneralClientID = -1; -{--------} -procedure TffServerEngine.ReadGeneralInfo; -var - aClientID : TffClientID; - Client : TffSrClient; - Cursor : TffSrBaseCursor; {!!.06} - DB : TffSrDatabase; - DBIResult : TffResult; - Dict : TffDataDictionary; - Folder : TffSrFolder; - Hash : TffWord32; - IsNull : boolean; - MyRec : PffByteArray; - SearchPath : TffPath; -begin - Client := nil; - DB := nil; - Folder := nil; - Cursor := nil; - try - {create ourselves a client} - DBIResult := ClientAdd(aClientID, '', ffc_AdminUserID, 1000, Hash); - if (DBIResult <> DBIERR_NONE) then - Exit; - - {open a database (no User) to the server engine directory} - Client := TffSrClient(aClientID); - Folder := TffSrFolder.Create(ConfigDir, True, seBufMgr); - DB := seDatabaseOpenPrim(Client.clSessionList.CurrentSession, - Folder, - '', - omReadWrite, - smExclusive, - 1000, - False); {!!.11} - if (DBIResult = DBIERR_NONE) then - FFSetRetry(DB.Timeout) - else - Exit; - - { If the table exists then read it. } - SearchPath := Folder.Path; - if (SearchPath[length(SearchPath)] <> '\') then - FFShStrAddChar(SearchPath, '\'); - if FFFileExists(SearchPath + FFForceExtension(ffc_GenInfoTableName, ffc_ExtForData)) then begin - { Open a cursor to read the records. } - Cursor := CursorClass.Create(Self, DB, 1000); {!!.06} - FFSetRetry(Cursor.Timeout); {!!.01} - Cursor.Open(ffc_GenInfoTableName, '', 0, omReadOnly, smExclusive, - true, False, []); - Cursor.CloseTable := True; - Dict := Cursor.Dictionary; - FFGetMem(MyRec, Dict.RecordLength); - try - FFSetRetry(Cursor.Timeout); - Cursor.SetToBegin; - FFSetRetry(Cursor.Timeout); - DBIResult := Cursor.GetNextRecord(MyRec, ffsltNone); - if DBIResult = DBIERR_NONE then - with Configuration.GeneralInfo^ do begin - Dict.GetRecordField(0, MyRec, IsNull, @giServerName); - Dict.GetRecordField(1, MyRec, IsNull, @giMaxRAM); - Dict.GetRecordField(2, MyRec, IsNull, @giIsSecure); - Dict.GetRecordField(3, MyRec, IsNull, @giAutoUp); - Dict.GetRecordField(4, MyRec, IsNull, @giAutoMini); - Dict.GetRecordField(5, MyRec, IsNull, @giDebugLog); - Dict.GetRecordField(6, MyRec, IsNull, @giSingleUser); - Dict.GetRecordField(7, MyRec, IsNull, @giIPXSPX); - Dict.GetRecordField(8, MyRec, IsNull, @giIPXSPXLFB); - Dict.GetRecordField(9, MyRec, IsNull, @giTCPIP); - Dict.GetRecordField(10, MyRec, IsNull, @giTCPIPLFB); - Dict.GetRecordField(11, MyRec, IsNull, @giTCPPort); - Dict.GetRecordField(12, MyRec, IsNull, @giUDPPortSr); - Dict.GetRecordField(13, MyRec, IsNull, @giUDPPortCl); - Dict.GetRecordField(14, MyRec, IsNull, @giIPXSocketSr); - Dict.GetRecordField(15, MyRec, IsNull, @giIPXSocketCl); - Dict.GetRecordField(16, MyRec, IsNull, @giSPXSocket); - Dict.GetRecordField(17, MyRec, IsNull, @giAllowEncrypt); - Dict.GetRecordField(18, MyRec, IsNull, @giReadOnly); - Dict.GetRecordField(19, MyRec, IsNull, @giLastMsgInterval); - Dict.GetRecordField(20, MyRec, IsNull, @giKAInterval); - Dict.GetRecordField(21, MyRec, IsNull, @giKARetries); - Dict.GetRecordField(22, MyRec, IsNull, @giPriority); - Dict.GetRecordField(23, MyRec, IsNull, @giTCPInterface); - Dict.GetRecordField(24, MyRec, IsNull, @giNoAutoSaveCfg); - Dict.GetRecordField(25, MyRec, IsNull, @giTempStoreSize); - Dict.GetRecordField(26, MyRec, IsNull, @giCollectEnabled); - Dict.GetRecordField(27, MyRec, IsNull, @giCollectFreq); - end; { with } - finally - FFFreeMem(MyRec, Dict.RecordLength); - end;{try..finally} - end; - finally - - { Close the cursor. } - if assigned(Cursor) then - Cursor.Free; - - DB.Free; - Folder.Free; - - { Remove the client. } - seClientRemovePrim(Client); - - { Update the logging state. } - seSetLoggingState; - - end; -end; -{--------} -function TffServerEngine.WriteGeneralInfo(aOverrideRO : Boolean) - : TffResult; -label - Cleanup, - InnerCleanup; -var - aClientID : TffClientID; - MyRec : PffByteArray; - Folder : TffSrFolder; - Hash : TffWord32; - TransID : TffTransID; - Dict : TffServerDataDict; - Client : TffSrClient; - DB : TffSrDatabase; - Cursor : TffSrBaseCursor; {!!.06} - State : integer; -begin - Result := DBIERR_NONE; - - {aOverrideRO is used to override the giReadOnly setting. If we didn't - have this option, there would be no way of saving the change when - setting giReadOnly from False to True} - with Configuration.GeneralInfo^ do - if ((giReadOnly or giNoAutoSaveCfg) and - (not aOverrideRO)) then - Exit; - - State := 0; - Client := nil; - DB := nil; - Cursor := nil; - Dict := nil; - Folder := nil; - - try - - { Strategy: Create a temporary table and write the data to that - table. If that works, rename the existing table and replace it with - the temporary table. If that succeeds, get rid of the old table. - If a failure occurs at any point, the old table must be put back - in its original place. } - - {create ourselves a client} - Result := ClientAdd(aClientID, '', ffc_AdminUserID, 1000, Hash); - if (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 100; {client added} - - {open a database (no alias) to the server engine directory} - Client := TffSrClient(aClientID); - Folder := TffSrFolder.Create(ConfigDir, False, seBufMgr); - DB := seDatabaseOpenPrim(Client.clSessionList.CurrentSession, - Folder, - '', - omReadWrite, - smExclusive, - 1000, - False); {!!.11} - if (Result = DBIERR_NONE) then - FFSetRetry(DB.Timeout) - else - goto Cleanup; - - State := 200; {database opened} - - {Make sure prior instances of the saved and temporary tables are deleted. } - seTableDeletePrim(DB, ffc_SavedGenInfoTableName); - seTableDeletePrim(DB, ffc_TempGenInfoTableName); - - {build a new data dictionary (don't bother with an index)} - Dict := TffServerDataDict.Create(4096); - - State := 300; {dict created} - - with Dict do begin - AddField('ServerName', '', fftShortString, pred(sizeof(TffNetName)), 0, true, nil); - AddField('MaxRAM', '', 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', '', fftInt16, 0, 0, True, nil); - AddField('CollectEnabld', '', fftBoolean, 0, 0, True, nil); - AddField('CollectFreq', '', fftInt32, 0, 0, True, nil); - end; - Dict.IsEncrypted := Configuration.GeneralInfo^.giAllowEncrypt; - - {build a new alias table} - Result := seTableBuildPrim(DB, True, ffc_TempGenInfoTableName, True, - Dict); - if (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 400; {temporary table created} - - {start a transaction before opening the table} - Result := seTransactionStart(DB, False, ffcl_TrImplicit, TransID); - if (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 500; { transaction started for opening table } - - try - {First, delete all existing records.} - FFGetMem(MyRec, Dict.RecordLength); - - State := 600; {memory allocated for MyRec} - - {Insert new record.} - Cursor := CursorClass.Create(Self, DB, 1000); {!!.06} - FFSetRetry(Cursor.Timeout); {!!.01} - Cursor.Open(ffc_TempGenInfoTableName, '', 0, omReadWrite, smExclusive, - True, False, []); - Cursor.CloseTable := True; - Cursor.Dictionary.InitRecord(MyRec); - with Configuration.GeneralInfo^, Cursor.Dictionary do begin - SetRecordField(0, MyRec, @giServerName); - SetRecordField(1, MyRec, @giMaxRAM); - SetRecordField(2, MyRec, @giIsSecure); - SetRecordField(3, MyRec, @giAutoUp); - SetRecordField(4, MyRec, @giAutoMini); - SetRecordField(5, MyRec, @giDebugLog); - SetRecordField(6, MyRec, @giSingleUser); - SetRecordField(7, MyRec, @giIPXSPX); - SetRecordField(8, MyRec, @giIPXSPXLFB); - SetRecordField(9, MyRec, @giTCPIP); - SetRecordField(10, MyRec, @giTCPIPLFB); - SetRecordField(11, MyRec, @giTCPPort); - SetRecordField(12, MyRec, @giUDPPortSr); - SetRecordField(13, MyRec, @giUDPPortCl); - SetRecordField(14, MyRec, @giIPXSocketSr); - SetRecordField(15, MyRec, @giIPXSocketCl); - SetRecordField(16, MyRec, @giSPXSocket); - SetRecordField(17, MyRec, @giAllowEncrypt); - SetRecordField(18, MyRec, @giReadOnly); - SetRecordField(19, MyRec, @giLastMsgInterval); - SetRecordField(20, MyRec, @giKAInterval); - SetRecordField(21, MyRec, @giKARetries); - SetRecordField(22, MyRec, @giPriority); - SetRecordField(23, MyRec, @giTCPInterface); - SetRecordField(24, MyRec, @giNoAutoSaveCfg); - SetRecordField(25, MyRec, @giTempStoreSize); - SetRecordField(26, MyRec, @giCollectEnabled); - SetRecordField(27, MyRec, @giCollectFreq); - end; - FFSetRetry(Cursor.Timeout); {!!.01} - Result := Cursor.InsertRecord(MyRec, ffsltExclusive); - if Result <> DBIERR_NONE then - goto InnerCleanup; - - State := 750; - - { Commit the transaction. } - FFSetRetry(Cursor.Timeout); {!!.01} - Result := seTransactionCommit(DB); - if Result = DBIERR_NONE then - State := 800; { transaction committed } - - InnerCleanup: - - finally - {rollback the transaction} - if (State >= 500) and (State < 750) then - seTransactionRollback(DB); - - {free memory for MyRec} - if State >= 600 then - FFFreeMem(MyRec, Dict.RecordLength); - - {close the cursor} - if assigned(Cursor) then - Cursor.Free; - - end; {try..finally} - - {if the record wasn't inserted, goto cleanup} - if State < 800 then - goto Cleanup; - - { Rename the existing table. } - Result := seTableRenamePrim(DB, ffc_GenInfoTableName, ffc_SavedGenInfoTableName); - if (Result <> DBIERR_NOSUCHTABLE) and (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 1000; {table renamed} - - { Replace the original table with the temporary table. } - Result := seTableRenamePrim(DB, ffc_TempGenInfoTableName, ffc_GenInfoTableName); - if Result <> DBIERR_NONE then - goto Cleanup; - - State := 1100; {renamed existing table} - - { The new table is now in place. Get rid of the saved, original - table. Ignore errors. } - if not IsTableNameOpen(DB.Folder, ffc_SavedGenInfoTableName) then - seDeleteTable(DB, ffc_SavedGenInfoTableName) - else - Result := DBIERR_TABLEOPEN; - - Cleanup: - - except - {If an error occurs at any point, we raise an exception. The - exception handling just falls through to the cleanup code below.} - on E: Exception do - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - - { Put System table back into its rightful place if a failure occurred - after it was renamed to the saved table. } - if (State >= 1000) and (State < 1100) then - seTableRenamePrim(DB, ffc_SavedGenInfoTableName, ffc_GenInfoTableName); - - {delete the temporary table if it didn't replace the system table} - if (State >= 400) and (State < 1100) then - if not IsTableNameOpen(DB.Folder, ffc_TempGenInfoTableName) then - seDeleteTable(DB, ffc_TempGenInfoTableName) - else - Result := DBIERR_TABLEOPEN; - - Dict.Free; - DB.Free; - Folder.Free; - - {remove the client} - if State >= 100 then - seClientRemovePrim(Client); - -end; -{=====================================================================} - - -{== Read/write key proc info from/to tables ==========================} -const - ffc_KeyProcClientID = -1; -{--------} -procedure TffServerEngine.ReadKeyProcData; -var - aClientID : TffClientID; - BufBuild : TffName; - BufCompare : TffName; - BufDLL : TffFullFileName; - BufIndexID : Longint; - BufPath : TffPath; - BufTable : TffTableName; - Client : TffSrClient; - Cursor : TffSrBaseCursor; {!!.06} - DB : TffSrDatabase; - DBIResult : TffResult; - Dict : TffDataDictionary; - Folder : TffSrFolder; - Hash : TffWord32; - IsNull : boolean; - MyRec : PffByteArray; - SearchPath : TffPath; -begin - Client := nil; - Folder := nil; - Cursor := nil; - DB := nil; - try - {create ourselves a client} - DBIResult := ClientAdd(aClientID, '', ffc_AdminUserID, 1000, Hash); - if (DBIResult <> DBIERR_NONE) then - Exit; - - {open a database (no User) to the server engine directory} - Client := TffSrClient(aClientID); - Folder := TffSrFolder.Create(ConfigDir, True, seBufMgr); - DB := seDatabaseOpenPrim(Client.clSessionList.CurrentSession, - Folder, - '', - omReadWrite, - smExclusive, - 1000, - False); {!!.11} - if (DBIResult = DBIERR_NONE) then - FFSetRetry(DB.Timeout) - else - Exit; - - {read the records} - Configuration.KeyProcList.Empty; - - { If the table exists then read it. } - SearchPath := Folder.Path; - if (SearchPath[length(SearchPath)] <> '\') then - FFShStrAddChar(SearchPath, '\'); - if FFFileExists(SearchPath + FFForceExtension(ffc_IndexTableName, ffc_ExtForData)) then begin - Cursor := CursorClass.Create(Self, DB, 1000); {!!.06} - FFSetRetry(Cursor.Timeout); {!!.01} - Cursor.Open(ffc_IndexTableName, '', 0, omReadOnly, smExclusive, - True, False, []); - Cursor.CloseTable := True; - Dict := Cursor.Dictionary; - FFGetMem(MyRec, Dict.RecordLength); - try - FFSetRetry(Cursor.Timeout); - Cursor.SetToBegin; - FFSetRetry(Cursor.Timeout); {!!.01} - DBIResult := Cursor.GetNextRecord(MyRec, ffsltNone); - while (DBIResult = DBIERR_NONE) do begin - Dict.GetRecordField(0, MyRec, IsNull, @BufPath); - Dict.GetRecordField(1, MyRec, IsNull, @BufTable); - Dict.GetRecordField(2, MyRec, IsNull, @BufIndexID); - Dict.GetRecordField(3, MyRec, IsNull, @BufDLL); - Dict.GetRecordField(4, MyRec, IsNull, @BufBuild); - Dict.GetRecordField(5, MyRec, IsNull, @BufCompare); - Configuration.AddKeyProc(BufPath, BufTable, BufIndexID, - BufDLL, BufBuild, BufCompare); - FFSetRetry(Cursor.Timeout); {!!.01} - DBIResult := Cursor.GetNextRecord(MyRec, ffsltNone); - end; - finally - FFFreeMem(MyRec, Dict.RecordLength); - end; {try..finally} - end; - finally - - { Close the cursor. } - if assigned(Cursor) then - Cursor.Free; - - DB.Free; - Folder.Free; - - { Remove the client. } - seClientRemovePrim(Client); - - end; -end; -{--------} -function TffServerEngine.WriteKeyProcData : TffResult; -label - Cleanup, - InnerCleanup; -var - aClientID : TffClientID; - BufInt : Longint; - BufStr : TffShStr; - Dict : TffDataDictionary; - Folder : TffSrFolder; - Hash : TffWord32; - i : integer; - KeyProcItem : TffKeyProcItem; - MyRec : PffByteArray; - State : integer; - TransID : TffTransID; - Client : TffSrClient; - DB : TffSrDatabase; - Cursor : TffSrBaseCursor; {!!.06} -begin - - Result := DBIERR_NONE; - with Configuration.GeneralInfo^ do - if giReadOnly or giNoAutoSaveCfg then - Exit; - - Client := nil; - DB := nil; - Dict := nil; - Folder := nil; - Cursor := nil; - State := 0; - try - { Strategy: Create a temporary table and write the data to that - table. If that works, rename the existing table and replace it with - the temporary table. If that succeeds, get rid of the old table. - If a failure occurs at any point, the old table must be put back - in its original place. } - - {create ourselves a client} - Result := ClientAdd(aClientID, '', ffc_AdminUserID, 1000, Hash); - if (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 100; { client added } - - {open a database (no alias) to the server engine directory} - Client := TffSrClient(aClientID); - Folder := TffSrFolder.Create(ConfigDir, False, seBufMgr); - DB := seDatabaseOpenPrim(Client.clSessionList.CurrentSession, - Folder, - '', - omReadWrite, - smExclusive, - 1000, - False); {!!.11} - if (Result = DBIERR_NONE) then - FFSetRetry(DB.Timeout) - else - goto Cleanup; - - State := 200; { database opened } - - {Make sure prior instances of the saved and temporary tables are deleted. } - seTableDeletePrim(DB, ffc_SavedIndexTableName); - seTableDeletePrim(DB, ffc_TempIndexTableName); - - {Prepare a data dictionary.} - Dict := TffServerDataDict.Create(4096); - - State := 300; { dictionary created } - - {Create the new table as a temporary file. } - - with Dict do begin - AddField('Path', '', fftShortString, pred(sizeof(TffPath)), 0, true, nil); - AddField('Table', '', fftShortString, pred(sizeof(TffTableName)), 0, true, nil); - AddField('IndexID', '', fftInt32, 0, 0, true, nil); - AddField('DLL', '', fftShortString, pred(sizeof(TffFullFileName)), 0, true, nil); - AddField('BuildKey', '', fftShortString, pred(sizeof(TffName)), 0, true, nil); - AddField('CompareKey', '', fftShortString, pred(sizeof(TffName)), 0, true, nil); - end; - Dict.IsEncrypted := Configuration.GeneralInfo^.giAllowEncrypt; - - Result := seTableBuildPrim(DB, true, ffc_TempIndexTableName, True, Dict); - if (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 400; { temporary table created } - - { Start a transaction before opening the table. } - Result := seTransactionStart(DB, false, ffcl_TrImplicit, TransID); - if (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 500; { transaction started for opening table } - - try - FFGetMem(MyRec, Dict.RecordLength); - - State := 600; - - Cursor := CursorClass.Create(Self, DB, 1000); {!!.06} - FFSetRetry(Cursor.Timeout); {!!.01} - Cursor.Open(ffc_TempIndexTableName, '', 0, omReadWrite, smExclusive, - True, False, []); - Cursor.CloseTable := True; - {Insert new records.} - for i := 0 to pred(Configuration.KeyProcList.Count) do begin - Cursor.Dictionary.InitRecord(MyRec); - KeyProcItem := Configuration.KeyProcList[i]; - BufStr := KeyProcItem.Path; - Cursor.Dictionary.SetRecordField(0, MyRec, @BufStr); - BufStr := KeyProcItem.Table; - Cursor.Dictionary.SetRecordField(1, MyRec, @BufStr); - BufInt := KeyProcItem.IndexID; - Cursor.Dictionary.SetRecordField(2, MyRec, @BufInt); - BufStr := KeyProcItem.DLLName; - Cursor.Dictionary.SetRecordField(3, MyRec, @BufStr); - BufStr := KeyProcItem.BuildKeyName; - Cursor.Dictionary.SetRecordField(4, MyRec, @BufStr); - BufStr := KeyProcItem.CompareKeyName; - Cursor.Dictionary.SetRecordField(5, MyRec, @BufStr); - FFSetRetry(Cursor.Timeout); {!!.01} - Result := Cursor.InsertRecord(MyRec, ffsltExclusive); - if (Result <> DBIERR_NONE) then - goto InnerCleanup; - end; - - State := 750; - - { Commit the transaction. } - FFSetRetry(Cursor.Timeout); {!!.01} - Result := seTransactionCommit(DB); - if Result = DBIERR_NONE then - State := 800; { transaction committed } - - InnerCleanup: - - finally - { Rollback the transaction. } - if (State >= 500) and (State < 750) then - seTransactionRollback(DB); - - if State >= 600 then - FFFreeMem(MyRec, Dict.RecordLength); - - {close the cursor} - if assigned(Cursor) then - Cursor.Free; - - end;{try..finally} - - { If the record insertions did not complete then jump to cleanup. } - if State < 800 then - goto Cleanup; - - { Rename the existing table. } - Result := seTableRenamePrim(DB, ffc_IndexTableName, ffc_SavedIndexTableName); - if (Result <> DBIERR_NOSUCHTABLE) and (Result <> DBIERR_NONE) then - goto Cleanup; - - State := 1000; { renamed system table to saved table } - - { Replace the original table with the temporary table. } - Result := seTableRenamePrim(DB, ffc_TempIndexTableName, ffc_IndexTableName); - if Result <> DBIERR_NONE then - goto Cleanup; - - State := 1100; { renamed temp table to system table } - - { The new table is now in place. Get rid of the saved, original - table. Ignore errors. } - if not IsTableNameOpen(DB.Folder, ffc_SavedIndexTableName) then - seDeleteTable(DB, ffc_SavedIndexTableName) - else - Result := DBIERR_TABLEOPEN; - - { The code jumps to this point if an error is detected in a ServerEngine - method. } - Cleanup: - except - {If an exception occurs, get the error code and fall through to the - cleanup code below. The error code will be returned to the calling - object. } - on E : Exception do - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); - end; - - { Put System table back into its rightful place if a failure occurred - after it was renamed to the saved table. } - if (State >= 1000) and (State < 1100) then - seTableRenamePrim(DB, ffc_SavedIndexTableName, ffc_IndexTableName); - - { Delete temporary table if it did not replace system table. } - if (State >= 400) and (State < 1100) then - if not IsTableNameOpen(DB.Folder, ffc_TempIndexTableName) then - seDeleteTable(DB, ffc_TempIndexTableName) - else - Result := DBIERR_TABLEOPEN; - - Dict.Free; - DB.Free; - Folder.Free; - - {remove the client} - if State >= 100 then - seClientRemovePrim(Client); - -end; -{--------} -procedure TffServerEngine.CreateAdminUser(SaveToDisk : Boolean); -var - Hash : TffWord32; -begin - Hash := FFCalcShStrELFHash('flashfiler'); - Configuration.AddUser(ffc_AdminUserID, - 'Administrator', - '', - Hash, - ffc_AdminRights); - if SaveToDisk then - WriteUserData; -end; -{====================================================================} - - -{===Initialization===================================================} -procedure InitializeUnit; -var - i : integer; - Temp : string[5]; -begin - {a simple encryption to thwart casual hackers: 'ojneb' will appear - in the EXE, not 'admin'} - Temp := 'ojneb'; - ffc_AdminUserID[0] := #5; - for i := 1 to 5 do - ffc_AdminUserID[i] := char(ord(Temp[6-i]) - 1); -end; -{====================================================================} - -initialization - InitializeUnit; - -end. - diff --git a/components/flashfiler/sourcelaz/ffsrfltr.pas b/components/flashfiler/sourcelaz/ffsrfltr.pas deleted file mode 100644 index 744a2c8e8..000000000 --- a/components/flashfiler/sourcelaz/ffsrfltr.pas +++ /dev/null @@ -1,634 +0,0 @@ -{*********************************************************} -{* FlashFiler: Server-side filter evaluation *} -{*********************************************************} - -(* ***** 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 ffsrfltr; - -interface - -uses - Windows, - SysUtils, - Classes, - Forms, - Messages, - ffllbase, - fflldict, - ffstdate, - fftbdict, - ffsrbase, - ffsrbde; - -type - 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; - - PffNodeValue = ^TffNodeValue; - TffNodeValue = packed record - nvType : TffWord16; - nvSize : TffWord16; - nvValue : Pointer; - nvIsNull : Boolean; - nvIsConst : Boolean; - end; - - TffSrFilter = class(TffObject) - protected {private} - sfDataDict : TffServerDataDict; - sfTimeout : TffWord32; - sfExpression : pCANExpr; - sfExprSize : TffWord16; - sfFilterUntil : TffWord32; - protected - protected - function sfGetLiteralPtr(aOffset : TffWord16) : Pointer; - function sfGetNodePtr(aOffset : TffWord16) : PffFilterNode; - - function sfEvaluateBinaryNode(aNode : PffFilterNode; - aRecBuf : Pointer; - aNoCase : Boolean; - aPartial: TffWord16) : Boolean; - function sfEvaluateConstNode(aNode : PffFilterNode; - aValue : PffNodeValue; - aRecBuf : Pointer) : Boolean; - function sfEvaluateFieldNode(aNode : PffFilterNode; - aValue : PffNodeValue; - aRecBuf : Pointer) : Boolean; - function sfEvaluateLogicalNode(aNode : PffFilterNode; - aRecBuf : Pointer) : Boolean; - function sfEvaluateNode(aNode : PffFilterNode; - aValue : PffNodeValue; - aRecBuf : Pointer) : Boolean; - function sfEvaluateUnaryNode(aNode : PffFilterNode; - aRecBuf : Pointer) : Boolean; - - function sfCompareValues(var aCompareResult : Integer; - var aFirst : TffNodeValue; - var aSecond : TffNodeValue; - aIgnoreCase : Boolean; - aPartLen : Integer) : Boolean; - function sfCompareValue(var aFirst : TffNodeValue; - var aSecond : TffNodeValue; - aIgnoreCase : Boolean; - aPartLen : Integer) : Integer; virtual; {!!.11} - public - constructor Create(aCursor : TObject; {!!.11} - aDataDict : TffServerDataDict; - aExpression : pCANExpr; - aTimeout : TffWord32); virtual; {!!.11} - destructor Destroy; override; - - function MatchesRecord(aRecBuf : Pointer) : Boolean; virtual; {!!.11} - - procedure BeginTimeout; - - function CheckTimeout(var Res: TffResult) : Boolean; - - property Expression: pCANExpr - read sfExpression; - - property Timeout: TffWord32 - read sfTimeout; - end; - -{Begin !!.11} -type - TffSrFilterClass = class of TffSrFilter; - -const - ffsrFilterClass : TffSrFilterClass = TffSrFilter; -{End !!.11} - -implementation - -uses - ffconst; - -{===TffSrFilter==================================================} -constructor TffSrFilter.Create(aCursor : TObject; {!!.11} - aDataDict : TffServerDataDict; - aExpression : pCANExpr; - aTimeout : TffWord32); -begin - inherited Create; - sfDataDict := aDataDict; - sfTimeout := aTimeout; -// if sfTimeout > 5000 then sfTimeout := 5000; {Deleted !!.07} -// if sfTimeout < 50 then sfTimeout := 50; {Deleted !!.07} - if Assigned(aExpression) then begin - sfExprSize := aExpression^.iTotalSize; - if (sfExprSize > 0) then begin - FFGetMem(sfExpression, sfExprSize); - Move(aExpression^, sfExpression^, sfExprSize); - end; - end; -end; -{--------} -destructor TffSrFilter.Destroy; -begin - if (sfExprSize > 0) and Assigned(sfExpression) then begin - FFFreeMem(sfExpression, sfExprSize); - sfExpression := nil; - end; - inherited Destroy; -end; -{--------} -function TffSrFilter.sfGetLiteralPtr(aOffset : TffWord16) : Pointer; -var - i : TffWord16; -begin - i := sfExpression^.iLiteralStart + aOffset; - Result := @PByteArray(sfExpression)^[i]; -end; -{--------} -function TffSrFilter.sfGetNodePtr(aOffset : TffWord16) : PffFilterNode; -var - i : TffWord16; -begin - i := sfExpression^.iNodeStart + aOffset; - Result := PffFilterNode(@PByteArray(sfExpression)^[i]); -end; -{--------} -function TffSrFilter.MatchesRecord(aRecBuf : Pointer) : Boolean; -var - Root : PffFilterNode; -begin - Result := true; - if Assigned(sfExpression) then begin - Root := sfGetNodePtr(0); - Result := sfEvaluateNode(Root, nil, aRecBuf); - end; -end; -{--------} -procedure TffSrFilter.BeginTimeout; -begin - sfFilterUntil := GetTickCount + sfTimeout; -end; -{--------} -function TffSrFilter.CheckTimeout(var Res: TffResult) : Boolean; -begin - Result := False; - if GetTickCount > sfFilterUntil then begin - Res := DBIERR_FF_FilterTimeout; - Result := True; - end; -end; -{--------} -function TffSrFilter.sfEvaluateNode(aNode : PffFilterNode; - aValue : PffNodeValue; - aRecBuf : Pointer) : Boolean; -begin - if (aValue <> nil) then - FillChar(aValue^, sizeof(aValue^), 0); - case aNode^.fnHdr.NodeClass of - nodeUNARY: - Result := sfEvaluateUnaryNode(aNode, aRecBuf); - nodeBINARY: - if (aNode^.fnHdr.CANOp in [canAND, canOR]) then - Result := sfEvaluateLogicalNode(aNode, aRecBuf) - else - Result := sfEvaluateBinaryNode(aNode, aRecBuf, false, 0); - nodeCOMPARE: - Result := sfEvaluateBinaryNode(aNode, aRecBuf, - aNode^.fnCompare.bCaseInsensitive, - aNode^.fnCompare.iPartialLen); - nodeFIELD: - Result := sfEvaluateFieldNode(aNode, aValue, aRecBuf); - nodeCONST: - Result := sfEvaluateConstNode(aNode, aValue, aRecBuf); - nodeCONTINUE: - Result := aNode^.fnContinue.iContOperand <> 0; - else - {all other node classes cause the node match to fail} - Result := false; - end;{case} -end; -{--------} -function TffSrFilter.sfEvaluateUnaryNode(aNode : PffFilterNode; - aRecBuf : Pointer) : Boolean; -var - OperandNode : PffFilterNode; - NodeValue : TffNodeValue; -begin - OperandNode := sfGetNodePtr(aNode^.fnUnary.iOperand1); - if sfEvaluateNode(OperandNode, @NodeValue, aRecBuf) then begin - case aNode^.fnHdr.CANOp of - canISBLANK: - Result := NodeValue.nvIsNull; - canNOTBLANK: - Result := not NodeValue.nvIsNull; - else - Result := false; - end;{case} - end - else { the node didn't match } - Result := aNode^.fnHdr.CANOp = canNOT; -end; -{--------} -function TffSrFilter.sfEvaluateLogicalNode(aNode : PffFilterNode; - aRecBuf : Pointer) : Boolean; -var - LeftNode : PffFilterNode; - RightNode : PffFilterNode; -begin - LeftNode := sfGetNodePtr(aNode^.fnBINARY.iOperand1); - RightNode := sfGetNodePtr(aNode^.fnBINARY.iOperand2); - case aNode^.fnHdr.CANOp of - canAND : Result := sfEvaluateNode(LeftNode, nil, aRecBuf) and - sfEvaluateNode(RightNode, nil, aRecBuf); - canOR : Result := sfEvaluateNode(LeftNode, nil, aRecBuf) or - sfEvaluateNode(RightNode, nil, aRecBuf); - else - {anything else fails} - Result := false; - end;{case} -end; -{--------} -function TffSrFilter.sfEvaluateBinaryNode(aNode : PffFilterNode; - aRecBuf : Pointer; - aNoCase : Boolean; - aPartial : TffWord16) : Boolean; -var - LeftNode : PffFilterNode; - RightNode : PffFilterNode; - LeftValue : TffNodeValue; - RightValue : TffNodeValue; - CompareResult : Integer; -begin - Result := false; - if (aNode^.fnHdr.NodeClass = nodeCOMPARE) then begin - LeftNode := sfGetNodePtr(aNode^.fnCompare.iOperand1); - RightNode := sfGetNodePtr(aNode^.fnCompare.iOperand2); - end - else begin - LeftNode := sfGetNodePtr(aNode^.fnBINARY.iOperand1); - RightNode := sfGetNodePtr(aNode^.fnBINARY.iOperand2); - end; - if not sfEvaluateNode(LeftNode, @LeftValue, aRecBuf) then - Exit; - if not sfEvaluateNode(RightNode, @RightValue, aRecBuf) then - Exit; - if not sfCompareValues(CompareResult, LeftValue, RightValue, - aNoCase, aPartial) then - Exit; - case aNode^.fnHdr.CANOp of - canLike : Result := CompareResult = 0; {!!.11} - 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 TffSrFilter.sfEvaluateConstNode(aNode : PffFilterNode; - aValue : PffNodeValue; - aRecBuf : Pointer) : Boolean; -begin - with aValue^, aNode^.fnCONST do begin - nvType := iType; - nvSize := iSize; - nvValue := sfGetLiteralPtr(iOffset); - nvIsNull := false; - nvIsConst := true; - end; - Result := true; -end; -{--------} -function TffSrFilter.sfEvaluateFieldNode(aNode : PffFilterNode; - aValue : PffNodeValue; - aRecBuf : Pointer) : Boolean; -var - FieldDesc : PffFieldDescriptor; -begin - with aNode^.fnFIELD do - if (0 < iFieldNum) and (iFieldNum <= sfDataDict.FieldCount) then - FieldDesc := sfDataDict.FieldDescriptor[Pred(iFieldNum)] - else - FieldDesc := nil; -{Begin !!.11} - if aValue <> nil then begin - with aValue^, FieldDesc^ do begin - nvType := Ord(fdType); - nvSize := Ord(fdLength); - nvValue := @PffByteArray(aRecBuf)^[fdOffset]; - sfDataDict.GetRecordField(Pred(aNode^.fnFIELD.iFieldNum), - PffByteArray(aRecBuf), nvIsNull, nil); - nvIsConst := false; - end; - Result := true; - end - else - Result := False; -{End !!.11} -end; -{--------} -function TffSrFilter.sfCompareValues(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 := sfCompareValue(aFirst, aSecond, aIgnoreCase, aPartLen); -end; -{--------} -function TffSrFilter.sfCompareValue(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 := DbiTime(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, TffShStr(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(Pointer(aFirst.nvValue), - Pointer(aSecond.nvValue), - FFMinI(aFirst.nvSize, aSecond.nvSize)); -end; - -end. - diff --git a/components/flashfiler/sourcelaz/ffsrfmap.pas b/components/flashfiler/sourcelaz/ffsrfmap.pas deleted file mode 100644 index 88d7dac22..000000000 --- a/components/flashfiler/sourcelaz/ffsrfmap.pas +++ /dev/null @@ -1,257 +0,0 @@ -{*********************************************************} -{* FlashFiler: Server Restructure Field Map *} -{*********************************************************} - -(* ***** 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 ffsrfmap; - -interface - -uses - Windows, - SysUtils, - Classes, - ffconst, - ffllbase, - fflldict, - ffsrbase, - ffsrbde, - fftbdict; - -type - TffSrRestructField = record - Name: TffDictItemName; - Number: Integer; - Offset: Integer; - FieldLength: Integer; - FieldType: TffFieldType; - end; - - TffSrFieldMapListItem = class(TffSelfListItem) - protected {private} - fmPadlock : TffPadlock; - fmSource : TffSrRestructField; - fmTarget : TffSrRestructField; - protected - public - constructor Create(aSourceField, aTargetField: TffSrRestructField); - destructor Destroy; override; - end; - - TffSrFieldMapList = class(TffObject) - protected {private} - FList : TffList; - fmlPadlock : TffPadlock; - fmlSourceDict: TffServerDataDict; - fmlTargetDict: TffServerDataDict; - protected - function GetCount: Integer; - function GetSourceField(aIndex: Integer): TffSrRestructField; - function GetTargetField(aIndex: Integer): TffSrRestructField; - public - constructor Create(aSourceDict, aTargetDict: TffDataDictionary); - destructor Destroy; override; - - function Add(aSourceFieldName, aTargetFieldName: TffShStr): TffResult; - {-insert single source-to-target field mapping into list; - return true on success} - function AddStringList(aFieldMap: TffStringList): TffResult; - {-given a string list containing "destfield=sourcefield" entries, - populates the field map with structured field entries} - - property Count: Integer - {-the number of items in the list} - read GetCount; - - property SourceDict: TffServerDataDict - {-provides access to the source table's dictionary} - read fmlSourceDict; - - property SourceField[aIndex: Integer]: TffSrRestructField - {-returns the field info for a source field} - read GetSourceField; - - property TargetDict: TffServerDataDict - {-provides access to the target table's dictionary} - read fmlTargetDict; - - property TargetField[aIndex: Integer]: TffSrRestructField - {-returns the field info for a target field} - read GetTargetField; - end; - - function FFBuildFieldMapEntry(aFieldName: TffDictItemName; - aDictionary: TffServerDataDict; - var aFieldEntry: TffSrRestructField): Boolean; - -implementation - -{===TffSrFieldMapListItem============================================} -constructor TffSrFieldMapListItem.Create(aSourceField, - aTargetField: TffSrRestructField); -begin - inherited Create; - fmPadlock := TffPadlock.Create; - fmSource := aSourceField; - fmTarget := aTargetField; -end; -{--------} -destructor TffSrFieldMapListItem.Destroy; -begin - fmPadlock.Free; - inherited Destroy; -end; -{====================================================================} - - -{===TffSrFieldMapLList===============================================} -constructor TffSrFieldMapList.Create(aSourceDict, aTargetDict: TffDataDictionary); -begin - inherited Create; - FList := TffList.Create; - fmlPadlock := TffPadlock.Create; - fmlSourceDict := TffServerDataDict.Create(4096); - fmlTargetDict := TffServerDataDict.Create(4096); - - fmlSourceDict.Assign(aSourceDict); - fmlTargetDict.Assign(aTargetDict); -end; -{--------} -destructor TffSrFieldMapList.Destroy; -begin - fmlSourceDict.Free; - fmlTargetDict.Free; - fmlPadlock.Free; - FList.Free; - inherited Destroy; -end; -{--------} -function TffSrFieldMapList.Add(aSourceFieldName, - aTargetFieldName: TffShStr): TffResult; -var - Item: TffSrFieldMapListItem; - SourceField, TargetField: TffSrRestructField; -begin - Result := DBIERR_NONE; - fmlPadlock.Lock; - try - if aSourceFieldName = '' then - aSourceFieldName := aTargetFieldName; - - { Build packet of info about the source field } - with fmlSourceDict do begin - SourceField.Name := aSourceFieldName; - SourceField.Number := GetFieldFromName(aSourceFieldName); - if SourceField.Number = -1 then begin - Result := DBIERR_INVALIDFIELDNAME; - Exit; - end; - - SourceField.Offset := FieldOffset[SourceField.Number]; - SourceField.FieldLength := FieldLength[SourceField.Number]; - SourceField.FieldType := FieldType[SourceField.Number]; - end; - - { Build packet of info about the target field } - with fmlTargetDict do begin - TargetField.Name := aTargetFieldName; - TargetField.Number := GetFieldFromName(aTargetFieldName); - if TargetField.Number = -1 then begin - Result := DBIERR_INVALIDFIELDNAME; - Exit; - end; - - TargetField.Offset := FieldOffset[TargetField.Number]; - TargetField.FieldLength := FieldLength[TargetField.Number]; - TargetField.FieldType := FieldType[TargetField.Number]; - end; - - Item := TffSrFieldMapListItem.Create(SourceField, TargetField); - try - if not FList.Insert(Item) then - Result := -1 {!! DBIERR_????}; - except - Item.Free; - raise; - end;{try..except} - finally - fmlPadlock.Unlock; - end;{try..finally} -end; -{--------} -function TffSrFieldMapList.AddStringList(aFieldMap: TffStringList): TffResult; -var - I: Integer; - SourceName, TargetName: TffShStr; -begin - Result := DBIERR_NONE; - for I := 0 to aFieldMap.Count - 1 do begin - FFShStrSplit(aFieldMap.Strings[I], '=', TargetName, SourceName); - - Add(SourceName, TargetName); {!! check for errors } - end; -end; -{--------} -function TffSrFieldMapList.GetCount: Integer; -begin - Result := FList.Count; -end; -{--------} -function TffSrFieldMapList.GetSourceField(aIndex: Integer): TffSrRestructField; -begin - Result := TffSrFieldMapListItem(FList.Items[aIndex]).fmSource; -end; -{--------} -function TffSrFieldMapList.GetTargetField(aIndex: Integer): TffSrRestructField; -begin - Result := TffSrFieldMapListItem(FList.Items[aIndex]).fmTarget; -end; -{====================================================================} - - - -function FFBuildFieldMapEntry(aFieldName: TffDictItemName; - aDictionary: TffServerDataDict; - var aFieldEntry: TffSrRestructField): Boolean; -begin - Result := True; - with aDictionary do begin - aFieldEntry.Number := GetFieldFromName(aFieldName); - if aFieldEntry.Number = -1 then begin - Result := False; - Exit; - end; - - aFieldEntry.Offset := FieldOffset[aFieldEntry.Number]; - aFieldEntry.FieldLength := FieldLength[aFieldEntry.Number]; - aFieldEntry.FieldType := FieldType[aFieldEntry.Number]; - end; -end; - -end. diff --git a/components/flashfiler/sourcelaz/ffsrfold.pas b/components/flashfiler/sourcelaz/ffsrfold.pas deleted file mode 100644 index 1f52bb00e..000000000 --- a/components/flashfiler/sourcelaz/ffsrfold.pas +++ /dev/null @@ -1,392 +0,0 @@ -{*********************************************************} -{* FlashFiler: Folder and folder list objects 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 ffsrfold; - -interface - -uses - Windows, - Messages, - SysUtils, - ffllbase, - ffllunc, - ffhash, - ffsrbase, - ffsrlock, - ffsrtran; - -type - TffSrFolder = class(TffSelfListItem) - protected {private} -{Begin !!.11} - FExistingTableVersion : Longint; - { !!! WARNING: This is intended for testing & utility purposes only. !!! - Holds the version # to be assigned to existing tables. - Default value is zero. If zero then the version number already in the - table is used. } -{End !!.11} - FHash : TffWord32; - FLockMgr : TffLockManager; -{Begin !!.11} - FNewTableVersion : Longint; - { !!! WARNING: This is intended for testing & utility purposes only. !!! - Holds the version # of tables that are created in this folder. - Default value is constant FFVersionNumber declared in unit FFLLBASE. } - FPackSrcTableVersion : Longint; - { !!! WARNING: This is intended for testing & utility purposes only. !!! - Holds the version # of source tables that are being opened in this - folder for a pack operation. - Default value is zero. If zero then the version number already in the - table is used. } -{End !!.11} - FPath : PffShStr; - FRefCount : integer; - FTranMgr : TffSrTransactionMgr; - protected - function GetPath : TffPath; - - function CanDelete : boolean; - -{Begin !!.11} - procedure SetExistingTableVersion(const Version : Longint); - procedure SetNewTableVersion(const Version : Longint); - procedure SetPackSrcTableVersion(const Version : Longint); -{End !!.11} - public - constructor Create(const aPath : TffPath; - const isReadOnly : boolean; - aBufMgr : TffBufferManager); - destructor Destroy; override; - - procedure DecRefCount; - procedure IncRefCount; - -{Begin !!.11} - property ExistingTableVersion : Longint - read FExistingTableVersion - write SetExistingTableVersion; - { !!! WARNING: This property is intended for testing & utility - purposes only. !!! - The version number to be assigned to existing tables opened in this - folder. Default value is zero which causes the version number in the - table to be used. } -{End !!.11} - property FolderID : longint read KeyAsInt; - property FolderReferences : integer read FRefCount; - property LockMgr : TffLockManager read FLockMgr; -{Begin !!.11} - property NewTableVersion : Longint - read FNewTableVersion - write SetNewTableVersion; - { !!! WARNING: This property is intended for testing & utility - purposes only. !!! - The version number to be assigned to new tables created in this - folder. Default value is constant FFVersionNumber declared in unit - FFLLBASE. } - property PackSrcTableVersion : Longint - read FPackSrcTableVersion - write SetPackSrcTableVersion; - { !!! WARNING: This property is intended for testing & utility - purposes only. !!! - The version number to be assigned to source tables opened by the - pack operation. Default value is zero which causes the version number - in the table to be used. } -{End !!.11} - property Path : TffPath read GetPath; - property PathHash : TffWord32 read FHash; - property RefCount : integer read FRefCount; - property TransactionMgr : TffSrTransactionMgr read FTranMgr; - end; - - TffSrFolderList = class(TffObject) - protected {private} - FList : TffThreadList; - protected - function GetFolderItem(Find : TffListFindType; Value : longint) : TffSrFolder; - function plIndexOf(const aPath : TffPath) : integer; - public - constructor Create; - destructor Destroy; override; - - function AddFolder(const aPath : TffPath; - const isReadOnly : boolean; - aBufMgr : TffBufferManager) : TffSrFolder; - { If a folder for the specified path does not exist in the folder list - then this method creates and adds a new folder to the folder list. - Otherwise it increments the reference count on the existing folder. } - - function BeginRead : TffSrFolderList; - {-A thread must call this method to gain read access to the list. - Returns the instance of this object as a convenience. } - - function BeginWrite : TffSrFolderList; - {-A thread must call this method to gain write access to the list. - Returns the instance of this object as a convenience.} - - procedure DeleteFolder(const aPath : TffPath); - procedure DeleteFolderByID(aFolderID : longint); - - 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 ExistsPath(const aPath : TffPath) : boolean; - procedure RemoveUnusedFolders; - - property Folder[Find : TffListFindType; Value : longint] : TffSrFolder - read GetFolderItem; - end; - -implementation - -{===TffSrPath========================================================} -constructor TffSrFolder.Create(const aPath : TffPath; - const isReadOnly : boolean; - aBufMgr : TffBufferManager); -var - UNC : TffShStr; -begin - inherited Create; - UNC := FFShStrUpper(FFExpandUNCFileName(aPath)); - FPath := FFShStrAlloc(UNC); - FHash := FFCalcShStrELFHash(FPath^); - FLockMgr := TffLockManager.Create; - FExistingTableVersion := 0; {!!.11} - FNewTableVersion := FFVersionNumber; {!!.11} - FPackSrcTableVersion := 0; {!!.11} - FTranMgr := TffSrTransactionMgr.Create(aBufMgr, FLockMgr, FPath^, isReadOnly); -end; -{--------} -destructor TffSrFolder.Destroy; -begin - FFShStrFree(FPath); - FLockMgr.Free; - FLockMgr := nil; - FTranMgr.Free; - FTranMgr := nil; - inherited Destroy; -end; -{--------} -function TffSrFolder.CanDelete : boolean; -begin - dec(FRefCount); - Result := (FRefCount = 0); -end; -{--------} -procedure TffSrFolder.DecRefCount; -begin - if FRefCount > 0 then - dec(FRefCount); -end; -{--------} -function TffSrFolder.GetPath : TffPath; -begin - Result := FPath^; -end; -{--------} -procedure TffSrFolder.IncRefCount; -begin - inc(FRefCount); -end; -{Begin !!.11} -{--------} -procedure TffSrFolder.SetExistingTableVersion(const Version : Longint); -begin - if Version <> FExistingTableVersion then - FExistingTableVersion := Version; -end; -{--------} -procedure TffSrFolder.SetNewTableVersion(const Version : Longint); -begin - if Version <> FNewTableVersion then - FNewTableVersion := Version; -end; -{--------} -procedure TffSrFolder.SetPackSrcTableVersion(const Version : Longint); -begin - if Version <> FPackSrcTableVersion then - FPackSrcTableVersion := Version; -end; -{End !!.11} -{====================================================================} - - -{===TffSrFolderList====================================================} -constructor TffSrFolderList.Create; -begin - inherited Create; - FList := TffThreadList.Create; -end; -{--------} -destructor TffSrFolderList.Destroy; -begin - FList.Free; - inherited Destroy; -end; -{--------} -function TffSrFolderList.AddFolder(const aPath : TffPath; - const isReadOnly : boolean; - aBufMgr : TffBufferManager) : TffSrFolder; -var - Inx : integer; -begin - Inx := plIndexOf(aPath); - if (Inx <> -1) then begin - Result := TffSrFolder(FList[Inx]); - Result.IncRefCount; - end - else begin - Result := TffSrFolder.Create(aPath, isReadOnly, aBufMgr); - try - FList.Insert(Result); - Result.IncRefCount; - except - Result.Free; - raise; - end; - end; -end; -{--------} -function TffSrFolderList.BeginRead : TffSrFolderList; -begin - FList.BeginRead; - Result := Self; -end; -{--------} -function TffSrFolderList.BeginWrite : TffSrFolderList; -begin - FList.BeginWrite; - Result := Self; -end; -{--------} -procedure TffSrFolderList.DeleteFolder(const aPath : TffPath); -var - Inx : integer; - Item : TffSrFolder; -begin - Inx := plIndexOf(aPath); - if (Inx <> -1) then begin - Item := TffSrFolder(FList[Inx]); - if Item.CanDelete then - FList.DeleteAt(Inx); - end; -end; -{--------} -procedure TffSrFolderList.DeleteFolderByID(aFolderID : longint); -var - Inx : integer; - Item : TffSrFolder; -begin - Inx := FList.Index(aFolderID); - if (Inx <> -1) then begin - Item := TffSrFolder(FList[Inx]); - if Item.CanDelete then - FList.DeleteAt(Inx); - end; -end; -{--------} -procedure TffSrFolderList.EndRead; -begin - FList.EndRead; -end; -{--------} -procedure TffSrFolderList.EndWrite; -begin - FList.EndWrite; -end; -{--------} -function TffSrFolderList.ExistsPath(const aPath : TffPath) : boolean; -begin - Result := plIndexOf(aPath) <> -1; -end; -{--------} -function TffSrFolderList.GetFolderItem(Find : TffListFindType; Value : longint) : TffSrFolder; -var - Inx : integer; -begin - Result := nil; - if (Find = ftFromID) then begin - Inx := FList.Index(Value); - if (Inx <> -1) then - Result := TffSrFolder(FList[Inx]); - end - else {Find = ftFromIndex} - if (0 <= Value) and (Value < FList.Count) then - Result := TffSrFolder(FList[Value]); -end; -{--------} -function TffSrFolderList.plIndexOf(const aPath : TffPath) : integer; -var - i : integer; - Hash : TffWord32; - Path : TffSrFolder; - UNC : TffShStr; -begin - UNC := FFShStrUpper(FFExpandUNCFileName(aPath)); - Hash := FFCalcShStrELFHash(UNC); - for i := 0 to pred(FList.Count) do begin - Path := TffSrFolder(FList[i]); - if (Path.PathHash = Hash) then - if (FFCmpShStr(Path.Path, UNC, 255) = 0) then begin - Result := i; - Exit; - end; - end; - Result := -1; -end; -{--------} -procedure TffSrFolderList.RemoveUnusedFolders; -var - Inx : integer; - Item : TffSrFolder; -begin - FList.BeginWrite; - try - for Inx := pred(FList.Count) downto 0 do begin - Item := TffSrFolder(FList[Inx]); - if Item.RefCount = 0 then - FList.DeleteAt(Inx); - end; - finally - FList.EndWrite; - end; -end; - -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/ffsrintf.pas b/components/flashfiler/sourcelaz/ffsrintf.pas deleted file mode 100644 index e48c17abc..000000000 --- a/components/flashfiler/sourcelaz/ffsrintf.pas +++ /dev/null @@ -1,335 +0,0 @@ -{*********************************************************} -{* FlashFiler: Server interface unit for DLLs *} -{*********************************************************} - -(* ***** 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} - -{===================================================================== -NOTES: - -Using this unit, you will be able to write a DLL that provides two -special routines. These two routines used as a pair will identify what -FlashFiler calls a user-defined index. A user-defined index does not -generate its keys automatically like the normal (composite) indexes in -FlashFiler, and since it does not do that it cannot compare two keys -for their sorted order either. However, if you provide both of these -routines (a build key routine and a compare key routine) then -FlashFiler Server will be able to store your user-defined keys and -index records in the table for you. - -The first routine is the Build Key routine. It must be of the -TffKeyBuildFunc type - - TffKeyBuildFunc = function (Index : integer; - DataRec : PffByteArray; - var Key; - KeyLen : integer) : boolean; - -Index is the number of the index for which the key must be generated. -DataRec is a pointer to the record from which you must generate the -key. It is assumed that you will know the record length. Key is an -untyped var where you must store the generated key, and KeyLen is the -length of the key to be generated. - -The second routine is the Compare Key routine. It must be of the -TffKeyCompareFunc type: - - TffKeyCompareFunc = function (const Key1, Key2; - aData : PffCompareData) : integer; - -Key1 and Key2 are untyped const variables holding the keys to be -compared. The object of the routine is to compare the two keys and -return an integer value depending on the collating sequence of the -keys (a negative number means 'less than', zero means 'equal' and -a positive number means 'greater than'). aData is a pointer to a -special record holding information about the comparison to be done. - - PffCompareData = ^TffCompareData; - TffCompareData = packed record - cdKeyLen : longint; - cdDict : pointer; - cdIndex : longint; - cdFldCnt : longint; - cdPartLen : longint; - cdAscend : boolean; - cdNoCase : boolean; - end; - -The cdKeyLen field is the length of the key in bytes. cdDict is a -field for internal purposes: it is not guaranteed to point to anything -when your routine gets called. cdIndex is the number of the index -where the keys reside. cdFldCnt will either be 0 or 1: 0 means that -the routine must perform a 'partial' comparison and cdPartLen is the -number of bytes to compare of the two keys. If cdFldCnt is 1, the -comparison you make must be done over the whole of the keys. cdAscend -determines whether the index is in ascending order or not, and hence -affects the result that you return. If cdAscend is true then you must -return a value <0 if Key1 is less than Key2, 0 if they are equal and ->0 otherwise. If it is false you must reverse the sign of the result -(ie, return <0 if Key1 > Key2, 0 if equal, >0 otherwise. cdNoCase -defines whether case-insensitivity is an issue with the compare: if -true the keys must be compared in a case-insensitive manner, if false -in a case-sensitive manner. Obviously cdNoCase only has meaning for -character or string fields. - -In 16-bit Delphi the routines you write will have to be exported from -the DLL and must therefore (a) be marked with the export keyword and -(b) be explicitly exported via the exports clause. - -In 32-bit Delphi the routines you write must be marked with the -stdcall directive. The fastcall type (and others) is not available. - -Once you have created the DLL, exporting these two routines, you can -then configure the server (via the configuration dialog) to go and use -this DLL whenever it needs to index records belonging to a particular -database alias, table and index. - -=====================================================================} - - -unit ffsrintf; - -interface - -uses - Windows, - SysUtils, - Classes, - ffconst, - ffllbase; - -type - PffCompareData = ^TffCompareData; - TffCompareData = packed record {Data for comparison operations} - cdKeyLen : longint; {..max length of key to compare} - cdDict : pointer; {..dictionary (to be typecast)} - cdIndex : longint; {..index number} - cdFldCnt : longint; {..field count (partial searches)} - cdPartLen : longint; {..partial length (partial searches)} - cdAscend : boolean; {..true if keys are to be compared in ascending order} - cdNoCase : boolean; {..true if keys are to be case-insensitive compared} - end; - -type - TffKeyCompareFunc = function (const Key1, Key2; aData : PffCompareData) : integer - stdcall; - {-Type of the key comparison routine for building an index. - Returns negative value if Key1 < Key2, 0 if equal, positive - value otherwise, aData defines the comparison criteria} - - TffKeyBuildFunc = function (Index : integer; - DataRec : PffByteArray; - var Key; - KeyLen : integer) : boolean - stdcall; - {-Type of the generation routine for generating a key. - Returns true if a key was generated. KeyLen defines the number - of bytes required in the generated key} - - -{---Useful Key Comparison routines---} -function FFKeyCompareLongint(const Key1, Key2; aData : PffCompareData) : integer; - stdcall; - {-Treat Key1 and Key2 as longints, compare} -function FFKeyCompareBytes(const Key1, Key2; aData : PffCompareData) : integer; - stdcall; - {-Treat Key1 and Key2 as array of bytes, compare} -function FFKeyCompareStr(const Key1, Key2; aData : PffCompareData) : integer; - stdcall; - {-Treat Key1 and Key2 as short strings, compare} -function FFKeyCompareStrZ(const Key1, Key2; aData : PffCompareData) : integer; - stdcall; - {-Treat Key1 and Key2 as null-terminated strings, compare} -function FFKeyCompareAnsiStr(const Key1, Key2; aData : PffCompareData) : integer; - stdcall; - {-Treat Key1 and Key2 as ANSI short strings, compare} -function FFKeyCompareAnsiStrZ(const Key1, Key2; aData : PffCompareData) : integer; - stdcall; - {-Treat Key1 and Key2 as ANSI null-terminated strings, compare} -function FFKeyCompareWideChar(const Key1, Key2; aData : PffCompareData) : integer; stdcall; - {-Treat Key1 and Key2 as wide UNICODE characters, compare} -function FFKeyCompareWideStr(const Key1, Key2; aData : PffCompareData) : integer; stdcall; - {-Treat Key1 and Key2 as wide UNICODE null-terminated strings, compare} - -function FFKeyCompareDWord(const Key1, Key2; - aData : PffCompareData) : integer; - stdcall; - {-Treat Key1 and Key2 as DWord, compare} - -function FFKeyCompareI64(const Key1, Key2; - aData : PffCompareData) : integer; stdcall; - {-Treat Key1 and Key2 as TffInt64, compare} -implementation - -{===Key Comparison routines==========================================} -function FFKeyCompareDWord(const Key1, Key2; - aData : PffCompareData) : integer; -begin - Result := FFCheckDescend(aData^.cdAscend, FFCmpDW(DWord(Key1), - DWord(Key2))); -end; -{--------} -function FFKeyCompareI64(const Key1, Key2; - aData : PffCompareData) : integer; -begin - Result := FFCheckDescend(aData^.cdAscend, FFCmpI64(TffInt64(Key1), - TffInt64(Key2))); -end; -{--------} -function FFKeyCompareLongint(const Key1, Key2; aData : PffCompareData) : integer; -begin - Result := FFCheckDescend(aData^.cdAscend, FFCmpI32(longint(Key1), longint(Key2))); -end; -{--------} -function FFKeyCompareBytes(const Key1, Key2; aData : PffCompareData) : integer; -begin - with aData^ do - Result := FFCheckDescend(cdAscend, - FFCmpBytes(@Key1, @Key2, FFForceNonZero(cdPartLen, cdKeyLen))); -end; -{--------} -function FFKeyCompareStr(const Key1, Key2; aData : PffCompareData) : integer; -var - S1 : TffShStr absolute Key1; - S2 : TffShStr absolute Key2; -begin - with aData^ do - if cdNoCase then - Result := FFCheckDescend(cdAscend, FFCmpShStrUC(S1, S2, FFForceNonZero(cdPartLen, cdKeyLen))) - else - Result := FFCheckDescend(cdAscend, FFCmpShStr(S1, S2, FFForceNonZero(cdPartLen, cdKeyLen))); -end; -{--------} -function FFKeyCompareStrZ(const Key1, Key2; aData : PffCompareData) : integer; -var - S1 : array [0..pred(ffcl_MaxKeyLength)] of AnsiChar absolute Key1; - S2 : array [0..pred(ffcl_MaxKeyLength)] of AnsiChar absolute Key2; -begin - with aData^ do - if cdNoCase then - Result := FFCheckDescend(cdAscend, - SysUtils.StrLIComp(S1, S2, FFForceNonZero(cdPartLen, cdKeyLen))) - else - Result := FFCheckDescend(cdAscend, - SysUtils.StrLComp(S1, S2, FFForceNonZero(cdPartLen, cdKeyLen))); -end; -{--------} -function FFKeyCompareAnsiStr(const Key1, Key2; aData : PffCompareData) : integer; -var - S1 : string[255] absolute Key1; - S2 : string[255] absolute Key2; -begin - with aData^ do - if cdNoCase then - Result := FFCheckDescend(cdAscend, - Windows.CompareStringA(LOCALE_USER_DEFAULT, - NORM_IGNORECASE, - PAnsiChar(@S1[1]), - FFMinI(FFForceNonZero(cdPartLen, cdKeyLen), length(S1)), - PAnsiChar(@S2[1]), - FFMinI(FFForceNonZero(cdPartLen, cdKeyLen), length(S2))) - 2) - else - Result := FFCheckDescend(cdAscend, - Windows.CompareStringA(LOCALE_USER_DEFAULT, 0, - PAnsiChar(@S1[1]), - FFMinI(FFForceNonZero(cdPartLen, cdKeyLen), length(S1)), - PAnsiChar(@S2[1]), - FFMinI(FFForceNonZero(cdPartLen, cdKeyLen), length(S2))) - 2); -end; -{--------} -function FFKeyCompareAnsiStrZ(const Key1, Key2; aData : PffCompareData) : integer; -var - S1 : array [0..pred(ffcl_MaxKeyLength)] of AnsiChar absolute Key1; - S2 : array [0..pred(ffcl_MaxKeyLength)] of AnsiChar absolute Key2; -begin - with aData^ do - if cdNoCase then - Result := FFCheckDescend(cdAscend, - Windows.CompareStringA(LOCALE_USER_DEFAULT, - NORM_IGNORECASE, - PAnsiChar(@S1[0]), - FFMinI(FFForceNonZero(cdPartLen, cdKeyLen), StrLen(S1)), - PAnsiChar(@S2[0]), - FFMinI(FFForceNonZero(cdPartLen, cdKeyLen), StrLen(S2))) - 2) - else - Result := FFCheckDescend(cdAscend, - Windows.CompareStringA(LOCALE_USER_DEFAULT, 0, - PAnsiChar(@S1[0]), - FFMinI(FFForceNonZero(cdPartLen, cdKeyLen), StrLen(S1)), - PAnsiChar(@S2[0]), - FFMinI(FFForceNonZero(cdPartLen, cdKeyLen), StrLen(S2))) - 2); -end; -{--------} -function FFKeyCompareWideChar(const Key1, Key2; aData : PffCompareData) : integer; -var - S1 : WideChar absolute Key1; - S2 : WideChar absolute Key2; -begin - if aData^.cdNoCase then - Result := FFCheckDescend(aData^.cdAscend, - Windows.CompareStringW - (LOCALE_USER_DEFAULT, - NORM_IGNORECASE + SORT_STRINGSORT, - PWideChar(@S1), 1, - PWideChar(@S2), 1) - 2) - else - Result := FFCheckDescend(aData^.cdAscend, - Windows.CompareStringW - (LOCALE_USER_DEFAULT, SORT_STRINGSORT, - PWideChar(@S1), 1, - PWideChar(@S2), 1) - 2); -end; -{--------} -function FFKeyCompareWideStr(const Key1, Key2; aData : PffCompareData) : integer; -var - S1 : array [0..pred(ffcl_MaxKeyLength div 2)] of WideChar absolute Key1; - S2 : array [0..pred(ffcl_MaxKeyLength div 2)] of WideChar absolute Key2; -begin - with aData^ do - if cdNoCase then - Result := FFCheckDescend( - cdAscend, - Windows.CompareStringW(LOCALE_USER_DEFAULT, - NORM_IGNORECASE + SORT_STRINGSORT, - PWideChar(@S1[0]), - FFMinI(FFForceNonZero(cdPartLen, cdKeyLen), lstrlenW(S1)), - PWideChar(@S2[0]), - FFMinI(FFForceNonZero(cdPartLen, cdKeyLen), lstrlenW(S2))) - 2) - else - Result := FFCheckDescend( - cdAscend, - Windows.CompareStringW(LOCALE_USER_DEFAULT, SORT_STRINGSORT, - PWideChar(@S1[0]), - FFMinI(FFForceNonZero(cdPartLen, cdKeyLen), lstrlenW(S1)), - PWideChar(@S2[0]), - FFMinI(FFForceNonZero(cdPartLen, cdKeyLen), lstrlenW(S2))) - 2); -end; -{====================================================================} - - -end. diff --git a/components/flashfiler/sourcelaz/ffsrixhl.pas b/components/flashfiler/sourcelaz/ffsrixhl.pas deleted file mode 100644 index a1f196826..000000000 --- a/components/flashfiler/sourcelaz/ffsrixhl.pas +++ /dev/null @@ -1,263 +0,0 @@ -{*********************************************************} -{* FlashFiler: Index helper objects for composite indices*} -{*********************************************************} - -(* ***** 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 - * Thorsten Engler. - * - * Portions created by the Initial Developer are Copyright (C) 2000-2002 - * the Initial Developer. All Rights Reserved. - * Used with permisson. - * - * Contributor(s): - * - * ***** END LICENSE BLOCK ***** *) - -{$I ffdefine.inc} - -unit ffsrixhl; - -interface - -uses - Windows, - SysUtils, - Classes, - ffconst, - ffllbase, - ffsrmgr, - ffllexcp, - ffsrintf, - ffsrbase; - -type - TffSrIndexHelper = class(TffUCStrListItem) - protected {private} - ihFieldTypes: TffFieldTypes; - public - class procedure Register(const aName : TffShStr; - aFieldTypes: TffFieldTypes; - const aParams : array of const); - {-creates an instance of this object and adds it to the internal list} - class procedure Unregister; - {-removes all IndexHelpers of this ClassType from the internal list} - class function FindHelper(const aName : TffShStr; - aFieldType: TffFieldType) - : TffSrIndexHelper; - {-searches the internal list for a helper with the specified name - and checks if the fieldtype is supported by that helper} - - procedure Initialize(const aParams: array of const); virtual; - {-called after the object is created by Register} - procedure BuildKey(const aFieldBuffer; - var aKeyBuffer; - aFieldDesc: PffFieldDescriptor; - aLenToUse: Integer); virtual; - {-builds the key for a specific field - aLenToUse > 0 means a partial string field is required} - function CompareKey(const Key1, - Key2; - aFieldDesc: PffFieldDescriptor; - aLenToUse : Integer; - aNoCase : Boolean) - : Integer; virtual; - {-compares the keys for a specific field - aLenToUse > 0 means a partial string field is required} - - property FieldTypes : TffFieldTypes - {-field types supported by this index helper} - read ihFieldTypes; - end; - - TffSrNumbersOnlyIH = class(TffSrIndexHelper) - public - procedure BuildKey(const aFieldBuffer; - var aKeyBuffer; - aFieldDesc: PffFieldDescriptor; - aLenToUse: Integer); override; - end; - - { Use the following to pass around arrays of index helpers. } - PffIndexHelperArray = ^TffIndexHelperArray; - TffIndexHelperArray = array[0..ffcl_MaxIndexFlds] of TffSrIndexHelper; - -{ Pre-defined helper names } -const - ffc_ihlpNumbersOnly = 'NumbersOnly'; - -implementation - -uses - TypInfo, - fftbbase; - -var - _HelperList : TffThreadList; - -{===TffSrIndexHelper=================================================} -class procedure TffSrIndexHelper.Register(const aName : TffShStr; - aFieldTypes: TffFieldTypes; - const aParams : array of const); -var - Helper: TffSrIndexHelper; -begin - _HelperList.BeginWrite; - try - Helper := Create(aName); - if not _HelperList.Insert(Helper) then begin - Helper.Free; - FFRaiseException(EffServerException, ffStrResGeneral, - fferrIxHlprRegistered, [aName]); - end else try - Helper.ihFieldTypes := aFieldTypes; - Helper.Initialize(aParams); - except - Helper.Free; - raise; - end; - finally - _HelperList.EndWrite; - end; -end; -{--------} -class procedure TffSrIndexHelper.Unregister; -var - i : Integer; -begin - if not Assigned(_HelperList) then - Exit; - _HelperList.BeginWrite; - try - for i := Pred(_HelperList.Count) downto 0 do - with _HelperList.Items[i] do - if (ClassType = Self) or ClassType.InheritsFrom(Self) then - Free; - finally - _HelperList.EndWrite; - end; -end; -{--------} -class function TffSrIndexHelper.FindHelper(const aName : TffShStr; - aFieldType: TffFieldType) - : TffSrIndexHelper; -var - i: Integer; -begin - _HelperList.BeginRead; - try - i := _HelperList.Index(aName); - if i < 0 then - FFRaiseException(EffServerException, ffStrResGeneral, - fferrIxHlprNotReg, [aName]); - Result := TffSrIndexHelper(_HelperList.Items[i]); - if not (aFieldType in Result.ihFieldTypes) then - FFRaiseException(EffServerException, ffStrResGeneral, - fferrIxHlprNotSupp, - [aName, GetEnumName(TypeInfo(TffFieldType), ord(aFieldType))]); - finally - _HelperList.EndRead; - end; -end; -{--------} -procedure TffSrIndexHelper.Initialize(const aParams: array of const); -begin - { May be overriden by descendant classes for custom initialization. } -end; -{--------} -procedure TffSrIndexHelper.BuildKey(const aFieldBuffer; - var aKeyBuffer; - aFieldDesc: PffFieldDescriptor; - aLenToUse: Integer); -begin - if aLenToUse<0 then - Move(aFieldBuffer, aKeyBuffer, aFieldDesc^.fdLength) - else with aFieldDesc^ do begin - if (fdType = fftShortString) or - (fdType = fftShortAnsiStr) then begin - Move(aFieldBuffer, aKeyBuffer, aLenToUse+1); - Byte(aKeyBuffer) := aLenToUse; - end - else - Move(aFieldBuffer, aKeyBuffer, aLenToUse); - end; -end; -{--------} -function TffSrIndexHelper.CompareKey(const Key1, - Key2; - aFieldDesc: PffFieldDescriptor; - aLenToUse : Integer; - aNoCase : Boolean) - : Integer; -begin - with aFieldDesc^ do - if aLenToUse < 0 then - Result := FFKeyCompareField(Key1, Key2, fdType, fdLength, aNoCase) - else - Result := FFKeyCompareField(Key1, Key2, fdType, aLenToUse, aNoCase); -end; -{====================================================================} - -{===TffSrNumbersOnlyIH================================================} -procedure TffSrNumbersOnlyIH.BuildKey(const aFieldBuffer; - var aKeyBuffer; - aFieldDesc: PffFieldDescriptor; - aLenToUse: Integer); -var - Source : TffShStr absolute aFieldBuffer; - Target : TffShStr absolute aKeyBuffer; - i : Integer; -begin - if aLenToUse < 0 then - aLenToUse := aFieldDesc^.fdUnits; - Target := ''; - for i:= 1 to Length(Source) do - //#254 is allowed for setting "123*" type of ranges... - if Source[i] in ['0'..'9', #254] then begin - Target := Target + Source[i]; - if Length(Target) >= aLenToUse then - Exit; - end; -end; -{====================================================================} - -initialization - _HelperList := TffThreadList.Create; - TffSrIndexHelper.Register - ('', - [fftBoolean..fftDateTime, fftByteArray..fftWideString], - {$IFDEF DCC4OrLater} - []); - {$ELSE} - ['']); - {$ENDIF} - - - TffSrNumbersOnlyIH.Register(ffc_ihlpNumbersOnly, - [fftShortString, fftShortAnsiStr], - {$IFDEF DCC4OrLater} - []); - {$ELSE} - ['']); - {$ENDIF} - -finalization - TffSrNumbersOnlyIH.Unregister; - TffSrIndexHelper.Unregister; - _HelperList.Free; - _HelperList:=nil; -end. diff --git a/components/flashfiler/sourcelaz/ffsrjour.pas b/components/flashfiler/sourcelaz/ffsrjour.pas deleted file mode 100644 index 695db285e..000000000 --- a/components/flashfiler/sourcelaz/ffsrjour.pas +++ /dev/null @@ -1,314 +0,0 @@ -{*********************************************************} -{* Journal Transaction Recovery *} -{*********************************************************} - -(* ***** 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 ffsrjour; - -interface - -uses - ffllbase, - ffsrbase, - fflleng, {!!.13} - uFFSRJrn; {!!.13} - -type - TffRecoveryClass = class of TffBaseRecoveryEngine; - - TffBaseRecoveryEngine = class(TffObject) - protected - public - procedure Check(anEngine : TffBaseServerEngine); virtual; abstract; - { Use this method to check each database for failsafe transactions - that were written to disk but not fully applied to the table(s).} - end; - - TffRecoveryEngine = class(TffBaseRecoveryEngine) - protected - procedure reWritePages(aJnlFile : PffFileInfo; Commit : Boolean); -{Begin !!.13} - function reReportJournalState( JournalState : TJournalState; - Alias, Path, FileName, - ExceptionString : string): Boolean; virtual; -{End !!.13} - public - procedure Check(anEngine : TffBaseServerEngine); override; - { Use this method to check each database for failsafe transactions - that were written to disk but not fully applied to the table(s). - - Requirements: The server engine must have already established its list - of aliases. The recovery engine scans through the list of aliases. } - end; - -var - FFRecoveryClass : TffRecoveryClass = TffRecoveryEngine; - -implementation - -uses - classes, - controls, - dialogs, - forms, - sysutils, - ffconst, - ffllexcp, - ffsrbde, - ffsreng, - ffsrcfg, - ffsrcvex; {!!.13} - -{===TffRecoveryEngine================================================} -procedure TffRecoveryEngine.Check(anEngine : TffBaseServerEngine); -var - aAliasItem : PffAliasDescriptor; - aClientID : TffClientID; - aHash : TffWord32; - aList : TList; - aJnlFile : PffFileInfo; - aResult : TffResult; - Commit : Boolean; - FindRes : Integer; - Hdr : TffJournalFileHeader; - iAlias : Integer; - iJournal : Integer; - JournalList : TffStringList; - SearchMask : TffPath; - SearchRec : TffSearchRec; -begin - JournalList := TffStringList.Create; - aList := TList.Create; - try - { Add a client session to the server engine. } - aResult := anEngine.ClientAdd(aClientID, '', ffc_AdminUserID, 1000, aHash); - try - if aResult <> DBIERR_NONE then - FFRaiseExceptionNoData(EffException, ffStrResServer, aResult); - { Note: Information will have already been logged. We are simply - raising the exception to make sure that somebody notices. } - - { Get the list of aliases from the server engine. } - aResult := anEngine.RecoveryAliasList(aList, aClientID); - if aResult <> DBIERR_NONE then - FFRaiseExceptionNoData(EffException, ffStrResServer, aResult); - { Note: Information will have already been logged. We are simply - raising the exception to make sure that somebody notices. } - - for iAlias := 0 to pred(aList.Count) do begin - - { Get the alias descriptor. } - aAliasItem := aList.Items[iAlias]; - - { Alias name is in aAliasItem^.adAlias, path is in aAliasItem^.adPath. - We could have multiple journal files to process. } - - { Empty the journal list. } - JournalList.Empty; - - { Now, search the alias path for any journal files (*.FF$). } - SearchMask := aAliasItem^.adPath; - if (SearchMask[length(SearchMask)] <> '\') then - FFShStrAddChar(SearchMask, '\'); - FFShStrConcat(SearchMask, '*.'); - FFShStrConcat(SearchMask, ffc_ExtForTrans); - FindRes := FFFindFirst(SearchMask, [ditFile], diaAnyAttr, - SearchRec); - while (FindRes = 0) do begin - JournalList.Insert(SearchRec.srName); - FindRes := FFFindNext(SearchRec); - end; - FFFindClose(SearchRec); - - for iJournal := 0 to pred(JournalList.Count) do begin - try - {allocate the file info} - aJnlFile := FFAllocFileInfo( - FFMakeFullFileName(aAliasItem^.adPath, - ExtractFileName(JournalList[iJournal])), - FFExtractExtension(JournalList[iJournal]), - nil); - try - FFOpenFile(aJnlFile, omReadOnly, smExclusive, False, False); - try - FFReadFileExact(aJnlFile, sizeof(Hdr), Hdr); - if (Hdr.jfhSignature = ffc_SigJnlHeader) then begin - if (Hdr.jfhState = 0) then begin - {incomplete header - show message and then delete the file} -{Begin !!.13} - reReportJournalState(jsIncomplete, - aAliasItem^.adAlias, - aAliasItem^.adPath, - JournalList[iJournal], - ''); -{End !!.13} - end - else begin - {complete header} - try -{Begin !!.13} - - Commit := reReportJournalState(jsComplete, - aAliasItem^.adAlias, - aAliasItem^.adPath, - JournalList[iJournal], - ''); -{End !!.13} - reWritePages(aJnlFile, Commit); - except - on E : Exception do begin - {major problem here - found a valid FF Journal file with - a complete header, and then hit an exception trying to - either commit it or rollback} -{Begin !!.13} - reReportJournalState(jsTrash, - aAliasItem^.adAlias, - aAliasItem^.adPath, - JournalList[iJournal], - E.Message); -{End !!.13} - Application.Terminate; - end; - end; - end; - end - else //Soner I could define here Hacked exception class (like this: type Exception = class(sysutils.Exception) ...) but it isn't needed. - raise Exception.CreateResFmt({$ifdef fpc}PString('Error! Not a valid Databasefile! Code: '+IntToStr(fferrNotAnFFFile)){$else}fferrNotAnFFFile{$endif}, - [JournalList[iJournal]]); - finally - FFCloseFile(aJnlFile); - end; - finally - FFFreeFileInfo(aJnlFile); - end; - FFDeleteFile(FFMakeFullFileName(aAliasItem^.adPath, - JournalList[iJournal])); - except - on E: Exception do begin - {show a message, but don't stop processing...} -{Begin !!.13} - reReportJournalState(jsSkipping, - aAliasItem^.adAlias, - aAliasItem^.adPath, - JournalList[iJournal], - E.Message); -{End !!.13} - end; - end; {try..except} - end; {for iJournal} - end; {for iAlias} - finally - anEngine.ClientRemove(aClientID); - end; - finally - for iAlias := pred(aList.Count) downto 0 do begin - aAliasItem := PffAliasDescriptor(aList.items[iAlias]); - FFFreeMem(aAliasItem, sizeOf(TffAliasDescriptor)); - end; - aList.Free; - JournalList.Free; - end; {try..finally} -end; -{Begin !!.13} -{--------} -function TffRecoveryEngine.reReportJournalState( - JournalState: TJournalState; Alias, Path, Filename, - ExceptionString: String): Boolean; -begin - Result := ShowJournalForm(JournalState, - Alias, - Path, - Filename, - ExceptionString ) = mrOK; -end; -{End !!.13} -{--------} -procedure TffRecoveryEngine.reWritePages(aJnlFile : PffFileInfo; - Commit : Boolean); -var - JFRH : TffJournalFileRecordHeader; - Block : Pointer; - After : Boolean; - TargetFile : PffFileInfo; - tfName : String; - FileSize : TffInt64; - FFHeader : array [0..4] of longint; - TempI64 : TffInt64; -begin - FileSize := FFGetFileSize(aJnlFile); - FFGetZeroMem(Block, ffcl_64k); - try - {as long as we're not at EOF, } - while (ffCmpI64(FFGetPositionFile(aJnlFile), FileSize) <> 0) do begin - {get a record header from the journal file} - FFReadFileExact(aJnlFile, sizeof(JFRH), JFRH); - {read a page into BLOCK} - FFReadFileExact(aJnlFile, JFRH.jfrhBlockSize, Block^); - {deal with the page} - {after images have jfrhBeforeImg = 0} - After := (JFRH.jfrhBeforeImg = 0); - if Commit = After then begin - {Writes after images on commit, before images on rollback} - {allocate the file info} - tfName := StrPas(JFRH.jfrhFileName); - TargetFile := FFAllocFileInfo( - FFMakeFullFileName(FFExtractPath(tfName), - FFExtractFileName(tfName)), - FFExtractExtension(tfName), - nil); - try - FFOpenFile(TargetFile, - omReadWrite, smExclusive, true, False); - try - {check to see whether the target file is encrypted or not} - FFReadFile(TargetFile, sizeof(FFHeader), FFHeader); - TargetFile^.fiEncrypted := FFHeader[4] = 1; - {write the data} - TempI64.iLow := JFRH.jfrhBlockSize; - TempI64.iHigh := 0; - ffI64MultInt(TempI64, JFRH.jfrhBlockNumber, TempI64); - FFWriteEncryptFileExactAt(TargetFile, - TempI64, - JFRH.jfrhBlockSize, - Block^); - finally - FFCloseFile(TargetFile); - end;{try..finally} - finally - FFFreeFileInfo(TargetFile); - end; - end; - end; - finally - FreeMem(Block, ffcl_64k); - end; -end; -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/ffsrlock.pas b/components/flashfiler/sourcelaz/ffsrlock.pas deleted file mode 100644 index bf05b2651..000000000 --- a/components/flashfiler/sourcelaz/ffsrlock.pas +++ /dev/null @@ -1,3143 +0,0 @@ -{*********************************************************} -{* FlashFiler: Database lock 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} - -{.$DEFINE LockLogging} -{$DEFINE UseLockContainerPool} - -unit ffsrlock; - -interface -uses - {$IFDEF LockLogging} - fflllog, - {$ENDIF} - SysUtils, - Classes, - Windows, - Forms, - ffllbase, - ffllthrd, - ffhash, - ffsrbase, - ffsrbde, - ffllexcp, - ffconst; - -resourcestring - ffcLockNone = 'None'; - ffcLockIntentS = 'Intent Shared'; - ffcLockIntentX = 'Intent Exclusive'; - ffcLockShare = 'Share'; - ffcLockSIX = 'Shared Intent Exclusive'; - ffcLockUpdate = 'Update'; - ffcLockExclusive = 'Exclusive'; - {$IFDEF LockLogging} - ffcDurationInstant = 'Instant'; - ffcDurationShort = 'Short'; - ffcDurationCommit = 'Commit'; - ffcRStatusGranted = 'Granted'; - ffcRStatusTimeout = 'Timeout'; - ffcRStatusDeadlock = 'Deadlock'; - ffcRStatusRejected = 'Rejected'; - {$ENDIF} - - -type - { This type is used to signify the type of lock requested, or the mode of - a granted group within the lock manager. - - ffsltNone The resource is not locked. - ffsltIntentS Intent Shared (IS) lock. - ffsltIntentX Intent Exclusive (IX) lock. - ffsltShare Share lock. - ffsltSIX Share Intent Exclusive (SIX) lock. - ffsltUpdate Update lock. This lock is handy when a resource has to - be read with the intent of updating the resource. The - Update lock is granted even if there are other Share locks - on the resource. When the Update lock is granted, it - prevents all other locks from being granted on the - resource. When the resource is to be modified, it must - be converted to an ffsltExclusive lock. - ffsltExclusive Exclusive lock. - } - TffSrLockType = (ffsltNone, ffsltIntentS, ffsltIntentX, ffsltShare, - ffsltSIX, ffsltUpdate, ffsltExclusive); - - - { The result of a lock request. - - fflrsGranted The lock was granted. - fflrsTimeOut The lock request timed out. - fflrsRejected The lock request was rejected. This is typically - returned when the request is for an instant duration - lock and the lock could not be granted. - } - TffLockRequestStatus = (fflrsGranted, fflrsTimeout, fflrsRejected); - - { The status of a lock request within a lock's request queue. - - fflsNone No status. Typically used when the request is first - issued. - fflsGranted The lock has been granted to the request. - fflsWaiting The request is waiting for the lock to be granted. - fflsWaitingConv The request is waiting for a conversion request to be - granted. - } - TffLockStatus = (fflsRejected, fflsGranted, fflsWaiting, fflsWaitingConv); - - TffLockListItem = class(TffListItem) - private - FConversion : Boolean; -{Begin !!.10} - FPrimaryID : TffBaseID; - { The unique ID of the server-side object requesting a lock. The object - may be a client, session, database, or cursor. } - F2ndaryID : TffBaseID; - { F2ndaryID is used for record locks. If it has the value zero then - a cursor associated with database FPrimaryID edited and released the - record. It is okay for a cursor associated with the same database to - lock the record. If non-zero then a cursor associated with database - FPrimaryID currently has the record locked. It is not okay to lock - the record for another cursor associated with the same database. } -{End !!.10} - FLockType : TffSrLockType; - FEvent : TffEvent; - FRefCount : Integer; - FStatus : TffLockStatus; - FTransaction : TffSrTransaction; - protected - public - constructor Create(const aKey : TffBaseID); {!!.10} - {-create the list item; aKey is its access/sort key} - 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 - cursorID } - - property LockType : TffSrLockType - read FLockType write FLockType; -{Begin !!.10} - property PrimaryID : TffBaseID - read FPrimaryID; - property SecondaryID : TffBaseID - read F2ndaryID; -{End !!.10} - property Status : TffLockStatus - read FStatus write FStatus; - property Transaction : TffSrTransaction - read FTransaction write FTransaction; - property Event : TffEvent - read FEvent write FEvent; - property RefCount : Integer - read FRefCount write FRefCount; - property Conversion : Boolean - read FConversion write FConversion; - end; - - TffLockQueue = class(TffQueue) - public - function Peek : TffListItem; - { Retrieve a pointer to the first item in the list } - procedure EnqueuePriority(anItem : TffListItem); - { Queue and item, but place it first in the queue } - end; - - { One TffLockContainer is required for each ResourceID, no two resources - share a LockContainer. TffLockContainer is responsible for maintaining the - following: - - 1. A list of granted lock requests. - 2. A queue of waiting lock requests. - 3. A queue of conversion lock requests. } - TffLockContainer = class(TffThreadList) - protected - FWaitQueue : TffLockQueue; - FWaitConversionQueue : TffLockQueue; - function AddLock(const Granted : Boolean; - const Conditional : Boolean; - LockItem : TffLockListItem) : TffLockStatus; - function LastLock : TffLockListItem; - procedure ProcessQueue; - procedure ProcessLockConversion(const aCursorID : TffCursorID; - aLockListItem : TffLockListItem); - public - constructor Create; override; - destructor Destroy; override; - function IsEmpty : boolean; - procedure RelaxRecordLock(const aDatabaseID : TffCursorID); {!!.10} - procedure ReleaseCursorLock(const aCursorID : TffCursorID; - var aRefCount : Integer); - { Release the specified cursor lock. If the lock's reference count - is greater than one then the reference count is decremented. } - procedure ReleaseCursorLockAll(const aCursorID : TffCursorID); - procedure ReleaseWaitingConversion(const RequestorID : TffBaseID); {!!.10} - procedure ReleaseWaitingLock(const RequestorID : TffBaseID); {!!.10} - function RequestLock(const LockType : TffSrLockType; - const Conditional : Boolean; - const Transaction : TffSrTransaction; - const RequestorID : TffBaseID; {!!.10} - var WaitEvent : TffEvent) : TffLockStatus; -{Begin !!.10} - { Used to request all types of locks excluding record locks. } - function RequestRecLock(const LockType : TffSrLockType; - const Conditional : Boolean; - const Transaction : TffSrTransaction; - const ReqPrimaryID, - ReqSecondaryID : TffBaseID; - var WaitEvent : TffEvent) : TffLockStatus; - { Used to request record locks. } -{End !!.10} -{Begin !!.03} - function SimpleDeadlock : Boolean; - { See if a simple deadlock situation may occur. Assumes that this - method is called only when a) the specified lock container has - granted locks to more than one transaction, b) the specified - Transaction has been granted a share lock, & c) the specified - transaction plans to request an Exclusive lock but has not - submitted the request at the time of this method call. } -{End !!.03} - function SummaryMode : TffSrLockType; - end; - - TffLockManager = class(TffObject) - protected - {$IFDEF LockLogging} - FEventLog : TffEventLog; - {$ENDIF} - FTableLocks : TffThreadHash; - FTransactions : TffThreadList; - FStartWithLock : TffPadlock; {!!.10} - procedure DisposeLockList(Sender : TffBaseHashTable; aData : Pointer); - procedure DisposeRecordLockList(Sender : TffBaseHashTable; aData : Pointer); - procedure ReleaseContentLockAll(Container : TffLockContainer; - Transaction : TffSrTransaction); - - procedure ReleaseRecordLockAll(const ResourceID : TffInt64; - const FI : PffFileInfo; - const Transaction : TffSrTransaction; - const DatabaseID : TffDatabaseID); {!!.10} - { Releases a record lock for a cursor regardless of the record lock's - reference count. - Parameters: - ResourceID - The reference number of the record that was locked. - FI - The file containing the locked record. - Transaction - The transaction in which the record was locked. - CursorID - The cursor locking the record. } - - procedure RelRecLockIterator(aKey : TffInt64; aData : pointer; - const cookie1, cookie2, cookie3 : TffWord32); - { Used to free record locks held by a transaction. } - public - constructor Create; - destructor Destroy; override; - - function AcquireClientLock(const Container : TffLockContainer; - const CursorID : TffCursorID; - const Timeout : TffWord32; - const LockType : TffSrLockType) : TffLockRequestStatus; - { Use this method to obtain client locks on a server table - (e.g., TffTable.LockTable). Container is the table's client lock - container. Cursor is the cursor requesting the lock. } - - function AcquireContentLock(const Container : TffLockContainer; - const ParentTable : TffObject; - const Transaction : TffSrTransaction; - const Conditional : Boolean; - const Timeout : TffWord32; - const LockType : TffSrLockType) : TffLockRequestStatus; - { Use this method to acquire a content lock on a server table for a - transaction. Container is the table's content lock container. - Transaction is the transaction requesting the content lock. } - - function AcquireRecordLock(const ResourceID : TffInt64; - const FI : PffFileInfo; - const LockType : TffSrLockType; - const Conditional : Boolean; - const Timeout : TffWord32; - const Transaction : TffSrTransaction; - const DatabaseID : TffDatabaseID; {!!.10} - const CursorID : TffCursorID) : TffLockRequestStatus; - { CursorID requests a RecordLock of type LockType on ResourceID/FileID - for Duration. } - - function AcquireTableLock(const ResourceID : TffWord32; - const LockType : TffSrLockType; - const Conditional : Boolean; - const Timeout : TffWord32; - const CursorID : TffCursorID) : TffLockRequestStatus; - { CursorID requests a TableLock of type LockType on ResourceID - for Duration. } - - procedure GetWaitingRecordLocks(const ResourceID : TffInt64; - const FI : PffFileInfo; - const Transaction : TffSrTransaction; - var WaitingLocks : TffPointerList); - - function HasClientLock(const Container : TffLockContainer; - const CursorID : TffCursorID) : boolean; - { Returns True if the client has any kind of client lock on the table. } - - function IsContentLockedBy(const Container : TffLockContainer; - const Transaction : TffSrTransaction) : boolean; - { Does the specified transaction have any kind of content lock on the - table? Returns True if the transaction has any kind of content lock. } - - function IsTableLockedBy(const aResourceID : TffWord32; - const aCursorID : TffCursorID; - const aLockType : TffSrLockType) : Boolean; - { Returns True if a lock of the specified type was granted to the - specified cursor. } - - function IsRecordLocked(const aResourceID : TffInt64; - const aFI : PffFileInfo) : Boolean; - { Returns True if the record is locked. Assumption: FF only requests - Exclusive record locks. } - - function TableLockGranted(const ResourceID : Longint) : TffSrLockType; - { Returns the summary mode for table ResourceID. If a lock is not - present, this routine returns ffslNone. } - - function RecordLockGranted(const ResourceID : TffInt64; - const FI : PffFileInfo) : TffSrLockType; - { Returns the summary mode for record ResourceID. If a lock is not - present, this routine returns ffslNone. } - -{Begin !!.10} - procedure RelaxRecordLock(const ResourceID : TffInt64; - const FI : PffFileInfo; - const DatabaseID : TffDatabaseID); - { Called after a successful insert, update, or delete so that another - cursor within the same transaction may obtain a record lock on the - same record. } -{End !!.10} - - procedure ReleaseClientLock(const Container : TffLockContainer; - const CursorID : TffCursorID); - - procedure ReleaseClientLockAll(const Container : TffLockContainer; - const CursorID : TffCursorID); - procedure ReleaseClientW(const Container : TffLockContainer; - const CursorID : TffCursorID); - procedure ReleaseClientWC(const Container : TffLockContainer; - const CursorID : TffCursorID); - - procedure ReleaseContentLock(const Container : TffLockContainer; - const Transaction : TffSrTransaction); - procedure ReleaseContentW(const Container : TffLockContainer; - const Transaction : TffSrTransaction); - procedure ReleaseContentWC(const Container : TffLockContainer; - const Transaction : TffSrTransaction); - - procedure ReleaseRecordLock(const ResourceID : TffInt64; - const FI : PffFileInfo; - const Transaction : TffSrTransaction; - const DatabaseID : TffDatabaseID); {!!.10} - - procedure ReleaseRecordW(const ResourceID : TffInt64; - const FI : PffFileInfo; - const DatabaseID : TffDatabaseID); {!!.10} - - procedure ReleaseRecordWC(const ResourceID : TffInt64; - const FI : PffFileInfo; - const DatabaseID : TffDatabaseID); {!!.10} - - procedure ReleaseTableLock(const ResourceID : TffWord32; - const CursorID : TffCursorID); - - procedure ReleaseTableLockAll(const aResourceID : Longint; - const aCursorID : TffCursorID); - - procedure ReleaseTableW(const ResourceID : TffWord32; - const CursorID : TffCursorID); - - procedure ReleaseTableWC(const ResourceID : TffWord32; - const CursorID : TffCursorID); - - procedure ReleaseTransactionLocks(const Transaction : TffSrTransaction; - const RecordsOnly : boolean); - { Call this method when committing a transaction. Transaction is the - transaction whose locks are to be freed. If only record locks are to - be freed, set RecordsOnly to True. If both content and record locks - are to be freed, set RecordsOnly to False. } - -{Begin !!.10} - property StartWithLock : TffPadlock read FStartWithLock; - { Used by the TffServerEngine.TransactionStartWith method. } -{End !!.10} - - end; - - { This class tracks what record locks and content locks have been acquired - by a transaction over the course of the transaction's life. Each - transaction has its own TffTransContainer. - - Only the thread carrying out an operation in the context of the - transaction will access the transaction's TffTransContainer therefore - the TffTransContainer does not need to be threadsafe. - - Each TffTransContainer contains a list of content locks. Each content - "lock" is a reference to the TffLockContainer of a TffSrTable. A lock - is added to the TffLockContainer when the transaction is granted a content - lock. The list of content locks in this class allows us to quickly - reference the table-specific lock containers when removing the - content locks on a per-transaction basis. - - Each element in the list of content locks not only points to a table's - lock container but the element's ExtraData item is also a reference to - the table itself. } - TffTransContainer = class(TffListItem) - protected - FContentLocks : TffList; - { List of } - FLockManager : TffLockManager; - FRecordLocks : TffList; - FTransaction : TffSrTransaction; - - procedure AddContentLock(Container : TffLockContainer; - ParentTable : TffObject; - LockType : TffSrLockType); - procedure AddRecordLock(const FI : PffFileInfo; - const CursorID : TffCursorID; - const ResourceID : TffInt64); - procedure RemoveContentLock(Container : TffLockContainer); - procedure RemoveRecordLock(const FI : PffFileInfo; - const ResourceID : TffInt64); - function tcGetContentCount : Longint; - function tcGetContentContainer(const aInx : Longint) : TffLockContainer; - function tcGetContentLockType(const aInx : Longint) : TffSrLockType; - function tcGetContentTable(const aInx : Longint) : TffObject; - function tcGetFileCount : Longint; - function tcGetFiles(const aInx : Longint) : TffWord32ListItem; - - public - constructor Create(const aKey : TffSrTransaction); - { Create the list item; aKey is its access/sort key. } - - destructor Destroy; override; - - 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. } - - function TableContentLockType(Container : TffLockContainer) : TffSrLockType; - { Returns the type of lock held by the transaction on a table's content. - Container is the table's lock container. If the transaction does not - have a content lock for the table then this function returns - ffsltNone. } - - property ContentCount : Longint - read tcGetContentCount; - { Number of tables for which the transaction has been granted a - content lock. } - - property ContentContainer[const aInx : Longint] : TffLockContainer - read tcGetContentContainer; - { Returns the lock container associated with a particular content - lock. aInx is base zero. The upper bound of aInx is - pred(ContentCount). } - - property ContentLockType[const aInx : Longint] : TffSrLockType - read tcGetContentLockType; - { Returns the type of lock held by a transaction on a table's content. - This list is base zero. Use pred(ContentCount) to determine the - upper bound. } - - property ContentTable[const aInx : Longint] : TffObject - read tcGetContentTable; - { Returns the TffSrTable (viewed as a TffObject) at the specified - index. This list is base zero. Use pred(ContentCount) to - determine the upper bound. } - - property FileCount : Longint - read tcGetFileCount; - { Returns the number of files for which the transaction has obtained - record locks. } - - property Files[const aInx : Longint] : TffWord32ListItem - read tcGetFiles; - { Returns the data structure holding record locks for a particular file. - aInx is base zero. The upper bound is pred(FileCount). } - - property LockManager : TffLockManager - read FLockManager write FLockManager; - - property Transaction : TffSrTransaction - read FTransaction write FTransaction; - end; - - function FFMapLockToName(aLockType : TffSrLockType) : string; - { Translates a lock type into a lock name. } - - {$IFDEF LockLogging} - function FFMapRequestStatusToName(aStatus : TffLockRequestStatus) : string; - { Translates a request status type into a name. } - {$ENDIF} -const - ffc_DefaultDeadlockFreq = 5000; - { The default deadlock detection frequency, in milliseconds. A value of - 5000 means deadlock detection will occur every 5 seconds. } - -{Begin !!.01} -{$IFDEF UseLockContainerPool} -type - TffLockContainerPool = class(TObject) - protected - FList : TffPointerList; - FRetainCount : Integer; - FPadLock : TffPadLock; - public - constructor Create(const InitialCount, RetainCount : Integer); - destructor Destroy; override; - procedure Flush; - function Get : TffLockContainer; - procedure Put(const aLockContainer : TffLockContainer); - end; - -var - FFLockContainerPool : TffLockContainerPool; -{$ENDIF} -{End !!.01} - -implementation - -{$IFDEF LockLogging} -var - Log : TffEventLog; -{$ENDIF} - -{$IFDEF LockLogging} -const - { Logging constants } - csResourceID = ' ResourceID : %8d'; - csResourceID64 = ' ResourceID : %8d:%8d'; - csLockContainer = ' LockContainer : %8d'; - csLockType = ' LockType : %s'; - csDuration = ' Duration : %s'; - csTransaction = ' Transaction : %8d'; - csConditional = ' Conditional : %s'; {!!.10} - csCursorID = ' CursorID : %8d'; - csDatabaseID = ' DatabaseID : %8d'; {!!.10} - csTimeout = ' Timeout : %d'; - csFI = ' FI : %8d'; - csLockRequestStatus = ' LRequestStat : %s'; -{$ENDIF} - -const - { Identifies whether or not a requested lock mode is compatible with an - existing (i.e., granted) lock mode. The first dimension of the array - is the granted mode. The second dimension of the array is the requested - mode. } - - ffca_LockCompatibility : array[TffSrLockType, TffSrLockType] of Boolean = - ( {None IntS IntX Share SIX Updt Excl } - {ffsltNone} (true , true , true , true , true , true , true ), - {ffslIntentS} (true , true , true , true , true , false, false), - {ffsltIntentX } (true , true , true , false, false, false, false), - {ffsltShare} (true , true , false, true , false, false, false), - {ffsltSIX} (true , true , false, false, false, false, false), - {ffsltUpdate} (true , false, false, true , false, false, false), - {ffsltExclusive}(true , false, false, false, false, false, false) - ); - - { This lock conversion matrix is used to determine the new lock - type when a lock conversion is necessary. } - - ffca_LockConversion : array[TffSrLockType, TffSrLockType] of TffSrLockType = - ( - {ffsltNone} (ffsltNone, ffsltIntentS, ffsltIntentX, - ffsltShare, ffsltSIX, ffsltUpdate, - ffsltExclusive), - - {ffsltIntentS} (ffsltIntentS, ffsltIntentS, ffsltIntentX, - ffsltShare, ffsltSIX, ffsltUpdate, - ffsltExclusive), - - {ffsltIntentX} (ffsltIntentX, ffsltIntentX, ffsltIntentX, - ffsltSIX, ffsltSIX, ffsltExclusive, - ffsltExclusive), - - {ffsltShare} (ffsltShare, ffsltShare, ffsltSIX, - ffsltShare, ffsltSIX, ffsltUpdate, - ffsltExclusive), - - {ffsltSIX} (ffsltSIX, ffsltSIX, ffsltSIX, - ffsltSIX, ffsltSIX, ffsltSIX, - ffsltExclusive), - - {ffsltUpdate} (ffsltUpdate, ffsltUpdate, ffsltExclusive, - ffsltUpdate, ffsltSIX, ffsltUpdate, - ffsltExclusive), - - {ffsltExclusive} (ffsltExclusive, ffsltExclusive, ffsltExclusive, - ffsltExclusive, ffsltExclusive, ffsltExclusive, - ffsltExclusive) - ); - -type - TffWaitForListItem = class(TffIntListItem) - private - FWaitingTrans : TffSrTransaction; - public - property WaitingTrans : TffSrTransaction - Read FWaitingTrans write FWaitingTrans; - end; - -{Begin Move !!.01} -{$IFDEF UseLockContainerPool} -//type -// TffLockContainerPool = class(TObject) -// protected -// FList : TffPointerList; -// FRetainCount : Integer; -// FPadLock : TffPadLock; -// public -// constructor Create(const InitialCount, RetainCount : Integer); -// destructor Destroy; override; -// function Get : TffLockContainer; -// procedure Put(const aLockContainer : TffLockContainer); -// end; - -//var -// FFLockContainerPool : TffLockContainerPool; -{$ENDIF} -{End Move !!.01} - -{===TffLockManager===================================================} -constructor TffLockManager.Create; -begin - inherited Create; - FTableLocks := TffThreadHash.Create(ffc_Size59); - FTableLocks.OnDisposeData := DisposeLockList; - - FTransactions := TffThreadList.Create; - FTransactions.Sorted := True; - - FStartWithLock := TffPadlock.Create; {!!.10} - - {$IFDEF LockLogging} - FEventLog := TffEventLog.Create(nil); - FEventLog.FileName := ExtractFilePath(application.ExeName) + 'FFLOCK.LOG'; - FEventLog.Enabled := True; - FEventLog.WriteStrings(['******************************', - '******************************', - Format('Lock Manager Started: %12D', [GetTickCount])]); - Log := FEventLog; - {$ENDIF} -end; -{--------} -destructor TffLockManager.Destroy; -begin - FTableLocks.Clear; - FTableLocks.Free; - FTableLocks := nil; - - FTransactions.Free; - FTransactions := nil; - - FStartWithLock.Free; {!!.10} - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - Format('Lock Manager Stopped: %12D', [GetTickCount])]); - FEventLog.Free; - {$ENDIF} - - inherited Destroy; -end; -{--------} -function TffLockManager.AcquireClientLock(const Container : TffLockContainer; - const CursorID : TffCursorID; - const Timeout : TffWord32; - const LockType : TffSrLockType) : TffLockRequestStatus; -var - LockStatus : TffLockStatus; - WaitEvent : TffEvent; - {$IFDEF LockLogging} - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - FEventLog.WriteStrings(['', - '========================================', - 'AcquireClientLock.BEGIN', - Format(csLockContainer, [Longint(Container)]), - Format(csCursorID, [CursorID])]); - {$ENDIF} - Result := fflrsGranted; - Container.BeginWrite; - try - { Add the request to the queue. } - LockStatus := Container.RequestLock(LockType, - False, - nil, - CursorID, - WaitEvent); - finally - Container.EndWrite; - end; - - if LockStatus = fflsGranted then - Result := fflrsGranted - else if LockStatus = fflsRejected then - Result := fflrsRejected - else { waiting } - { The lock is now in the queue. At this point we must pause the thread - until the lock is granted. The WaitEvent local var is passed to the - TffLockContainer.RequestLock method. This keeps us from creating - an instance of TffEvent unnecessarily. The container is responsible - for the create operation if it is necessary} - try - try - WaitEvent.WaitFor(Timeout); - Result := fflrsGranted; - except - on E: EffException do begin - if E.ErrorCode = fferrReplyTimeout then - Result := fflrsTimeout - else - Result := fflrsRejected; - if LockStatus = fflsWaiting then - ReleaseClientW(Container, CursorID) - else - ReleaseClientWC(Container, CursorID); - end - else begin - if LockStatus = fflsWaiting then - ReleaseClientW(Container, CursorID) - else - ReleaseClientWC(Container, CursorID); - raise; - end; - end - finally - WaitEvent.Free; - WaitEvent := nil; - end; - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('AcquireClientLock - Time: %12D', [GetTickCount - StartTime]), - Format(csLockContainer, [Longint(Container)]), - Format(csTimeout, [Timeout]), - Format(csCursorID, [CursorID]), - Format(csLockType, [FFMapLockToName(LockType)]), - Format(csLockRequestStatus, [FFMapRequestStatusToName(Result)])]); - {$ENDIF} -end; -{--------} -function TffLockManager.AcquireContentLock(const Container : TffLockContainer; - const ParentTable : TffObject; - const Transaction : TffSrTransaction; - const Conditional : Boolean; - const Timeout : TffWord32; - const LockType : TffSrLockType) : TffLockRequestStatus; -var - aCursorID : TffCursorID; - LockStatus : TffLockStatus; - TransContainer : TffTransContainer; - WaitEvent : TffEvent; - {$IFDEF LockLogging} - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - FEventLog.WriteStrings(['', - '========================================', - 'AcquireContentLock.BEGIN', - Format(csLockContainer, [Longint(Container)]), - Format(csTransaction, [Transaction.TransactionID])]); - {$ENDIF} - Result := fflrsGranted; - aCursorID := TffCursorID(Transaction); - Container.BeginWrite; - try - { Add the request to the queue. } - LockStatus := Container.RequestLock(LockType, Conditional, Transaction, - aCursorID, WaitEvent); - finally - Container.EndWrite; - end; - - if LockStatus = fflsGranted then - Result := fflrsGranted - else if LockStatus = fflsRejected then - Result := fflrsRejected - else { waiting } - { The lock is now in the queue. At this point we must pause the thread - until the lock is granted. The WaitEvent local var is passed to the - TffLockContainer.RequestLock method. This keeps us from creating - an instance of TffEvent unnecessarily. The container is responsible - for the create operation if it is necessary} - try - try - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('AcquireContentLock - Waiting: %d', [aCursorID])]); - {$ENDIF} - WaitEvent.WaitFor(Timeout); - Result := fflrsGranted; - except - on E: EffException do begin - if E.ErrorCode = fferrReplyTimeout then - Result := fflrsTimeout - else - Result := fflrsRejected; - if LockStatus = fflsWaiting then - ReleaseContentW(Container, Transaction) - else - ReleaseContentWC(Container, Transaction); - end - else begin - if LockStatus = fflsWaiting then - ReleaseContentW(Container, Transaction) - else - ReleaseContentWC(Container, Transaction); - raise; - end; - end - finally - WaitEvent.Free; - WaitEvent := nil; - end; - - if Result = fflrsGranted then begin - { Add the new lock to the transaction list. } - FTransactions.BeginWrite; - try - TransContainer := TffTransContainer(Transaction.TransLockContainer); - if not Assigned(TransContainer) then begin - TransContainer := TffTransContainer.Create(Transaction); - TransContainer.LockManager := Self; - Transaction.TransLockContainer := TransContainer; - FTransactions.Insert(TransContainer); - end; - TransContainer.AddContentLock(Container, ParentTable, LockType); - finally - FTransactions.EndWrite; - end; - end; - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('AcquireContentLock - Time: %12D', [GetTickCount - StartTime]), - Format(csLockContainer, [Longint(Container)]), - Format(csTimeout, [Timeout]), - Format(csTransaction, [Transaction.TransactionID]), - Format(csLockType, [FFMapLockToName(LockType)]), - Format(csLockRequestStatus, [FFMapRequestStatusToName(Result)])]); - {$ENDIF} -end; -{--------} -function TffLockManager.AcquireRecordLock(const ResourceID : TffInt64; - const FI : PffFileInfo; - const LockType : TffSrLockType; - const Conditional : Boolean; - const Timeout : TffWord32; - const Transaction : TffSrTransaction; - const DatabaseID : TffDatabaseID; {!!.10} - const CursorID : TffCursorID - ): TffLockRequestStatus; -var - TransContainer : TffTransContainer; - LockContainerList : TffThreadHash64; - LockContainer : TffLockContainer; - LockStatus : TffLockStatus; - WaitEvent : TffEvent; - {$IFDEF LockLogging} - IsCond : string; - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - WaitEvent := nil; - Result := fflrsRejected; - - {$IFDEF LockLogging} - if Transaction = nil then - FEventLog.WriteStrings(['', - '========================================', - Format('AcquireRecordLock BEGIN - Time: %12D', [GetTickCount - StartTime]), - Format(csFI, [FI^.fiHandle]), - Format(csResourceID64, [ResourceID.iLow, ResourceID.iHigh]), - Format(csTransaction, [0]), - Format(csCursorID, [CursorID])]) - else - FEventLog.WriteStrings(['', - '========================================', - Format('AcquireRecordLock BEGIN - Time: %12D', [GetTickCount - StartTime]), - Format(csFI, [FI^.fiHandle]), - Format(csResourceID64, [ResourceID.iLow, ResourceID.iHigh]), - Format(csTransaction, [Transaction.TransactionID]), - Format(csCursorID, [CursorID])]); - {End !!.06} - {$ENDIF} - - { Find the LockContainer List, create one if it does not exist. } - LockContainerList := FI^.fiRecordLocks; - if not Assigned(LockContainerList) then begin - LockContainerList := TffThreadHash64.Create(ffc_Size257); - LockContainerList.OnDisposeData := DisposeLockList; - FI^.fiRecordLocks := LockContainerList; - end; - - { We need write access to the container list before we can find/create - the LockContainer. } - LockContainerList.BeginWrite; - - { Has a lock already been created for this table resource? } - try - { Find the lock container, create one if it does not exist. } - LockContainer := LockContainerList.Get(ResourceID); - if not Assigned(LockContainer) then begin - {$IFDEF UseLockContainerPool} - LockContainer := FFLockContainerPool.Get; - {$ELSE} - LockContainer := TffLockContainer.Create; - {$ENDIF} - - { Add the new lock container to the internal list } - LockContainerList.Add(ResourceID, LockContainer); - end; - - { We need write access to the container before we can queue the lock } - LockContainer.BeginWrite; - finally - LockContainerList.EndWrite; - end; - - try - { We need to add the request to the queue. } - LockStatus := LockContainer.RequestRecLock(LockType, {!!.10} - Conditional, - Transaction, - DatabaseID, {!!.10} - CursorID, - WaitEvent); - finally - LockContainer.EndWrite; - end; - - if LockStatus = fflsGranted then - Result := fflrsGranted - else if LockStatus = fflsRejected then - Result := fflrsRejected - else if (LockStatus = fflsWaiting) then - { The lock is now in the queue. At this point we must pause the thread - until the lock is granted. The WaitEvent local var is passed to the - TffLockContainer.RequestLock method. This keeps us from creating - an instance of TffEvent unnecessarily. The container is responsible - for the create operation if it is necessary} - try - try - {$IFDEF LockLogging} - FEventLog.WriteStrings(['AcquireRecordLock: WaitEvent.WaitFor', - Format(csCursorID, [CursorID])]); - {$ENDIF} - WaitEvent.WaitFor(Timeout); - Result := fflrsGranted; - except - on E: EffException do begin - case E.ErrorCode of - fferrReplyTimeout : Result := fflrsTimeout; - fferrWaitFailed : Result := fflrsRejected; - end; - {$IFDEF LockLogging} - FEventLog.WriteStrings(['AcquireRecordLock: lock request timed out or rejected', - Format(csCursorID, [CursorID])]); - {$ENDIF} - if LockStatus = fflsWaiting then - ReleaseRecordW(ResourceID, FI, DatabaseID) {!!.10} - else - ReleaseRecordWC(ResourceID, FI, DatabaseID); {!!.10} - end - else begin - if LockStatus = fflsWaiting then - ReleaseRecordW(ResourceID, FI, DatabaseID) {!!.10} - else - ReleaseRecordWC(ResourceID, FI, DatabaseID); {!!.10} - raise; - end; - end - finally - {$IFDEF LockLogging} - FEventLog.WriteStrings(['AcquireRecordLock: WaitEvent.Free', - Format(csCursorID, [CursorID])]); - {$ENDIF} - WaitEvent.Free; - WaitEvent := nil; - end; - - if Result = fflrsGranted then begin - { Is a transaction active? } - if assigned(Transaction) then begin - { Yes. Add the new lock to the transaction list. } - FTransactions.BeginWrite; - try - TransContainer := TffTransContainer(Transaction.TransLockContainer); - if not Assigned(TransContainer) then begin - TransContainer := TffTransContainer.Create(Transaction); - TransContainer.LockManager := Self; - Transaction.TransLockContainer := TransContainer; - FTransactions.Insert(TransContainer); - end; - TransContainer.AddRecordLock(FI, DatabaseID, ResourceID); {!!.10} - finally - FTransactions.EndWrite; - end; - end; - end; - - {$IFDEF LockLogging} - if Conditional then - IsCond := 'Yes' - else - IsCond := 'No'; -{Begin !!.06} - if Transaction = nil then - FEventLog.WriteStrings(['', - '========================================', - Format('AcquireRecordLock END - Time: %12D', [GetTickCount - StartTime]), - Format(csFI, [FI^.fiHandle]), - Format(csResourceID64, [ResourceID.iLow, ResourceID.iHigh]), - Format(csLockType, [FFMapLockToName(LockType)]), - Format(csConditional, [isCond]), {!!.10} - Format(csTimeout, [Timeout]), - Format(csTransaction, [0]), - Format(csCursorID, [CursorID]), - Format(csLockRequestStatus, [FFMapRequestStatusToName(Result)])]) - else - FEventLog.WriteStrings(['', - '========================================', - Format('AcquireRecordLock END - Time: %12D', [GetTickCount - StartTime]), - Format(csFI, [FI^.fiHandle]), - Format(csResourceID64, [ResourceID.iLow, ResourceID.iHigh]), - Format(csLockType, [FFMapLockToName(LockType)]), - Format(csConditional, [isCond]), {!!.10} - Format(csTimeout, [Timeout]), - Format(csTransaction, [Transaction.TransactionID]), - Format(csCursorID, [CursorID]), - Format(csLockRequestStatus, [FFMapRequestStatusToName(Result)])]); - {End !!.06} - {$ENDIF} -end; -{--------} -function TffLockManager.AcquireTableLock(const ResourceID : TffWord32; - const LockType : TffSrLockType; - const Conditional : Boolean; - const Timeout : TffWord32; - const CursorID : TffCursorID) : TffLockRequestStatus; -var - LockContainer : TffLockContainer; - LockStatus : TffLockStatus; - WaitEvent : TffEvent; - {$IFDEF LockLogging} - IsCond : string; - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - WaitEvent := nil; - Result := fflrsRejected; - { Has a lock already been created for this table resource? } - FTableLocks.BeginWrite; - try - { Find the lock container, create one if it does not exist. } - LockContainer := FTableLocks.Get(ResourceID); - if not Assigned(LockContainer) then begin - {$IFDEF UseLockContainerPool} - LockContainer := FFLockContainerPool.Get; - {$ELSE} - LockContainer := TffLockContainer.Create; - {$ENDIF} - - { Add the new lock container to the internal list } - FTableLocks.Add(ResourceID, LockContainer); - end; - - { We need write access to the container before we can queue the lock } - LockContainer.BeginWrite; - finally - FTableLocks.EndWrite; - end; - - try - { We need to add the request to the queue. } - LockStatus := LockContainer.RequestLock(LockType, - Conditional, - nil, - CursorID, - WaitEvent); - finally - LockContainer.EndWrite; - end; - - if (LockStatus = fflsWaiting) then - { The lock is now in the queue. At this point we must pause the thread - until the lock is granted. The WaitEvent local var is passed to the - TffLockContainer.RequestLock method. This keeps us from creating - an instance of TffEvent unnecessarily. The container is responsible - for the create operation if it is necessary} - try - try - WaitEvent.WaitFor(Timeout); - Result := fflrsGranted; - except - on E: EffException do begin - case E.ErrorCode of - fferrReplyTimeout : Result := fflrsTimeout; - fferrWaitFailed : Result := fflrsRejected; - end; - if LockStatus = fflsWaiting then - ReleaseTableW(ResourceID, CursorID) - else - ReleaseTableWC(ResourceID, CursorID); - end - else begin - ReleaseTableLock(ResourceID, CursorID); - raise; - end; - end; - finally - WaitEvent.Free; - WaitEvent := nil; - end - else - if LockStatus = fflsGranted then - Result := fflrsGranted - else - Result := fflrsRejected; - {$IFDEF LockLogging} - if Conditional then - isCond := 'Yes' - else - isCond := 'No'; - FEventLog.WriteStrings(['========================================', - Format('AcquireTableLock - Time: %12D', [GetTickCount - StartTime]), - Format(csResourceID, [ResourceID]), - Format(csLockType, [FFMapLockToName(LockType)]), - Format(csConditional, [isCond]), {!!.10} - Format(csTimeout, [Timeout]), - Format(csCursorID, [CursorID]), - Format(csLockRequestStatus, [FFMapRequestStatusToName(Result)])]); - {$ENDIF} -end; -{--------} -procedure TffLockManager.DisposeLockList(Sender: TffBaseHashTable; - aData: Pointer); -var - LockList : TffLockContainer; - Index : Integer; -begin - if Assigned(aData) then begin - LockList := TffLockContainer(aData); - - { Free the items in the list. } - for Index := Pred(LockList.Count) downto 0 do - LockList.DeleteAt(Index); - {$IFDEF UseLockContainerPool} - FFLockContainerPool.Put(LockList); - {$ELSE} - LockList.Free; - {$ENDIF} - end; -end; -{--------} -procedure TffLockManager.DisposeRecordLockList(Sender : TffBaseHashTable; - aData : Pointer); -var - LockList : TffThreadHash; -begin - if Assigned(aData) then begin - LockList := TffThreadHash(aData); - { Free the items in the list. } - LockList.Clear; - LockList.Free; - end; -end; -{--------} -procedure TffLockManager.GetWaitingRecordLocks(const ResourceID : TffInt64; - const FI : PffFileInfo; - const Transaction : TffSrTransaction; - var WaitingLocks : TffPointerList); -var - LockContainerList : TffThreadHash64; - LockContainer : TffLockContainer; - LockIdx : Integer; - LockItem : TffLockListItem; - {$IFDEF LockLogging} - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - { Find the LockContainerList } - LockContainerList := FI^.fiRecordLocks; - if not Assigned(LockContainerList) then Exit; - - LockContainerList.BeginRead; - try - { Find the lock container } - LockContainer := LockContainerList.Get(ResourceID); - if not Assigned(LockContainer) then Exit; - - LockContainer.BeginRead; - try - for LockIdx := 0 to Pred(LockContainer.Count) do begin - LockItem := TffLockListItem(LockContainer.Items[LockIdx]); - if LockItem.Status = fflsWaiting then - WaitingLocks.Append(pointer(LockItem)); - end; - finally - LockContainer.EndRead; - end; - finally - LockContainerList.EndRead; - end; - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('GetWaitingRecordLocks - Time: %12D', [GetTickCount - StartTime]), - Format(csResourceID64, [ResourceID.iLow, ResourceID.iHigh]), - Format(csFI, [FI^.fiHandle]), - Format(csTransaction, [Transaction.TransactionID])]); - {$ENDIF} -end; -{--------} -function TffLockManager.IsRecordLocked(const aResourceID : TffInt64; - const aFI : PffFileInfo): Boolean; -var - LockContainerList : TffThreadHash64; - LockContainer : TffLockContainer; - {$IFDEF LockLogging} - LockStatus : string; - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - Result := False; - - { Find the LockContainerList } - LockContainerList := aFI^.fiRecordLocks; - if not Assigned(LockContainerList) then Exit; - - LockContainerList.BeginRead; - try - { Find the lock container } - LockContainer := LockContainerList.Get(AResourceID); - if not Assigned(LockContainer) then Exit; - Result := (LockContainer.Count > 0); - finally - LockContainerList.EndRead; - end; - - {$IFDEF LockLogging} - if not Result then - LockStatus := 'Not '; - FEventLog.WriteStrings(['', - '========================================', - Format('IsRecordLocked - Time: %12D', [GetTickCount - StartTime]), - Format(csResourceID64, [aResourceID.iLow, aResourceID.iHigh]), - Format(csFI, [aFI^.fiHandle]), - Format(' %sLocked', [LockStatus])]); - {$ENDIF} -end; -{--------} -function TffLockManager.HasClientLock(const Container : TffLockContainer; - const CursorID : TffCursorID) : boolean; -begin - Container.BeginRead; - try - Result := (Container.fflIndexPrim(CursorID) <> -1); - finally - Container.EndRead; - end; -end; -{--------} -function TffLockManager.IsContentLockedBy(const Container : TffLockContainer; - const Transaction : TffSrTransaction) : boolean; -begin - Container.BeginRead; - try - Result := (Container.fflIndexPrim(TffCursorID(Transaction)) <> -1); - finally - Container.EndRead; - end; -end; -{--------} -function TffLockManager.IsTableLockedBy(const AResourceID : TffWord32; - const aCursorID : TffCursorID; - const ALockType : TffSrLockType): Boolean; -var - ItemIndex : Longint; - LockContainer : TffLockContainer; - {$IFDEF LockLogging} - LockStatus : string; - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - Result := False; - FTableLocks.BeginRead; - try - { Find the lock container } - LockContainer := FTableLocks.Get(AResourceID); - if not Assigned(LockContainer) then Exit; - - LockContainer.BeginRead; - try - with LockContainer do begin - ItemIndex := fflIndexPrim(aCursorID); - if ItemIndex <> -1 then - with TffLockListItem(Items[ItemIndex]) do - Result := ALockType = LockType; - end; - finally - LockContainer.EndRead; - end; - - finally - FTableLocks.EndRead; - end; - {$IFDEF LockLogging} - if not Result then - LockStatus := 'Not '; - FEventLog.WriteStrings(['', - '========================================', - Format('IsTableLockedBy - Time: %12D', [GetTickCount - StartTime]), - Format(csResourceID, [aResourceID]), - Format(csCursorID, [aCursorID]), - Format(csLockType, [FFMapLockToName(aLockType)]), - Format(' %sLocked', [LockStatus])]); - {$ENDIF} -end; -{--------} -function TffLockManager.RecordLockGranted(const ResourceID : TffInt64; - const FI : PffFileInfo): TffSrLockType; -var - LockContainerList : TffThreadHash64; - LockContainer : TffLockContainer; - {$IFDEF LockLogging} - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - Result := ffsltNone; - - { Find the LockContainerList } - LockContainerList := FI^.fiRecordLocks; - if not Assigned(LockContainerList) then Exit; - - LockContainerList.BeginRead; - try - { Find the lock container } - LockContainer := LockContainerList.Get(ResourceID); - if not Assigned(LockContainer) then Exit; - - LockContainer.BeginRead; - try - Result := LockContainer.SummaryMode; - finally - LockContainer.EndRead; - end; - - { Remove the lock container if it is empty } - if LockContainer.Count = 0 then - LockContainerList.Remove(ResourceID); - - finally - LockContainerList.EndRead; - end; - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('RecordLockGranted - Time: %12D', [GetTickCount - StartTime]), - Format(csResourceID64, [ResourceID.iLow, ResourceID.iHigh]), - Format(csFI, [FI^.fiHandle]), - Format(csLockType, [FFMapLockToName(Result)])]); - {$ENDIF} -end; -{Begin !!.10} -{--------} -procedure TffLockManager.RelaxRecordLock(const ResourceID : TffInt64; - const FI : PffFileInfo; - const DatabaseID : TffDatabaseID); -var - LockContainerList : TffThreadHash64; - LockContainer : TffLockContainer; - {$IFDEF LockLogging} - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - { Find the LockContainerList } - LockContainerList := FI^.fiRecordLocks; - if not Assigned(LockContainerList) then Exit; - - LockContainerList.BeginWrite; - try - { Find the lock container } - LockContainer := LockContainerList.Get(ResourceID); - if not Assigned(LockContainer) then Exit; - - LockContainer.BeginWrite; - try - LockContainer.RelaxRecordLock(DatabaseID); - finally - LockContainer.EndWrite; - end; - - finally - LockContainerList.EndWrite; - end; - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('RelaxRecordLock - Time: %12D', [GetTickCount - StartTime]), - Format(csResourceID64, [ResourceID.iLow, ResourceID.iHigh]), - Format(csFI, [FI^.fiHandle]), - Format(csDatabaseID, [DatabaseID])]); - {$ENDIF} -end; -{End !!.10} -{--------} -procedure TffLockManager.ReleaseClientLock(const Container : TffLockContainer; - const CursorID : TffCursorID); -var - RefCount : Integer; - {$IFDEF LockLogging} - StartTime : DWORD; - {$ENDIF} -begin - - Assert(assigned(Container)); - - {$IFDEF LockLogging} - StartTime := GetTickCount; - FEventLog.WriteStrings(['', - '========================================', - 'ReleaseClientLock.BEGIN', - Format(csLockContainer, [Longint(Container)]), - Format(csCursorID, [CursorID])]); - {$ENDIF} - - Container.BeginWrite; - try - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - 'ReleaseClientLock.ReleaseCursorLock pre', - Format(csLockContainer, [Longint(Container)]), - Format(csCursorID, [CursorID])]); - {$ENDIF} - Container.ReleaseCursorLock(CursorID, RefCount); - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - 'ReleaseClientLock.ReleaseCursorLock post', - Format(csLockContainer, [Longint(Container)]), - Format(csCursorID, [CursorID])]); - {$ENDIF} - finally - Container.EndWrite; - end; - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('ReleaseClientLock - Time: %12D', [GetTickCount - StartTime]), - Format(csLockContainer, [Longint(Container)]), - Format(csCursorID, [CursorID])]); - {$ENDIF} -end; -{--------} -procedure TffLockManager.ReleaseClientLockAll(const Container : TffLockContainer; - const CursorID : TffCursorID); -{$IFDEF LockLogging} -var - StartTime : DWORD; -{$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - - Container.BeginWrite; - try - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - 'ReleaseClientLockAll', - Format(csCursorID, [CursorID]), - Format(csLockContainer, [Longint(Container)]), - Format('# container items: %d',[Container.Count])]); - {$ENDIF} - Container.ReleaseCursorLockAll(CursorID); - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - 'ReleaseClientLockAll - after purge', - Format(csCursorID, [CursorID]), - Format('# container items: %d',[Container.Count])]); - {$ENDIF} - finally - Container.EndWrite; - end; - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('ReleaseClientLockAll - Time: %12D', [GetTickCount - StartTime]), - Format(csCursorID, [CursorID]), - Format(csLockContainer, [Longint(Container)])]); - {$ENDIF} -end; -{--------} -procedure TffLockManager.ReleaseClientW(const Container : TffLockContainer; - const CursorID : TffCursorID); -begin - Assert(assigned(Container)); - Container.BeginWrite; - try - Container.ReleaseWaitingLock(CursorID); - finally - Container.EndWrite; - end; -end; -{--------} -procedure TffLockManager.ReleaseClientWC(const Container : TffLockContainer; - const CursorID : TffCursorID); -begin - Assert(assigned(Container)); - Container.BeginWrite; - try - Container.ReleaseWaitingConversion(CursorID); - finally - Container.EndWrite; - end; -end; -{--------} -procedure TffLockManager.ReleaseContentLock(const Container : TffLockContainer; - const Transaction : TffSrTransaction); -var - RefCount : Integer; - {$IFDEF LockLogging} - StartTime : DWORD; - {$ENDIF} - TransContainer : TffTransContainer; -begin - - Assert(assigned(Container)); - Assert(assigned(Transaction)); - - {$IFDEF LockLogging} - StartTime := GetTickCount; - FEventLog.WriteStrings(['', - '========================================', - 'ReleaseContentLock.BEGIN', - Format(csLockContainer, [Longint(Container)]), - Format(csTransaction, [Transaction.TransactionID])]); - {$ENDIF} - - Container.BeginWrite; - try - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - 'ReleaseContentLock.ReleaseCursorLock pre', - Format(csLockContainer, [Longint(Container)]), - Format(csTransaction, [Transaction.TransactionID])]); - {$ENDIF} - Container.ReleaseCursorLock(TffCursorID(Transaction), RefCount); - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - 'ReleaseContentLock.ReleaseCursorLock post', - Format(csLockContainer, [Longint(Container)]), - Format(csTransaction, [Transaction.TransactionID])]); - {$ENDIF} - { Remove the lock from the transaction list } - if RefCount = 0 then - { Is a transaction active? } - if assigned(Transaction) then begin - FTransactions.BeginWrite; - try - TransContainer := TffTransContainer(Transaction.TransLockContainer); - if Assigned(TransContainer) then - TransContainer.RemoveContentLock(Container); - finally - FTransactions.EndWrite; - end; - end; - finally - Container.EndWrite; - end; - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('ReleaseContentLock - Time: %12D', [GetTickCount - StartTime]), - Format(csLockContainer, [Longint(Container)]), - Format(csTransaction, [Transaction.TransactionID])]); - {$ENDIF} -end; -{--------} -procedure TffLockManager.ReleaseContentLockAll(Container : TffLockContainer; - Transaction : TffSrTransaction); -{$IFDEF LockLogging} -var - StartTime : DWORD; -{$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - - Container.BeginWrite; - try - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - 'ReleaseContentLockAll', - Format(csTransaction, [Longint(Transaction)]), - Format(csLockContainer, [Longint(Container)]), - Format('# container items: %d',[Container.Count])]); - {$ENDIF} - Container.ReleaseCursorLockAll(TffCursorID(Transaction)); - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - 'ReleaseContentLockAll - after purge', - Format('# container items: %d',[Container.Count])]); - {$ENDIF} - finally - Container.EndWrite; - end; - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('ReleaseContentLockAll - Time: %12D', [GetTickCount - StartTime]), - Format(csTransaction, [Longint(Transaction)]), - Format(csLockContainer, [Longint(Container)])]); - {$ENDIF} -end; -{--------} -procedure TffLockManager.ReleaseContentW(const Container : TffLockContainer; - const Transaction : TffSrTransaction); -begin - - Assert(assigned(Container)); - Assert(assigned(Transaction)); - - Container.BeginWrite; - try - Container.ReleaseWaitingLock(TffCursorID(Transaction)); - finally - Container.EndWrite; - end; -end; -{--------} -procedure TffLockManager.ReleaseContentWC(const Container : TffLockContainer; - const Transaction : TffSrTransaction); -begin - - Assert(assigned(Container)); - Assert(assigned(Transaction)); - - Container.BeginWrite; - try - Container.ReleaseWaitingConversion(TffCursorID(Transaction)); - finally - Container.EndWrite; - end; -end; -{--------} -procedure TffLockManager.ReleaseRecordLock(const ResourceID : TffInt64; - const FI : PffFileInfo; - const Transaction : TffSrTransaction; - const DatabaseID : TffDatabaseID); {!!.10} -var - TransContainer : TffTransContainer; - LockContainerList : TffThreadHash64; - LockContainer : TffLockContainer; - RefCount : Integer; - {$IFDEF LockLogging} - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - { Find the LockContainerList } - LockContainerList := FI^.fiRecordLocks; - if not Assigned(LockContainerList) then Exit; - - LockContainerList.BeginWrite; - try - { Find the lock container } - LockContainer := LockContainerList.Get(ResourceID); - if not Assigned(LockContainer) then Exit; - - LockContainer.BeginWrite; - try - LockContainer.ReleaseCursorLock(DatabaseID, RefCount); {!!.10} - finally - LockContainer.EndWrite; - end; - - { Remove the lock from the transaction list } - if RefCount = 0 then - { Is a transaction active? } - if assigned(Transaction) then begin - FTransactions.BeginWrite; - try - TransContainer := TffTransContainer(Transaction.TransLockContainer); - if Assigned(TransContainer) then - TransContainer.RemoveRecordLock(FI, ResourceID); - finally - FTransactions.EndWrite; - end; - end; - - { Remove the lock container if it is empty } - if LockContainer.IsEmpty then - LockContainerList.Remove(ResourceID); - - finally - LockContainerList.EndWrite; - end; - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('ReleaseRecordLock - Time: %12D', [GetTickCount - StartTime]), - Format(csResourceID64, [ResourceID.iLow, ResourceID.iHigh]), - Format(csFI, [FI^.fiHandle]), - Format(csTransaction, [Transaction.TransactionID]), - Format(csDatabaseID, [DatabaseID])]); - {$ENDIF} -end; -{--------} -procedure TffLockManager.ReleaseRecordLockAll(const ResourceID : TffInt64; - const FI : PffFileInfo; - const Transaction : TffSrTransaction; - const DatabaseID : TffDatabaseID); {!!.10} -var - LockContainerList : TffThreadHash64; - LockContainer : TffLockContainer; - {$IFDEF LockLogging} - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - { We might need to release the lock container, and lock container list so - we get request full access to the list } - { Find the LockContainerList } - LockContainerList := FI^.fiRecordLocks; - - { Find the lock container } - LockContainer := LockContainerList.Get(ResourceID); - if not Assigned(LockContainer) then Exit; - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('ReleaseRecordLockAll - Time: %12D', [GetTickCount - StartTime]), - Format(csResourceID64, [ResourceID.iLow, ResourceID.iHigh]), - Format(csFI, [FI^.fiHandle]), - Format(csTransaction, [Transaction.TransactionID]), - Format(csDatabaseID, [DatabaseID])]); - {$ENDIF} - - LockContainer.BeginWrite; - try - LockContainer.ReleaseCursorLockAll(DatabaseID); {!!.10} - finally - LockContainer.EndWrite; - end; - - { Remove the lock container if it is empty } - if LockContainer.Count = 0 then - LockContainerList.Remove(ResourceID); - -end; -{--------} -procedure TffLockManager.ReleaseRecordW(const ResourceID : TffInt64; - const FI : PffFileInfo; - const DatabaseID : TffDatabaseID); {!!.10} -var - LockContainerList : TffThreadHash64; - LockContainer : TffLockContainer; -begin - { Find the LockContainerList } - LockContainerList := FI^.fiRecordLocks; - if not Assigned(LockContainerList) then Exit; - - LockContainerList.BeginWrite; - try - { Find the lock container } - LockContainer := LockContainerList.Get(ResourceID); - if not Assigned(LockContainer) then Exit; - - LockContainer.BeginWrite; - try - LockContainer.ReleaseWaitingLock(DatabaseID); {!!.10} - finally - LockContainer.EndWrite; - end; - - finally - LockContainerList.EndWrite; - end; - -end; -{--------} -procedure TffLockManager.ReleaseRecordWC(const ResourceID : TffInt64; - const FI : PffFileInfo; - const DatabaseID : TffDatabaseID); { !!.10} -var - LockContainerList : TffThreadHash64; - LockContainer : TffLockContainer; -begin - { Find the LockContainerList } - LockContainerList := FI^.fiRecordLocks; - if not Assigned(LockContainerList) then Exit; - - LockContainerList.BeginWrite; - try - { Find the lock container } - LockContainer := LockContainerList.Get(ResourceID); - if not Assigned(LockContainer) then Exit; - - LockContainer.BeginWrite; - try - LockContainer.ReleaseWaitingConversion(DatabaseID); {!!.10} - finally - LockContainer.EndWrite; - end; - - finally - LockContainerList.EndWrite; - end; - -end; -{--------} -procedure TffLockManager.ReleaseTableLock(const ResourceID : TffWord32; - const CursorID : TffCursorID); - -var - LockContainer : TffLockContainer; - RefCount : Integer; - {$IFDEF LockLogging} - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - { We might need to release the lock container, so we request full access - to the list } - FTableLocks.BeginWrite; - try - { Find the lock container } - LockContainer := FTableLocks.Get(ResourceID); - - if not Assigned(LockContainer) then - Exit; - - LockContainer.BeginWrite; - try - LockContainer.ReleaseCursorLock(CursorID, RefCount); - finally - LockContainer.EndWrite; - end; - - finally - FTableLocks.EndWrite; - end; - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('ReleaseTableLock - Time: %12D', [GetTickCount - StartTime]), - Format(csResourceID, [ResourceID]), - Format(csCursorID, [CursorID])]); - {$ENDIF} -end; -{--------} -procedure TffLockManager.ReleaseTableLockAll(const aResourceID: Integer; - const aCursorID: TffCursorID); -var - LockContainer : TffLockContainer; - {$IFDEF LockLogging} - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - { We might need to release the lock container, so we get request full access - to the list } - FTableLocks.BeginWrite; - try - { Find the lock container } - LockContainer := FTableLocks.Get(AResourceID); - if not Assigned(LockContainer) then Exit; - - LockContainer.BeginWrite; - try - LockContainer.ReleaseCursorLockAll(aCursorID); - finally - LockContainer.EndWrite; - end; - - { Remove the lock container if it is empty } - if LockContainer.IsEmpty then - FTableLocks.Remove(AResourceID); - - finally - FTableLocks.EndWrite; - end; - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('ReleaseTableLockAll - Time: %12D', [GetTickCount - StartTime]), - Format(csResourceID, [aResourceID]), - Format(csCursorID, [aCursorID])]); - {$ENDIF} -end; -{--------} -procedure TffLockManager.ReleaseTableW(const ResourceID : TffWord32; - const CursorID : TffCursorID); - -var - LockContainer : TffLockContainer; -begin - { We might need to release the lock container, so we request full access - to the list } - FTableLocks.BeginWrite; - try - { Find the lock container } - LockContainer := FTableLocks.Get(ResourceID); - - if not Assigned(LockContainer) then - Exit; - - LockContainer.BeginWrite; - try - LockContainer.ReleaseWaitingLock(CursorID); - finally - LockContainer.EndWrite; - end; - - finally - FTableLocks.EndWrite; - end; -end; -{--------} -procedure TffLockManager.ReleaseTableWC(const ResourceID : TffWord32; - const CursorID : TffCursorID); - -var - LockContainer : TffLockContainer; -begin - { We might need to release the lock container, so we request full access - to the list } - FTableLocks.BeginWrite; - try - { Find the lock container } - LockContainer := FTableLocks.Get(ResourceID); - - if not Assigned(LockContainer) then - Exit; - - LockContainer.BeginWrite; - try - LockContainer.ReleaseWaitingConversion(CursorID); - finally - LockContainer.EndWrite; - end; - - finally - FTableLocks.EndWrite; - end; -end; -{--------} -procedure TffLockManager.ReleaseTransactionLocks(const Transaction : TffSrTransaction; - const RecordsOnly : boolean); -var - FI : PffFileInfo; - FileInx : Longint; - FileItem : TffWord32ListItem; - ResList : TffHash64; - TransContainer : TffTransContainer; - {$IFDEF LockLogging} - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - TransContainer := TffTransContainer(Transaction.TransLockContainer); - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - 'ReleaseTransactionLocks - Start', - Format(csTransaction, [Transaction.TransactionID])]); - {$ENDIF} - - if assigned(TransContainer) then begin - { Release record locks first. } - for FileInx := 0 to pred(TransContainer.FileCount) do begin - FileItem := TransContainer.Files[FileInx]; - FI := PffFileInfo(FileItem.KeyAsInt); - if assigned(FI^.fiRecordLocks) then begin - FI^.fiRecordLocks.BeginWrite; - try - ResList := TffHash64(FileItem.ExtraData); - ResList.Iterate(RelRecLockIterator, TffWord32(FileItem), - TffWord32(Transaction), 0); - ResList.Free; - finally - FI^.fiRecordLocks.EndWrite; - end; - end; { if have record locks } - FileItem.ExtraData := nil; - end; - - { Release content locks next. } - if not RecordsOnly then - for FileInx := 0 to pred(TransContainer.ContentCount) do - ReleaseContentLockAll - (TransContainer.ContentContainer[FileInx], Transaction); - end; { if have transaction container } - - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('ReleaseTransactionLocks - Time: %12D', [GetTickCount - StartTime]), - Format(csTransaction, [Transaction.TransactionID])]); - {$ENDIF} -end; -{--------} -procedure TffLockManager.RelRecLockIterator(aKey : TffInt64; - aData : pointer; - const cookie1, cookie2, cookie3 : TffWord32); -var - FileItem : TffWord32ListItem; - Transaction : TffSrTransaction; -begin - { Assumptions: - aKey = record reference number (i.e., ID of locked resource) - aData = database ID - Cookie1 = fileItem - Cookie2 = transaction - Cookie3 = nothing of value } - FileItem := TffWord32ListItem(cookie1); - Transaction := TffSrTransaction(cookie2); - ReleaseRecordLockAll(aKey, - PffFileInfo(FileItem.KeyValue), - Transaction, - TffDatabaseID(aData)); {!!.10} -end; -{--------} -function TffLockManager.TableLockGranted(const ResourceID: Integer): TffSrLockType; -var - LockContainer : TffLockContainer; - {$IFDEF LockLogging} - StartTime : DWORD; - {$ENDIF} -begin - {$IFDEF LockLogging} - StartTime := GetTickCount; - {$ENDIF} - FTableLocks.BeginRead; - try - { Find the lock container } - LockContainer := FTableLocks.Get(ResourceID); - if not Assigned(LockContainer) then begin - Result := ffsltNone; - Exit; - end; - - Result := LockContainer.SummaryMode; - finally - FTableLocks.EndRead; - end; - {$IFDEF LockLogging} - FEventLog.WriteStrings(['', - '========================================', - Format('TableLockGranted - Time: %12D', [GetTickCount - StartTime]), - Format(csResourceID, [ResourceID]), - Format(csLockType, [FFMapLockToName(Result)])]); - {$ENDIF} -end; -{====================================================================} - -{===TffLockContainer=================================================} -constructor TffLockContainer.Create; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - inherited Create; - Sorted := True; - FWaitQueue := TffLockQueue.Create; - FWaitConversionQueue := TffLockQueue.Create; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -destructor TffLockContainer.Destroy; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - FWaitQueue.Free; - FWaitQueue := nil; - - FWaitConversionQueue.Free; - FWaitConversionQueue := nil; - - inherited Destroy; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffLockContainer.AddLock(const Granted : Boolean; - const Conditional : Boolean; - LockItem : TffLockListItem - ): TffLockStatus; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if Granted then - { Normal Lock is granted, so add it to the list } - if not LockItem.Conversion then begin - Insert(LockItem); - Result := fflsGranted; - end else begin - { Grant a conversion lock } - with TffLockListItem(Items[fflIndexPrim(LockItem.PrimaryID)]) do {!!.10} - LockType := LockItem.LockType; - LockItem.Free; - Result := fflsGranted; - Exit; - end - else if (not Granted) and (not Conditional) then begin - { A waiting lock is added to the list } - if LockItem.Conversion then begin - { Add the lock item to the conversion list } - FWaitConversionQueue.Enqueue(LockItem); - Result := fflsWaitingConv; - end else begin - { Append lock request to the queue } - FWaitQueue.Enqueue(LockItem); - Result := fflsWaiting; - end; - end else - { Since a conditional lock could not be acquired instantly, the request - is rejected } - Result := fflsRejected; - - LockItem.Status := Result; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffLockContainer.LastLock: TffLockListItem; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := TffLockListItem(Self.Items[Pred(Count)]); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffLockContainer.ProcessLockConversion(const aCursorID : TffCursorID; - aLockListItem : TffLockListItem); -var - anItem : TffLockListItem; - LockIndex : Longint; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - {$IFDEF LockLogging} - Log.WriteStrings(['', - '========================================', - Format('LockContainer.ProcessLockConversion: CU %d', [aCursorID])]); - {$ENDIF} - { Retrieve the existing lock } - LockIndex := fflIndexPrim(aCursorID); - - { Convert the granted lock & wake it up. } - if LockIndex <> -1 then begin - anItem := TffLockListItem(Items[LockIndex]); - anItem.LockType := aLockListItem.LockType; - anItem.Event.SignalEvent; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffLockContainer.ProcessQueue; -var - anItem : TffLockListItem; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - {$IFDEF LockLogging} - Log.WriteStrings(['', - '========================================', - Format('LockContainer.ProcessQueue: %d', [Longint(self)])]); - {$ENDIF} - { Process all pending conversion requests first} - while Assigned(TffLockListItem(FWaitConversionQueue.Peek)) do - with TffLockListItem(FWaitConversionQueue.Peek) do - if ffca_LockCompatibility[LockType, SummaryMode] then begin - - {$IFDEF LockLogging} - Log.WriteStrings(['', - Format('LockContainer.SumMode: %s', [FFMapLockToName(SummaryMode)])]); - {$ENDIF} - - { Compatible waiting lock found, we must now grant it } - anItem := TffLockListItem(FWaitConversionQueue.Dequeue); - anItem.Status := fflsGranted; - - { If a lock conversion request has been encountered, we - must finalize the conversion operation } - ProcessLockConversion(PrimaryID, anItem); {!!.10} - - anItem.Free; - end else - Exit; - - {$IFDEF LockLogging} - Log.WriteStrings(['', - Format('Middle LockContainer.SumMode: %s', [FFMapLockToName(SummaryMode)])]); - {$ENDIF} - - { Check for normal locks } - while Assigned(TffLockListItem(FWaitQueue.Peek)) do - with TffLockListItem(FWaitQueue.Peek) do - if ffca_LockCompatibility[LockType, SummaryMode] then begin - {$IFDEF LockLogging} - Log.WriteStrings(['', - Format('LockContainer.SumMode: %s', [FFMapLockToName(SummaryMode)])]); - {$ENDIF} - { Compatible waiting lock found, we must now move it to the granted - list & mark it as granted. } - anItem := TffLockListItem(FWaitQueue.Dequeue); - anItem.Status := fflsGranted; - Insert(anItem); - anItem.Event.SignalEvent; - end else - { incompatible waiting lock found } - Exit; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffLockContainer.IsEmpty : boolean; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := (Count = 0) and - (FWaitQueue.Count = 0) and - (FWaitConversionQueue.Count = 0); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{Begin !!.10} -{--------} -procedure TffLockContainer.RelaxRecordLock(const aDatabaseID : TffCursorID); -var - anItem : TffLockListItem; - ItemIndex : Longint; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - {$IFDEF LockLogging} - Log.WriteStrings(['', - '========================================', - Format('LockContainer.RelaxRecordLock: %d, DB %d', - [Longint(self), aDatabaseID])]); - {$ENDIF} - ItemIndex := fflIndexPrim(aDatabaseID); - if ItemIndex <> -1 then begin - anItem := TffLockListItem(Items[ItemIndex]); - anItem.F2ndaryID := 0; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{End !!.10} -{--------} -procedure TffLockContainer.ReleaseWaitingConversion(const RequestorID : TffBaseID); {!!.10} -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - FWaitConversionQueue.Delete(RequestorID); {!!.10} - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffLockContainer.ReleaseWaitingLock(const RequestorID : TffBaseID); {!!.10} -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - FWaitQueue.Delete(RequestorID); {!!.10} - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffLockContainer.ReleaseCursorLock(const aCursorID : TffCursorID; - var aRefCount : Integer); -var - anItem : TffLockListItem; - ItemIndex : Longint; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - {$IFDEF LockLogging} - Log.WriteStrings(['', - '========================================', - Format('LockContainer.ReleaseCursorLock: %d, Cursor %d', - [Longint(self), aCursorID])]); - {$ENDIF} - ItemIndex := fflIndexPrim(aCursorID); - if ItemIndex <> -1 then begin - anItem := TffLockListItem(Items[ItemIndex]); - if anItem.RefCount > 1 then begin - anItem.RefCount := anItem.RefCount - 1; - aRefCount := anItem.RefCount; - end else begin - aRefCount := 0; - DeleteAt(ItemIndex); - ProcessQueue; - end; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffLockContainer.ReleaseCursorLockAll(const aCursorID : TffCursorID); -var - ItemIndex : Longint; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - {$IFDEF LockLogging} - Log.WriteStrings(['', - '========================================', - Format('LockContainer.ReleaseCursorLockAll: %d, cursor %d', - [Longint(self), aCursorID])]); - {$ENDIF} - ItemIndex := fflIndexPrim(aCursorID); - if ItemIndex <> -1 then - with TffLockListItem(Items[ItemIndex]) do begin - DeleteAt(ItemIndex); - ProcessQueue; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffLockContainer.RequestLock(const LockType : TffSrLockType; - const Conditional : Boolean; - const Transaction : TffSrTransaction; - const RequestorID : TffBaseID; {!!.10} - var WaitEvent : TffEvent - ) : TffLockStatus; -var - CvtLockItem : TffLockListItem; - CvtOnlyItem : boolean; - ItemIndex : Longint; - LockItem : TffLockListItem; -{$IFDEF LockLogging} - TranID : TffTransID; -{$ENDIF} -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - CvtOnlyItem := false; - ItemIndex := fflIndexPrim(RequestorID); {!!.10} - {$IFDEF LockLogging} - if Transaction = nil then - TranID := 0 - else - TranID := Transaction.TransactionID; - {$ENDIF} - if ItemIndex <> -1 then begin - { If a lock item already exists for this transaction, then we need to - see if it is compatible } - LockItem := TffLockListItem(Items[ItemIndex]); - assert(LockItem.Status = fflsGranted); - if LockItem.LockType >= LockType then begin - { The lock is compatible, so we increment the lock's RefCount } - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.Compatible, TR %d, CU %d', {!!.10} - [TranID, RequestorID]); {!!.10} - {$ENDIF} - LockItem.RefCount := LockItem.RefCount + 1; - Result := fflsGranted; - Exit; - end else begin - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.Incompatible, TR %d, CU %d', {!!.10} - [TranID, RequestorID]); {!!.10} - {$ENDIF} - { The LockTypes are not compatible, so we must convert the existing Lock } - - { To facilitate the lock conversion, we add a new lock request into the - queue. Once the lock is granted, any existing locks for the same - transaction will be removed, and this lock will take it's place. } - - { If there is only 1 item in the queue then we are that item and the - conversion can be granted automatically. Set a flag so we know this - later on. } - CvtOnlyItem := (Count = 1); - - { Create and Initialize the lock item } - CvtLockItem := TffLockListItem.Create(RequestorID); {!!.10} - CvtLockItem.LockType := ffca_LockConversion[LockItem.LockType, LockType]; - CvtLockItem.Transaction := Transaction; - CvtLockItem.RefCount := 1; - CvtLockItem.Conversion := True; - CvtLockItem.MaintainLinks := False; - LockItem.Conversion := True; - { Mark the granted lock's conversion flag so that if we know to pull - a lock item out of the wait conversion queue if the lock request - times out. } - - { We are done with the original lock item, so we will set it (the var) - to the new converted lock item. When this new lock is granted, any - existing locks for this transaction will be removed. } - LockItem := CvtLockItem; - end; - end else begin - { Create and Initialize the lock item } - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.CreateLockItem, TR %d, CU %d', - [TranID, RequestorID]); {!!.10} - {$ENDIF} - LockItem := TffLockListItem.Create(RequestorID); {!!.10} - LockItem.LockType := LockType; - LockItem.Transaction := Transaction; - LockItem.RefCount := 1; - LockItem.Conversion := False; - LockItem.MaintainLinks := False; - end; - - { If there are no items in the queue or we are the only item in the queue - and we happen to be a conversion request then grant the lock. } - if (Count = 0) or CvtOnlyItem then begin - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.OnlyItem, TR %d, CU %d', - [TranID, RequestorID]); {!!.10} - {$ENDIF} - Result := AddLock(True, Conditional, LockItem); - Exit; - end; - - { If the last lock is waiting, then make the new lock wait in line } - if (FWaitQueue.Count > 0) then begin - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.MakeWait, TR %d, CU %d', - [TranID, RequestorID]); {!!.10} - {$ENDIF} - Result := AddLock(False, Conditional, LockItem) - end - else if ffca_LockCompatibility[LockType, SummaryMode] then begin - { No locks are waiting, the summary mode is compatible, so add a granted - lock. } - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.CompatibleWithSumMode, TR %d, CU %d', - [TranID, RequestorID]); {!!.10} - {$ENDIF} - Result := AddLock(True, Conditional, LockItem) - end - else begin - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.LastOption, TR %d, CU %d', - [TranID, RequestorID]); {!!.10} - {$ENDIF} - Result := AddLock(False, Conditional, LockItem); - end; - - if Result in [fflsWaiting, fflsWaitingConv] then begin - { We need to create the waitfor event } - WaitEvent := TffEvent.Create; - LockItem.Event := WaitEvent; - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.CreateWaitEvent, TR %d, CU %d', - [TranID, RequestorID]); {!!.10} - {$ENDIF} - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{Begin !!.10} -{--------} -function TffLockContainer.RequestRecLock(const LockType : TffSrLockType; - const Conditional : Boolean; - const Transaction : TffSrTransaction; - const ReqPrimaryID, - ReqSecondaryID : TffBaseID; - var WaitEvent : TffEvent - ) : TffLockStatus; -var - CvtLockItem : TffLockListItem; - CvtOnlyItem : boolean; - ItemIndex : Longint; - LockItem : TffLockListItem; -{$IFDEF LockLogging} - TranID : TffTransID; -{$ENDIF} -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} - CvtOnlyItem := false; - { Look for an existing lock held by the database. } - ItemIndex := fflIndexPrim(ReqPrimaryID); - {$IFDEF LockLogging} - if Transaction = nil then - TranID := 0 - else - TranID := Transaction.TransactionID; - {$ENDIF} - { Did we find an existing lock entry for the database? } - if ItemIndex <> -1 then begin - { Yes. If a lock item already exists then we need to determine if it was - obtained by a different cursor. } - LockItem := TffLockListItem(Items[ItemIndex]); - assert(LockItem.Status = fflsGranted); - if ((LockItem.SecondaryID = 0) or - (LockItem.SecondaryID = ReqSecondaryID)) then begin - { The lock is held by the same cursor or was held by another cursor but - released after it was finished with the record. Next, determine if the - existing lock and the requested lock are compatible. } - if (LockItem.LockType >= LockType) then begin - { The lock is compatible, so we increment the lock's RefCount } - if LockItem.SecondaryID = 0 then begin - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.Compatible, TR %d, DB %d, CU %d, ' + - 'obtaining exclusive access', - [TranID, ReqPrimaryID, ReqSecondaryID]); - {$ENDIF} - LockItem.F2ndaryID := ReqSecondaryID; - end else - begin - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.Compatible, TR %d, DB %d, CU %d', - [TranID, ReqPrimaryID, ReqSecondaryID]); - {$ENDIF} - end; - LockItem.RefCount := LockItem.RefCount + 1; - Result := fflsGranted; - Exit; - end else begin - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.Incompatible, TR %d, DB %d, CU %d', - [TranID, ReqPrimaryID, ReqSecondaryID]); - {$ENDIF} - { The LockTypes are not compatible, so we must convert the existing Lock } - - { To facilitate the lock conversion, we add a new lock request into the - queue. Once the lock is granted, any existing locks for the same - transaction will be removed, and this lock will take it's place. } - - { If there is only 1 item in the queue then we are that item and the - conversion can be granted automatically. Set a flag so we know this - later on. } - CvtOnlyItem := (Count = 1); - - { Create and Initialize the lock item } - CvtLockItem := TffLockListItem.Create(ReqPrimaryID); - CvtLockItem.F2ndaryID := LockItem.F2ndaryID; - CvtLockItem.LockType := ffca_LockConversion[LockItem.LockType, LockType]; - CvtLockItem.Transaction := Transaction; - CvtLockItem.RefCount := 1; - CvtLockItem.Conversion := True; - CvtLockItem.MaintainLinks := False; - LockItem.Conversion := True; - { Mark the granted lock's conversion flag so that if we know to pull - a lock item out of the wait conversion queue if the lock request - times out. } - - { We are done with the original lock item, so we will set it (the var) - to the new converted lock item. When this new lock is granted, any - existing locks for this transaction will be removed. } - LockItem := CvtLockItem; - end; { if } - end - else begin - { The existing lock is being exclusively held by another cursor in the - same database. This situation represents a coding error. } - Result := fflsRejected; - Exit; - end; - end else begin - { Create and Initialize the lock item } - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.CreateLockItem, TR %d, DB %d, CU %d', - [TranID, ReqPrimaryID, ReqSecondaryID]); - {$ENDIF} - LockItem := TffLockListItem.Create(ReqPrimaryID); - LockItem.F2ndaryID := ReqSecondaryID; - LockItem.LockType := LockType; - LockItem.Transaction := Transaction; - LockItem.RefCount := 1; - LockItem.Conversion := False; - LockItem.MaintainLinks := False; - end; - - { If there are no items in the queue or we are the only item in the queue - and we happen to be a conversion request then grant the lock. } - if (Count = 0) or CvtOnlyItem then begin - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.OnlyItem, TR %d, DB %d, CU %d', - [TranID, ReqPrimaryID, ReqSecondaryID]); - {$ENDIF} - Result := AddLock(True, Conditional, LockItem); - Exit; - end; - - { If the last lock is waiting, then make the new lock wait in line } - if (FWaitQueue.Count > 0) then begin - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.MakeWait, TR %d, DB %d, CU %d', - [TranID, ReqPrimaryID, ReqSecondaryID]); - {$ENDIF} - Result := AddLock(False, Conditional, LockItem) - end - else if ffca_LockCompatibility[LockType, SummaryMode] then begin - { No locks are waiting, the summary mode is compatible, so add a granted - lock. } - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.CompatibleWithSumMode, TR %d, DB %d, CU %d', - [TranID, ReqPrimaryID, ReqSecondaryID]); - {$ENDIF} - Result := AddLock(True, Conditional, LockItem) - end - else begin - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.LastOption, TR %d, DB %d, CU %d', - [TranID, ReqPrimaryID, ReqSecondaryID]); - {$ENDIF} - Result := AddLock(False, Conditional, LockItem); - end; - - if Result in [fflsWaiting, fflsWaitingConv] then begin - { We need to create the waitfor event } - WaitEvent := TffEvent.Create; - LockItem.Event := WaitEvent; - {$IFDEF LockLogging} - Log.WriteStringFmt('ReqLock.CreateWaitEvent, TR %d, DB %d, CU %d', - [TranID, ReqPrimaryID, ReqSecondaryID]); - {$ENDIF} - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} -end; -{End !!.10} -{Begin !!.03} -{--------} -function TffLockContainer.SimpleDeadlock : Boolean; -var - anInx, anInx2 : Longint; - LockItem, LockItem2 : TffLockListItem; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Assumption: The transaction invoking this method has not submitted its - request for an Exclusive lock. } - { Scan through the wait queues for a transaction that is requesting an - Exclusive lock. If found then see if it has been granted a share lock. - If found then return True else return False. } - Result := False; - {Check the wait queue. } - for anInx := 0 to Pred(FWaitQueue.Count) do begin - LockItem := TffLockListItem(FWaitQueue.Items[anInx]); - if LockItem.LockType = ffsltExclusive then - { Found a waiting request for Exclusive lock. Already granted a - share lock? } - for anInx2 := 0 to Pred(Count) do begin - LockItem2 := TffLockListItem(Items[anInx]); - if (LockItem2 <> nil) and {!!.06} - (LockItem2.Transaction = LockItem.Transaction) then begin {!!.06} - Result := True; - Exit; - end; - end; - end; - - {Check the wait conversion queue. } - for anInx := 0 to Pred(FWaitConversionQueue.Count) do begin - LockItem := TffLockListItem(FWaitConversionQueue.Items[anInx]); - if LockItem.LockType = ffsltExclusive then - { Found a waiting request for Exclusive lock. Already granted a - share lock? } - for anInx2 := 0 to Pred(Count) do begin - LockItem2 := TffLockListItem(Items[anInx]); - if LockItem2.Transaction = LockItem.Transaction then begin - Result := True; - break; - end; - end; - end; { for } - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{End !!.03} -{--------} -function TffLockContainer.SummaryMode : TffSrLockType; -var - Idx : Integer; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := ffsltNone; - {$IFDEF LockLogging} - Log.WriteStringFmt('SumMode:Lock container Count: %d', [Count]); - {$ENDIF} - for Idx := 0 to Pred(Count) do - with TffLockListItem(Items[Idx]) do begin - {$IFDEF LockLogging} - Log.WriteStringFmt('SumMode:Item %d, lock type %s, status %d (0=rej, 1=grant, 2=wait)', - [Idx, FFMapLockToName(LockType), - ord(Status)]); - {$ENDIF} - if (LockType > Result) then - Result := LockType; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{====================================================================} - -{$IFDEF UseLockContainerPool} -{===TffLockContainerPool=============================================} -constructor TffLockContainerPool.Create(const InitialCount, RetainCount : Integer); -var - aLockContainer : TffLockContainer; - Index : integer; -begin - inherited Create; - FList := TffPointerList.Create; - FRetainCount := RetainCount; - FPadLock := TffPadlock.Create; - - { Create the initial set of LockContainers. } - for Index := 1 to InitialCount do begin - aLockContainer := TffLockContainer.Create; - FList.Append(aLockContainer); - end; -end; -{--------} -destructor TffLockContainerPool.Destroy; -var - Index : Longint; -begin - { Explicitly free the lock containers. They are not freed - by FList.Free. } - for Index := pred(FList.Count) downto 0 do - TffLockContainer(FList[Index]).Free; - FList.Free; - FPadLock.Free; - inherited Destroy; -end; -{Begin !!.01} -{--------} -procedure TffLockContainerPool.Flush; -var - aLockContainer : TffLockContainer; - anInx : Longint; -begin - FPadLock.Lock; - try - if FList.Count > FRetainCount then - for anInx := pred(FList.Count) downto FRetainCount do begin - aLockContainer := FList.Pointers[anInx]; - FList.RemoveAt(anInx); - aLockContainer.Free; - end; - finally - FPadLock.Unlock; - end; -end; -{End !!.01} -{--------} -function TffLockContainerPool.Get : TffLockContainer; -var - aCount : Longint; -begin - FPadLock.Lock; - try - if FList.IsEmpty then - Result := TffLockContainer.Create - 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(FList.Count); - Result := FList.Pointers[aCount]; - FList.RemoveAt(aCount); - end; - finally - FPadLock.Unlock; - end; -end; -{--------} -procedure TffLockContainerPool.Put(const aLockContainer : TffLockContainer); -begin - FPadLock.Lock; - try - FList.Append(aLockContainer); - finally - FPadLock.Unlock; - end; -end; -{====================================================================} -{$ENDIF} - -{===Utility routines=================================================} -function FFMapLockToName(aLockType : TffSrLockType) : string; -begin - case aLockType of - ffsltNone : Result := ffcLockNone; - ffsltIntentS : Result := ffcLockIntentS; - ffsltIntentX : Result := ffcLockIntentX; - ffsltShare : Result := ffcLockShare; - ffsltSIX : Result := ffcLockSIX; - ffsltUpdate : Result := ffcLockUpdate; - ffsltExclusive : Result := ffcLockExclusive; - end; { case } -end; -{$IFDEF LockLogging} -{--------} -function FFMapRequestStatusToName(aStatus : TffLockRequestStatus) : string; -begin - case aStatus of - fflrsGranted : Result := ffcRStatusGranted; - fflrsTimeout : Result := ffcRStatusTimeout; - fflrsRejected : Result := ffcRStatusRejected; - end; -end; -{$ENDIF} -{====================================================================} - -{===TffLockListItem==================================================} -constructor TffLockListItem.Create(const aKey: TffBaseID); {!!.10} -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - inherited Create; - FPrimaryID := aKey; {!!.10} - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffLockListItem.Compare(aKey: pointer): integer; -begin - Result := FFCmpI32(PffWord32(aKey)^, FPrimaryID); {!!.10} -end; -{--------} -function TffLockListItem.Key : pointer; -begin - Result := @FPrimaryID; {!!.10} -end; -{====================================================================} - -{===TffLockQueue=====================================================} -procedure TffLockQueue.EnqueuePriority(anItem: TffListItem); -var - NewItem : TffListItem; - OldItem : TffListItem; - Idx : Integer; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if GetCount = 0 then - Enqueue(anItem) - else begin - { insert the new item at the beginning of the queue, and - adjust accordingly } - NewItem := anItem; - for Idx := 0 to Pred(ffqList.Count) do begin - OldItem := ffqList[Idx]; - ffqList[Idx] := NewItem; - NewItem := OldItem; - end; - Enqueue(NewItem); - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffLockQueue.Peek: TffListItem; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := nil; - if GetCount > 0 then - Result := ffqList[0]; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{====================================================================} - -{===TffTransContainer================================================} -constructor TffTransContainer.Create(const aKey: TffSrTransaction); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - inherited Create; - Transaction := TffSrTransaction(aKey); - - FContentLocks := TffList.Create; - FRecordLocks := TffList.Create; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -destructor TffTransContainer.Destroy; -var - Inx : Longint; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - - FContentLocks.Free; - { Note: We must *NOT* free the TffSrTable referenced by the ExtraData - property of each item. } - FContentLocks := nil; - - for Inx := pred(FRecordLocks.Count) downto 0 do - TffThreadList(TffWord32ListItem(FRecordLocks[Inx]).ExtraData).Free; - FRecordLocks.Free; - FRecordLocks := nil; - - Transaction.TransLockContainer := nil; - - inherited Destroy; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffTransContainer.AddContentLock(Container : TffLockContainer; - ParentTable : TffObject; - LockType : TffSrLockType); -var - anItem : TffWord32ListItem; - anIndx : Longint; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - anIndx := FContentLocks.Index(TffWord32(Container)); - { Have we referenced this lock container before? } - if anIndx = -1 then begin - { No. Create a reference to this lock container. } - anItem := TffWord32ListItem.Create(TffWord32(Container)); - anItem.ExtraData := ParentTable; - anItem.ExtraData2 := ord(LockType); - { Note: The table referenced by ExtraData must *NOT* be freed. } - FContentLocks.Insert(anItem); - end - else begin - { Yes. Update the lock type. } - anItem := TffWord32ListItem(FcontentLocks[anIndx]); - anItem.ExtraDAta2 := ord(LockType); - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffTransContainer.AddRecordLock(const FI : PffFileInfo; - const CursorID : TffCursorID; - const ResourceID : TffInt64); -var - FileItem : TffWord32ListItem; - FileIdx : Longint; - ResList : TffHash64; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - FileIdx := FRecordLocks.Index(TffWord32(FI)); - if FileIdx = -1 then begin - { Create the file item, and resource list } - FileItem := TffWord32ListItem.Create(TffWord32(FI)); - { Add the file item to the list } - FRecordLocks.Insert(FileItem); - end - else - { Retrieve the information from the list } - FileItem := TffWord32ListItem(FRecordLocks.Items[FileIdx]); - - ResList := TffHash64(FileItem.ExtraData); - if not assigned(ResList) then begin - ResList := TffHash64.Create(ffc_Size521); - ResList.CanShrink := False; - FileItem.ExtraData := ResList; - end; - - ResList.Add(ResourceID, pointer(CursorID)); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffTransContainer.Compare(aKey: pointer): integer; -begin - Result := FFCmpI32(PffLongint(aKey)^, Longint(FTransaction)); -end; -{--------} -function TffTransContainer.Key: pointer; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := @FTransaction; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffTransContainer.RemoveContentLock(Container : TffLockContainer); -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { If this container is not present then this should fall through without - doing anything. No exception should be raised. } - FContentLocks.Delete(TffWord32(Container)); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -procedure TffTransContainer.RemoveRecordLock(const FI : PffFileInfo; - const ResourceID : TffInt64); -var - FileItem : TffWord32ListItem; - FileIdx : Longint; - ResList : TffHash64; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - FileIdx := FRecordLocks.Index(TffWord32(FI)); - if FileIdx > -1 then begin - FileItem := TffWord32ListItem(FRecordLocks.Items[FileIdx]); - ResList := TffHash64(FileItem.ExtraData); - - ResList.Remove(ResourceID); - - if ResList.Count = 0 then begin - FRecordLocks.Delete(TffWord32(FI)); - ResList.Free; - end; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffTransContainer.TableContentLockType(Container : TffLockContainer) : TffSrLockType; -var - aInx : Longint; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - { Assumptions: FContentLocks is assigned. } - with Container.BeginRead do - try - aInx := FContentLocks.Index(TffWord32(Container)); - { Does the transaction have a content lock on this table? } - if aInx = -1 then - { No. } - Result := ffsltNone - else - Result := TffSrLockType(TffWord32ListItem(FContentLocks[aInx]).ExtraData2); - finally - EndRead; - end; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffTransContainer.tcGetContentCount : Longint; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if assigned(FContentLocks) then - Result := FContentLocks.Count - else - Result := 0; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffTransContainer.tcGetContentContainer(const aInx : Longint) : TffLockContainer; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - Result := TffLockContainer(TffWord32ListItem(FContentLocks[aInx]).KeyAsInt); - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffTransContainer.tcGetContentLockType(const aInx : Longint) : TffSrLockType; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if assigned(FContentLocks) then - Result := TffSrLockType(TffWord32ListItem(FContentLocks[aInx]).ExtraData2) - else - Result := ffsltNone; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffTransContainer.tcGetContentTable(const aInx : Longint) : TffObject; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if assigned(FContentLocks) then - Result := TffObject(TffWord32ListItem(FContentLocks[aInx]).ExtraData) - else - Result := nil; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffTransContainer.tcGetFileCount : Longint; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if assigned(FRecordLocks) then - Result := FRecordLocks.Count - else - Result := 0; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{--------} -function TffTransContainer.tcGetFiles(const aInx : Longint) : TffWord32ListItem; -begin - {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03} - if assigned(FRecordlocks) then - Result := TffWord32ListItem(FRecordLocks[aInx]) - else - Result := nil; - {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03} -end; -{====================================================================} - -{$IFDEF UseLockContainerPool} -{===Initialization/Finalization======================================} -procedure FinalizeUnit; -begin - FFLockContainerPool.Free; -end; -{--------} -procedure InitializeUnit; -begin - FFLockContainerPool := TFFLockContainerPool.Create(250,1000); -end; - -initialization - InitializeUnit; - -finalization - FinalizeUnit; -{$ENDIF} - -end. - diff --git a/components/flashfiler/sourcelaz/ffsrmgr.pas b/components/flashfiler/sourcelaz/ffsrmgr.pas deleted file mode 100644 index 6444b29da..000000000 --- a/components/flashfiler/sourcelaz/ffsrmgr.pas +++ /dev/null @@ -1,397 +0,0 @@ -{*********************************************************} -{* FlashFiler: String resource 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} - -{include the resource compiled using BRCC32.EXE and SRMC.EXE} -{$R ffsrmgr.res} - -unit ffsrmgr; - -interface - -uses - Windows, - Classes, - SysUtils, {!!.03} - ffllbase; {!!.03} - -const - DefReportError = False; - - {id at start of binary resource; must match SRMC} - ResID : array[0..3] of char = 'STR0'; - -type - EffStringResourceError = class(Exception); - - TInt32 = Integer; - - PIndexRec = ^TIndexRec; - TIndexRec = record - id : TInt32; - ofs: TInt32; - len: TInt32; - end; - TIndexArray = array[0..(MaxInt div SizeOf(TIndexRec))-2] of TIndexRec; - - PResourceRec = ^TResourceRec; - TResourceRec = record - id : array[0..3] of char; - count : LongInt; - index : TIndexArray; - end; - - TffStringResource = class - private - {property variables} - FReportError : Boolean; {true to raise exception if string not found} - - {internal variables} - srHandle : THandle; {handle for TPStrings resource} - srP : PResourceRec; {pointer to start of resource} - srPadlock : TffPadlock; {!!.03} - - {internal methods} - procedure srCloseResource; - function srFindIdent(Ident : TInt32) : PIndexRec; - function srGetCount : longInt; - procedure srLock; - procedure srLoadResource(Instance : THandle; const ResourceName : string); - procedure srOpenResource(Instance : THandle; const ResourceName : string); - procedure srUnLock; - - public - constructor Create(Instance : THandle; const ResourceName : string); virtual; - destructor Destroy; override; - procedure ChangeResource(Instance : THandle; const ResourceName : string); - - function GetAsciiZ(Ident : TInt32; Buffer : PChar; BufChars : Integer) : PChar; - - function GetIdentAtIndex(const anIndex : longInt) : integer; - - function GetString(Ident : TInt32) : string; - function GetStringAtIndex(const anIndex : longInt) : string; - - property Strings[Ident : TInt32] : string - read GetString; default; - function GetWideChar(Ident : TInt32; Buffer : PWideChar; BufChars : Integer) : PWideChar; - - property Count : longInt read srGetCount; - {-Returns the number of strings managed by this resource. } - - property ReportError : Boolean - read FReportError - write FReportError; - end; - -var - ffResStrings : TffStringResource; {error strings for this unit} - -implementation - -{===TffStringResource================================================} -{*** TffStringResource ***} - -procedure TffStringResource.ChangeResource(Instance : THandle; const ResourceName : string); -begin - srCloseResource; - if ResourceName <> '' then - srOpenResource(Instance, ResourceName); -end; -{--------} -constructor TffStringResource.Create(Instance : THandle; const ResourceName : string); -begin - inherited Create; - srPadlock := TffPadlock.Create; {!!.03} - FReportError := DefReportError; - ChangeResource(Instance, ResourceName); -end; -{--------} -destructor TffStringResource.Destroy; -begin - srCloseResource; - srPadlock.Free; {!!.03} - inherited Destroy; -end; -{--------} -procedure WideCopy(Dest, Src : PWideChar; Len : Integer); -begin - while Len > 0 do begin - Dest^ := Src^; - inc(Dest); - inc(Src); - dec(Len); - end; - Dest^ := #0; -end; -{--------} -function TffStringResource.GetWideChar(Ident : TInt32; - Buffer : PWideChar; BufChars : Integer) : PWideChar; -var - OLen : Integer; - P : PIndexRec; -begin - srLock; - try - P := srFindIdent(Ident); - if P = nil then - Buffer[0] := #0 - - else begin - OLen := P^.len; - if OLen >= BufChars then - OLen := BufChars-1; - WideCopy(Buffer, PWideChar(PChar(srP)+P^.ofs), OLen); - end; - finally - srUnLock; - end; - - Result := Buffer; -end; -{--------} -function TffStringResource.GetAsciiZ(Ident : TInt32; - Buffer : PChar; BufChars : Integer) : PChar; -var - P : PIndexRec; - Src : PWideChar; - Len, OLen : Integer; -begin - srLock; - try - P := srFindIdent(Ident); - if P = nil then - OLen := 0 - - else begin - Src := PWideChar(PChar(srP)+P^.ofs); - Len := P^.len; - - {see if entire string fits in Buffer} - OLen := WideCharToMultiByte(CP_ACP, 0, Src, Len, nil, 0, nil, nil); - - while OLen >= BufChars do begin - {reduce length to get what will fit} - dec(Len); - OLen := WideCharToMultiByte(CP_ACP, 0, Src, Len, nil, 0, nil, nil); - end; - - {copy to buffer} - OLen := WideCharToMultiByte(CP_ACP, 0, Src, Len, Buffer, BufChars, nil, nil) - end; - finally - srUnLock; - end; - - {null terminate the result} - Buffer[OLen] := #0; - Result := Buffer; -end; -{--------} -function TffStringResource.GetIdentAtIndex(const anIndex : longInt) : integer; -begin - Result := -1; - srLock; - try - if anIndex > pred(srP^.Count) then - raise EffStringResourceError.CreateFmt(ffResStrings[6], [anIndex]); - Result := PIndexRec(@srP^.index[anIndex])^.id; - finally - srUnLock; - end; -end; -{--------} -function TffStringResource.GetString(Ident : TInt32) : string; -var - P : PIndexRec; - Src : PWideChar; - Len, OLen : Integer; -begin - srLock; - try - P := srFindIdent(Ident); - if P = nil then - Result := '' - - else begin - Src := PWideChar(PChar(srP)+P^.ofs); - Len := P^.len; - OLen := WideCharToMultiByte(CP_ACP, 0, Src, Len, nil, 0, nil, nil); - SetLength(Result, OLen); - WideCharToMultiByte(CP_ACP, 0, Src, Len, PChar(Result), OLen, nil, nil); - end; - finally - srUnLock; - end; -end; -{--------} -function TffStringResource.GetStringAtIndex(const anIndex : longInt) : string; -var - P : PIndexRec; - Src : PWideChar; - Len, OLen : Integer; -begin - srLock; - try - if anIndex > pred(srP^.Count) then - raise EffStringResourceError.CreateFmt(ffResStrings[6], [anIndex]); - - P := @srP^.index[anIndex]; - if P = nil then - Result := '' - - else begin - Src := PWideChar(PChar(srP)+P^.ofs); - Len := P^.len; - OLen := WideCharToMultiByte(CP_ACP, 0, Src, Len, nil, 0, nil, nil); - SetLength(Result, OLen); - WideCharToMultiByte(CP_ACP, 0, Src, Len, PChar(Result), OLen, nil, nil); - end; - finally - srUnLock; - end; -end; -{--------} -procedure TffStringResource.srCloseResource; -begin - while Assigned(srP) do - srUnLock; - - if srHandle <> 0 then begin - FreeResource(srHandle); - srHandle := 0; - end; -end; -{--------} -function TffStringResource.srFindIdent(Ident : TInt32) : PIndexRec; -var - L, R, M : TInt32; -begin - Assert(srP <> nil, 'Lock not obtained on string resource'); - {binary search to find matching index record} - L := 0; - R := srP^.count-1; - while L <= R do begin - M := (L+R) shr 1; - Result := @srP^.index[M]; - if Ident = Result^.id then - exit; - if Ident > Result^.id then - L := M+1 - else - R := M-1; - end; - - {not found} - Result := nil; - if FReportError then - raise EffStringResourceError.CreateFmt(ffResStrings[1], [Ident]); -end; -{--------} -function TffStringResource.srGetCount : longInt; -begin - srLock; - try - Result := srP^.count; - finally - srUnlock; - end; -end; -{--------} -procedure TffStringResource.srLock; -begin - srPadlock.Lock; {!!.03} - try {!!.03} - srP := LockResource(srHandle); - if not Assigned(srP) then - raise EffStringResourceError.Create(ffResStrings[2]); - except {!!.03} - srPadlock.Unlock; {!!.03} - raise; {!!.03} - end; {!!.03} -end; -{--------} -procedure TffStringResource.srLoadResource(Instance : THandle; const ResourceName : string); -var - H : THandle; - Buf : array[0..255] of Char; -begin - StrPLCopy(Buf, ResourceName, SizeOf(Buf)-1); - {$IFDEF UsesCustomDataSet} - Instance := FindResourceHInstance(Instance); - {$ENDIF} - H := FindResource(Instance, Buf, RT_RCDATA); - if H = 0 then begin - raise EffStringResourceError.CreateFmt(ffResStrings[3], [ResourceName]); - end else begin - srHandle := LoadResource(Instance, H); - if srHandle = 0 then - raise EffStringResourceError.CreateFmt(ffResStrings[4], [ResourceName]); - end; -end; -{--------} -procedure TffStringResource.srOpenResource(Instance : THandle; const ResourceName : string); -begin - {find and load the resource} - srLoadResource(Instance, ResourceName); - - {confirm it's in the correct format} - srLock; - try - if srP^.id <> ResId then - raise EffStringResourceError.Create(ffResStrings[5]); - finally - srUnLock; - end; -end; -{--------} -procedure TffStringResource.srUnLock; -begin - try {!!.03} - if not UnLockResource(srHandle) then - srP := nil; - finally {!!.03} - srPadlock.Unlock; {!!.03} - end; {!!.03} -end; -{--------} -procedure FreeTpsResStrings; far; -begin - ffResStrings.Free; -end; -{====================================================================} - -initialization - ffResStrings := TffStringResource.Create(HInstance, 'FFSRMGR_STRINGS'); - -finalization - FreeTpsResStrings; - -end. diff --git a/components/flashfiler/sourcelaz/ffsrmgr.rc b/components/flashfiler/sourcelaz/ffsrmgr.rc deleted file mode 100644 index 6513af250..000000000 --- a/components/flashfiler/sourcelaz/ffsrmgr.rc +++ /dev/null @@ -1,31 +0,0 @@ -/********************************************************* - * FlashFiler: FFSRMGR 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 ***** */ - - -FFSRMGR_STRINGS RCDATA FFSRMGR.SRM diff --git a/components/flashfiler/sourcelaz/ffsrmgr.res b/components/flashfiler/sourcelaz/ffsrmgr.res deleted file mode 100644 index decda9d23..000000000 Binary files a/components/flashfiler/sourcelaz/ffsrmgr.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffsrmgr.srm b/components/flashfiler/sourcelaz/ffsrmgr.srm deleted file mode 100644 index 1e9832194..000000000 Binary files a/components/flashfiler/sourcelaz/ffsrmgr.srm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffsrmgr.str b/components/flashfiler/sourcelaz/ffsrmgr.str deleted file mode 100644 index 037aa99ec..000000000 --- a/components/flashfiler/sourcelaz/ffsrmgr.str +++ /dev/null @@ -1,37 +0,0 @@ -;********************************************************* -;* FlashFiler: FFSRMGR error 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 ***** - -//Compile with SRMC, then compile FFSRMGR.RC with BRCC[32] - - 1, "String not found: %d" - 2, "Cannot lock resource" - 3, "String resource not found: %s" - 4, "Unable to open string resource: %s" - 5, "Invalid TPString resource" - 6, "Invalid string index: %d" diff --git a/components/flashfiler/sourcelaz/ffsrpack.inc b/components/flashfiler/sourcelaz/ffsrpack.inc deleted file mode 100644 index 1ee48ff52..000000000 --- a/components/flashfiler/sourcelaz/ffsrpack.inc +++ /dev/null @@ -1,696 +0,0 @@ -{*********************************************************} -{* FlashFiler: pack table 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 - { The name given the old table while we are replacing it with the new - table. } - ffcPackBaseName = '_PACK'; - ffcSaveBaseName = '_PACKSV'; - -function TffServerEngine.TablePack(aDatabaseID : TffDatabaseID; - const aTableName : TffTableName; - var aRebuildID : LongInt): TffResult; -var - DB : TffSrDatabase; - RebuildParamsPtr: PffSrRebuildParams; - SourceDict: TffServerDataDict; - TargetDict: TffServerDataDict; - TargetBasename: TffFileName; - RecordInfo: TffRecordInfo; - CursorID: TffCursorID; - I: Integer; - Inx: Integer; - KeyProcItem : TffKeyProcItem; - StartedTrans : boolean; - TransID : TffTransID; - SrcTblVersionChanged : Boolean; {!!.11} - - function SetTargetBasename(Path: TffPath; Root: TffFileName): TffFileName; - var - I: Integer; - begin - I := 0; - repeat - Inc(I); - Result := Root + IntToStr(I); - until not FFFileExists(FFMakeFullFilename(Path, - FFMakeFileNameExt(Result, - ffc_ExtForData))); - end; - -begin - if IsReadOnly then begin {!!.01 - Start} - Result := DBIERR_TABLEREADONLY; - Exit; - end else {!!.01 - End} - Result := DBIERR_NONE; - aRebuildID := -1; - StartedTrans := False; - RebuildParamsPtr := nil; - - try - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if Result <> DBIERR_NONE then - Exit; - try - Result := DB.NotifyExtenders(ffeaBeforeTabPack, ffeaTabPackFail); - { Exit if the extenders give us an error. } - if Result <> DBIERR_NONE then - Exit; - - FFGetMem(RebuildParamsPtr, SizeOf(RebuildParamsPtr^)); {!!.13} - FillChar(RebuildParamsPtr^, SizeOf(RebuildParamsPtr^), 0); - with RebuildParamsPtr^ do begin - rpDB := TffSrDatabase.Create(DB.Engine, - DB.Session, - DB.Folder, - DB.Alias, - DB.OpenMode, - DB.ShareMode, - DB.Timeout, - DB.CheckSpace); {!!.11} - rpDB.State := ffosActive; - { Update the folder's reference count. } - DB.Folder.IncRefCount; - rpTableName := aTableName; - rpIndexName := ''; - rpIndexID := 0; - - try - { Open the table for exclusive write access; TablePackPrim - is responsible for closing the cursor. } -{Begin !!.11} - SrcTblVersionChanged := False; - if rpDB.Folder.PackSrcTableVersion <> 0 then begin - SrcTblVersionChanged := True; - rpDB.Folder.ExistingTableVersion := - rpDB.Folder.PackSrcTableVersion; - end; -{End !!.11} - Result := TableOpen(rpDB.DatabaseID, - aTableName, False, '', 0, omReadWrite, - smExclusive, DB.Timeout, CursorID, nil); -{Begin !!.11} - if SrcTblVersionChanged then - rpDB.Folder.ExistingTableVersion := 0; -{End !!.11} - if Result <> DBIERR_NONE then Abort; - - seCheckCursorIDAndGet(CursorID, TffSrBaseCursor(rpCursor)); - rpCursor.State := ffosActive; - rpCursor.CloseTable := True; - - try - { Start an implicit, read-only transaction. } - if not assigned(DB.Transaction) then begin - Result := seTransactionStart(rpDB, false, - ffcl_TrImplicit, TransID); - StartedTrans := (Result = DBIERR_NONE); - end; - - if Result <> DBIERR_NONE then Abort; - - { Get the total nondeleted records in the table } - FFTblGetRecordInfo(rpCursor.Table.Files[0], - rpDB.TransactionInfo, - RecordInfo); - if StartedTrans then begin - seTransactionCommit(rpDB); - StartedTrans := False; - end; - rpRebuildStatus := RebuildRegister - (TffSrClient(rpDB.Client).ClientID, - RecordInfo.riRecCount); - aRebuildID := rpRebuildStatus.RebuildID; - - { Setup the destination file(s). Use a basename of _PACK<x> - where <x> starts and 1 and is incremented upward until a - nonexistant filename is found. } - TargetBasename := SetTargetBasename(DB.Folder.Path, - ffcPackBaseName); - - { Capture the data dictionary } - SourceDict := rpCursor.Table.Dictionary; - TargetDict := TffServerDataDict.Create(SourceDict.BlockSize); - try - - { Setup the new (temporary) table } - TargetDict.Assign(SourceDict); - Result := TableBuild(rpDB.DatabaseID, False, TargetBasename, - False, TargetDict); - if Result <> DBIERR_NONE then Abort; - try - - { Bind the user-defined index routines (if any) to the - target table } - for I := 1 to TargetDict.IndexCount - 1 do - if (TargetDict.IndexType[I] = itUserDefined) then - with Configuration do begin - with rpCursor.Table do - Inx := KeyProcList.KeyProcIndex(Folder.Path, - BaseName, i); - if (Inx <> -1) then begin - KeyProcItem := KeyProcList[Inx]; - with KeyProcItem do begin - Link; - AddKeyProc(DB.Folder.Path, TargetBasename, I, - DLLName, BuildKeyName, - CompareKeyName); - end; - end else - FFRaiseExceptionNoData(EffServerException, - ffStrResServer, - fferrResolveTableLinks); - end; - try - - { Open the destination table for exclusive write access; - TablePackPrim is responsible for closing the cursor } - Result := TableOpen(rpDB.DatabaseID, - TargetBasename, False, - '', 0, omReadWrite, smExclusive, - DB.Timeout, CursorID, nil); - if Result <> DBIERR_NONE then Abort; - seCheckCursorIDAndGet(CursorID, - TffSrBaseCursor(rpTargetCursor)); - rpTargetCursor.State := ffosActive; - rpTargetCursor.Table.AddAttribute(fffaBLOBChainSafe); {!!.03} - rpTargetCursor.CloseTable := True; - finally - - { Get rid of the temporary user-defined index bindings } - for I := 1 to TargetDict.IndexCount - 1 do - if (TargetDict.IndexType[I] = itUserDefined) then - with Configuration do - if KeyProcList.KeyProcExists(DB.Folder.Path, - TargetBaseName, I) then - KeyProcList.DeleteKeyProc(DB.Folder.Path, - TargetBaseName, I); - end; - - try - { Create a separate thread for the pack operation } - TffSrPackThread.Create(Self, RebuildParamsPtr); - - { The thread constructor is responsible for - deallocating this memory block } - RebuildParamsPtr := nil; - except - rpTargetCursor.State := ffosInactive; - CursorClose(rpTargetCursor.CursorID); - raise; - end; - except - { Clean up the files } - TableDelete(rpDB.DatabaseID, TargetBasename); - raise; - end; -{Begin !!.05} - finally - TargetDict.Free; - end; -{End !!.05} - except - rpCursor.State := ffosInactive; - CursorClose(rpCursor.CursorID); - raise; - end; - except - rpDB.State := ffosInactive; - RebuildDeregister(aRebuildID); - raise; - end; - end; - finally - DB.Deactivate; - end; - except - on E : Exception do begin - if Result = DBIERR_NONE then - Result := ConvertServerException(E, FEventLog); -{Begin !!.13} - if Assigned(RebuildParamsPtr) then begin - if StartedTrans then - seTransactionRollback(RebuildParamsPtr^.rpDB); - FFFreeMem(RebuildParamsPtr, SizeOf(RebuildParamsPtr^)); - end; { if } -{End !!.13} - end; - end; -end; - -function TffServerEngine.seTablePackPrim(aRebuildParamsPtr: PffSrRebuildParams): TffResult; -const - { Action intervals } - aiSnapshot = 10; { every x records, update the status snapshot } - aiYield = 10; { every x records, yield for other messages } - -{Begin !!.03} - BLOBBufLen = ffcl_1MB; { size of BLOB transfer buffer } - RecBuf = ffcl_1MB; { max memory for records before flushing } - MaxBLOBBytes = 10 * ffcl_1MB; { max # of BLOB bytes that may be copied before - committing the transaction. } -{End !!.03} -var - aiFlush : integer; - BLOBBytesCopied : Integer; {!!.03} - RecordBuf: PffByteArray; - BufLength: LongInt; - SaveBaseName : TffTableName; - TargetRecordBuf: PffByteArray; - TargetBufLength: LongInt; - IsNull: Boolean; - RAMTrigger : Longint; {!!.03} - RefNr: TffInt64; - SourceName: TffTableName; - TargetName: TffTableName; - Restructuring: Boolean; - BLOBBuffer: Pointer; - AutoIncField: Integer; - AutoIncHighValue: TffWord32; - ThisAutoIncValue: TffWord32; - TransID : TffTransID; - - RecordsRead: LongInt; - RecordsWritten: LongInt; - - NextFlushPoint: LongInt; - NextSnapshotPoint: LongInt; - {$IFNDEF ThreadedRebuilds} - {NextYieldPoint: LongInt;} {!!.03} - {$ENDIF} - - procedure FindAutoIncField; - var - TargetAutoInc: Integer; - begin - with aRebuildParamsPtr^ do - if rpTargetCursor.Table.Dictionary.HasAutoIncField(TargetAutoInc) then - AutoIncField := TargetAutoInc; - end; - - procedure AllocateBLOBTransferBuffer; - { Don't allocate a BLOB transfer buffer unless we actually - need one (i.e., there may not be any BLOBs in this record } - begin - if not Assigned(BLOBBuffer) then - FFGetMem(BLOBBuffer, BLOBBufLen); - end; - - procedure ReleaseBLOBTransferBuffer; - begin - if Assigned(BLOBBuffer) then - FFFreeMem(BLOBBuffer, BLOBBufLen); - end; - - function CopyBLOBs(var BLOBBytesCopied : Integer): TffResult; {!!.03} - var - I: Integer; - SourceBLOBNr: TffInt64; - TargetBLOBNr: TffInt64; - IsNull: Boolean; - begin - Result := DBIERR_NONE; - - with aRebuildParamsPtr^ do - with rpCursor.Table.Dictionary do - for I := 0 to FieldCount - 1 do - - { Find all the BLOB fields in the record } - if (FieldType[I] >= fftBLOB) and - (FieldType[I] <= ffcLastBLOBType) then begin - GetRecordField(I, RecordBuf, IsNull, @SourceBLOBNr); - if IsNull then - with rpTargetCursor.Table.Dictionary do - SetRecordField(I, TargetRecordBuf, nil) - else begin - AllocateBLOBTransferBuffer; - -{Begin !!.03} - inc(BLOBBytesCopied, rpCursor.BLOBGetLength(SourceBLOBNr, Result)); - if Result <> DBIERR_NONE then Abort; -{End !!.03} - - Result := rpTargetCursor.bcBLOBCopy - (rpCursor, SourceBLOBNr, TargetBLOBNr); - if Result <> DBIERR_NONE then Abort; - - with rpTargetCursor.Table.Dictionary do - SetRecordField(I, TargetRecordBuf, @TargetBlobNr); - end; - end; - end; - - function FillTargetBuffer(aSourceCursor, aTargetCursor: TffSrCursor; - aSourceBuf, aTargetBuf: PffByteArray; - aFieldMap: TffSrFieldMapList; {!!.03} - var BLOBBytesCopied : Integer): TffResult; {!!.03} - { Copies the fields from the source buffer into the target buffer } - var - I: Integer; - IsNull: Boolean; - BLOBNr: TffInt64; - SourceBLOBNr: TffInt64; {!!.03} - begin - { The FieldMap has already been validated so we can assume all the - fieldnames and datatype matches are legal. } - { WARNING: the above assumption is no longer valid. Some matches are now - checked for during restructure and an exception is raised below if invalid. } {!!.10} - Result := DBIERR_NONE; - - { Initialize the output buffer. All fields will be null by default, - therefore we do not have to explicitly handle any new fields added - by the restructure. } - aTargetCursor.Table.Dictionary.InitRecord(aTargetBuf); - - { Loop through all the fields to be converted } - for I := 0 to aFieldMap.Count - 1 do - with aFieldMap do begin -{Begin !!.03} - if TargetField[I].FieldType in [fftBLOB..ffcLastBLOBType] then begin - AllocateBLOBTransferBuffer; - { Obtain the length of the source BLOB. } - if (SourceField[I].FieldType in [fftBLOB..ffcLastBLOBType]) then begin {!!.13} - aSourceCursor.Table.Dictionary.GetRecordField(SourceField[I].Number, - aSourceBuf, - IsNull, @SourceBLOBNr); - if (not IsNull) then - inc(BLOBBytesCopied, - aSourceCursor.BLOBGetLength(SourceBLOBNr, Result)); - if Result <> DBIERR_NONE then Break; - end - else {!!.13} - inc(BLOBBytesCopied, aFieldMap.SourceField[I].FieldLength);{!!.13} - end; -{End !!.03} - - Result := seConvertSingleField(aSourceBuf, - aTargetBuf, - aSourceCursor.CursorID, - aTargetCursor.CursorID, - SourceField[I].Number, - TargetField[I].Number, - BLOBBuffer, - BLOBBufLen); - if Result <> DBIERR_NONE then - {Begin !!.10} - if Result = DBIERR_INVALIDFLDXFORM then - FFRaiseException(EffException, ffStrResServer, fferrBadFieldXform, - [SourceField[I].Name+' ('+ - GetEnumName(TypeInfo(TffFieldtype), Integer(SourceField[I].FieldType))+')', - TargetField[I].Name+' ('+ - GetEnumName(TypeInfo(TffFieldtype), Integer(TargetField[I].FieldType))+')']) - - else - {End !!.10} - Break; - end; - - { Check for fields not converted that may be "required" (i.e., added - fields that have the "required" flag set) } - with aTargetCursor.Table.Dictionary do begin - for I := 0 to FieldCount - 1 do begin - GetRecordField(I, aTargetBuf, IsNull, nil); - if IsNull and FieldRequired[I] then begin - - { Clear the null flag, the record buffer is already set to zero } - FFClearBit(PffByteArray(@aTargetBuf^[LogicalRecordLength]), I); - - { For BLOBs we have to create an empty BLOB } - if FieldType[I] in [fftBLOB..ffcLastBLOBType] then begin - AllocateBLOBTransferBuffer; - Result := aTargetCursor.BLOBAdd(BLOBNr); - SetRecordField(I, aTargetBuf, @BLOBNr); - if Result = DBIERR_NONE then - Result := aTargetCursor.BLOBWrite(BLOBNr, 0, 0, BLOBBuffer); - end; - end; - end; - end; - end; - - function SetTargetBasename(Path: TffPath; Root: TffFileName): TffFileName; - var - I: Integer; - begin - I := 0; - repeat - Inc(I); - Result := Root + IntToStr(I); - until not FFFileExists(FFMakeFullFilename(Path, - FFMakeFileNameExt(Result, - ffc_ExtForData))); - end; - -begin - Result := DBIERR_NONE; - AutoIncField := -1; - AutoIncHighValue := 0; - BLOBBytesCopied := 0; {!!.03} - RAMTrigger := seBufMgr.MaxRAM + (seBufMgr.MaxRAM div 10); {!!.03} - RecordsRead := 0; - RecordsWritten := 0; - FFSetRetry(0); - with aRebuildParamsPtr^ do begin - try - try - rpCursor.Timeout := 0; - rpTargetCursor.Timeout := 0; - rpDb.Timeout := 0; - TargetRecordBuf := nil; - TargetBufLength := 0; - - { Find first AutoInc field, if any } - FindAutoIncField; - - { Decide if we are performing a restructure as well } - Restructuring := Assigned(rpFieldMap); - if Restructuring then begin - - { Allocate an output record buffer } - TargetBufLength := rpTargetCursor.Table.Dictionary.RecordLength; - FFGetMem(TargetRecordBuf, TargetBufLength); - end; - - try - try - try - try - BLOBBuffer := nil; - - SourceName := rpCursor.Table.Basename; - TargetName := rpTargetCursor.Table.Basename; - - - { Allocate a record buffer } - BufLength := rpCursor.Table.Dictionary.RecordLength; - FFGetMem(RecordBuf, BufLength); - - { Figure out how many records are to be processed before - flushing. } - aiFlush := (RecBuf div BufLength); - - try - try - - { For packs, TargetRecordBuf points to the input buffer as well } - if not Assigned(TargetRecordBuf) then - TargetRecordBuf := RecordBuf; - - Result := seTransactionStart(rpDB, False, False, TransID); - if Result <> DBIERR_NONE then Abort; - try - NextFlushPoint := aiFlush; - NextSnapshotPoint := aiSnapshot; - {$IFNDEF ThreadedRebuilds} - {NextYieldPoint := aiYield;} {!!.03} - {$ENDIF} - - RefNr.iLow := 0; - RefNr.iHigh := 0; - - { Loop through all the nondeleted records... } - rpCursor.Table.GetNextRecordSeq(rpDB.TransactionInfo, - RefNr, RecordBuf); - while not ((RefNr.iLow = 0) and (RefNr.iHigh = 0)) do begin - Inc(RecordsRead); - - { Copy record to the new output file, restructuring - along the way if needed. } - if Restructuring then begin - FillTargetBuffer(rpCursor, - rpTargetCursor, - RecordBuf, - TargetRecordBuf, - rpFieldMap, {!!.03} - BLOBBytesCopied); {!!.03} - end - else begin - - { Copy BLOBs, if any, to the new table } - Result := CopyBLOBs(BLOBBytesCopied); {!!.03} - if Result <> DBIERR_NONE then Abort; - end; - - { Add the record into the new table } - Result := rpTargetCursor.InsertRecord(TargetRecordBuf, - ffsltExclusive); - if Result <> DBIERR_NONE then - Abort; - - { For fftAutoInc targets, keep track of the largest value observed } - if AutoIncField <> -1 then begin - rpTargetCursor.Table.Dictionary.GetRecordField(AutoIncField, - TargetRecordBuf, - IsNull, - @ThisAutoIncValue); - if not IsNull and (ThisAutoIncValue > AutoIncHighValue) then - AutoIncHighValue := ThisAutoIncValue; - end; - - Inc(RecordsWritten); - - { See if it's time to flush our work so far } - if (RecordsRead >= NextFlushPoint) or {!!.03} - (BLOBBytesCopied >= MaxBLOBBytes) or {!!.03} - (seBufMgr.RAMUsed >= RAMTrigger ) then begin {!!.03} - - if (RecordsRead >= NextFlushPoint) then {!!.13} - Inc(NextFlushPoint, aiFlush); - BLOBBytesCopied := 0; {!!.03} - if seTransactionCommitSubset(rpDB) <> DBIERR_NONE then - FFRaiseExceptionNoData(EffServerException, - ffStrResServer, - fferrTransactionFailed); - end; - - { See if it's time to update the status packet } - if RecordsRead >= NextSnapshotPoint then begin - Inc(NextSnapshotPoint, aiSnapshot); - rpRebuildStatus.MakeSnapshot(RecordsRead, - RecordsWritten, - DBIERR_NONE); - end; - -{Deleted !!.01} - {$IFNDEF ThreadedRebuilds} - { See if it's time to yield for other messages } -{ if RecordsRead >= NextYieldPoint then begin - Inc(NextYieldPoint, aiYield); - Application.ProcessMessages; - end;} - {$ENDIF} - - rpCursor.Table.GetNextRecordSeq(rpDB.TransactionInfo, - RefNr, RecordBuf); - end; - - { Post the autoinc value if needed } - if AutoIncField <> -1 then - FFTblSetAutoIncValue(rpTargetCursor.Table.Files[0], - rpDB.TransactionInfo, - AutoIncHighValue); -// finally {Deleted !!.01} - { Save all data changes } - if seTransactionCommit(rpDB) <> DBIERR_NONE then - FFRaiseExceptionNoData(EffServerException, - ffStrResServer, - fferrTransactionFailed); -{Begin !!.01} - except - seTransactionRollback(rpDB); - raise; -{End !!.01} - end; - finally - ReleaseBLOBTransferBuffer; - end; - finally - { Deallocate the record buffer } - FFFreeMem(RecordBuf, BufLength); - end; - finally - { Close the target cursor } - rpTargetCursor.State := ffosInactive; - CursorClose(rpTargetCursor.CursorID); - end; - finally - { Close the source cursor } - rpCursor.State := ffosInactive; - CursorClose(rpCursor.CursorID); - end; - except - { An error occurred somewhere in the process; clean up the files} - TableDelete(rpDB.DatabaseID, TargetName); - raise; - end; - - { Replace the original file with the working file. - First step: Rename the old table. We will restore it if an - error occurs. } - SaveBaseName := SetTargetBaseName(rpDB.Folder.Path, ffcSaveBaseName); - Result := TableRename(rpDB.DatabaseID, SourceName, SaveBaseName); - if Result = DBIERR_NONE then begin - try - { Rename the new table to the old table. } - Result := TableRename(rpDB.DatabaseID, TargetName, SourceName); - except - { If an exception occurs then put the original table back in its - place. } - TableRename(rpDB.DatabaseID, SaveBaseName, SourceName); - raise; - end; - { Everything worked so far. Delete the original table. } - Result := TableDelete(rpDB.DatabaseID, SaveBaseName); - end; - finally - rpDB.State := ffosInactive; - rpDB.Free; - { Release the output record buffer, if allocated separately from - the input record buffer } - if Restructuring then - FFFreeMem(TargetRecordBuf, TargetBufLength); - end; - except - on E : Exception do begin - if Result = DBIERR_NONE then - Result := ConvertServerExceptionEx(E, FEventLog, {!!.01} - bseGetReadOnly); {!!.01} - end; - end; - finally - { Shut down the rebuild status indicator } - rpRebuildStatus.MakeSnapshot(RecordsRead, - RecordsWritten, - Result); - RebuildDeregister(rpRebuildStatus.RebuildID); - end; - end; -end; - diff --git a/components/flashfiler/sourcelaz/ffsrrcnt.inc b/components/flashfiler/sourcelaz/ffsrrcnt.inc deleted file mode 100644 index 741180092..000000000 --- a/components/flashfiler/sourcelaz/ffsrrcnt.inc +++ /dev/null @@ -1,228 +0,0 @@ -{*********************************************************} -{* FlashFiler: async get record count 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 - * Thorsten Engler - * - * Portions created by the Initial Developer are Copyright (C) 2000-2002 - * the Initial Developer. All Rights Reserved. - * Used with permission. - * - * Modified from the original to fit the width of your screen - * & to be compatible with FlashFiler 2. - * - * Contributor(s): - * - * ***** END LICENSE BLOCK ***** *) - -function TffServerEngine.TableGetRecCountAsync(aCursorID : TffCursorID; - var aTaskID : Longint) : TffResult; -var - Cursor : TffSrBaseCursor; - RebuildParamsPtr: PffSrRebuildParams; - RecordInfo: TffRecordInfo; -begin - Result := DBIERR_NONE; - aTaskID := -1; - - try - Result := CheckCursorIDAndGet(aCursorID, Cursor); - try - if Result <> DBIERR_NONE then - Exit; - FFGetMem(RebuildParamsPtr, SizeOf(RebuildParamsPtr^)); {!!.13} - try - FillChar(RebuildParamsPtr^, SizeOf(RebuildParamsPtr^), 0); - with RebuildParamsPtr^ do begin - rpDB := nil; - rpTableName := ''; - rpIndexName := ''; - rpIndexID := 0; - - try - rpCursor := TffSrCursor(Cursor.CloneCursor(omReadOnly)); - try - rpCursor.State := ffosActive; - { Get the total nondeleted records in the table } - FFTblGetRecordInfo(rpCursor.Table.Files[0], - rpCursor.Database.TransactionInfo, - RecordInfo); - rpRebuildStatus := RebuildRegister - (TffSrClient(rpCursor.Database.Client).ClientID, - RecordInfo.riRecCount); - aTaskID := rpRebuildStatus.RebuildID; - - { Create a separate thread for the pack operation } - TffSrGetRecordCountThread.Create(Self, RebuildParamsPtr); - - { The thread constructor (32-bit) or message handler (16-bit) - are responsible for deallocating this memory block } - RebuildParamsPtr := nil; - except - rpCursor.State := ffosInactive; - CursorClose(rpCursor.CursorID); - raise; - end; - except - RebuildDeregister(aTaskID); - raise; - end; - end; - except - if Assigned(RebuildParamsPtr) then {!!.13} - FFFreeMem(RebuildParamsPtr, SizeOf(RebuildParamsPtr^)); {!!.13} - raise; - end; - finally - Cursor.Deactivate; - end; - except - on E : Exception do begin - if Result = DBIERR_NONE then - Result := ConvertServerException(E, FEventLog); - end; - end; -end; - -type - TffSrCursorHacker=class(TffSrCursor); - -function TffServerEngine.seTableGetRecordCountPrim(aRebuildParamsPtr: PffSrRebuildParams): TffResult; -const - { Action intervals } - aiSnapshot = 128; { every x records, update the status snapshot } -var - Action : TffSearchKeyAction; - KeyCompareResult : integer; - Info : TffRecordInfo; - RecordsRead : Longint; - RecordsMatched : Longint; - NextSnapshotPoint: Longint; -begin - Result := DBIERR_NONE; - aRebuildParamsPtr^.rpCursor.AcqContentLock(ffclmRead); - try - with aRebuildParamsPtr^, TffSrCursorHacker(rpCursor) do begin - rpCursor.Timeout := 0; - NextSnapshotPoint := aiSnapshot; - RecordsRead := 0; - RecordsMatched := 0; - try - if bcHasRange or Assigned(bcFilter) then begin - - SetToBegin; - if bcHasRange and bcRng1Valid then begin - {position at start of range} - if bcRng1Incl then - Action := skaGreaterEqual - else - Action := skaGreater; - {note: the following FindKey call will always return true in - this case} - Move(bcRng1Key^, bcCurKey^, scKeyLen); - with bcCompareData do begin - cdFldCnt := bcRng1FldCnt; - cdPartLen := bcRng1PtlLen; - end; - Table.FindKey(bcKID, bcInfo.RefNr, Database.TransactionInfo, - bcCurKey, bcInfo.KeyPath, Action); - {check whether the keypath was positioned at EOF, if so the - start of the range is at EOF, so it's not likely we'll find a - 'next' key or any keys at all <g>} - if (bcInfo.KeyPath.kpPos = kppEOF) then begin - {note the reset of the cursor position still occurs} - Exit; - end; - {make sure that the keypath is on the crack before the key so that - the next key call in a minute returns the right record} - if (bcInfo.KeyPath.kpPos = kppOnKey) then - bcInfo.KeyPath.kpPos := kppOnCrackBefore; - end; - {while not EOF or other error do} - while (Result = DBIERR_NONE) do begin - {readnext key} - Result := Table.GetNextKey(bcKID, bcInfo.RefNr, - Database.TransactionInfo, - bcCurKey, bcInfo.KeyPath); - if (Result = DBIERR_NONE) then begin - {check that we're in range if required} - if bcHasRange and bcRng2Valid then begin - {check whether beyond end of range} - with bcCompareData do begin - cdFldCnt := bcRng2FldCnt; - cdPartLen := bcRng2PtlLen; - end; - KeyCompareResult := - Table.CompareKeysForCursor(bcKID, bcCurKey, bcRng2Key); - if (KeyCompareResult > 0) or - ((KeyCompareResult = 0) and (not bcRng2Incl)) then begin - Result := DBIERR_EOF; - end - else {key is in range} begin - if Assigned(bcFilter) then begin - Table.GetRecordNoLock(Database.TransactionInfo, - bcInfo.RefNr, - bcRecordData); - if bcFilter.MatchesRecord(bcRecordData) then - inc(RecordsMatched); - end else - inc(RecordsMatched); - end; - end - else {end of range = end of index path} begin - if Assigned(bcFilter) then begin - Table.GetRecordNoLock(Database.TransactionInfo, - bcInfo.RefNr, bcRecordData); - if bcFilter.MatchesRecord(bcRecordData) then - inc(RecordsMatched); - end else - Inc(RecordsMatched); - end; - inc(RecordsRead); - - { See if it's time to update the status packet } - if RecordsRead >= NextSnapshotPoint then begin - Inc(NextSnapshotPoint, aiSnapshot); - rpRebuildStatus.MakeSnapshot(RecordsRead, - RecordsMatched, - DBIERR_NONE); - end; - end; - end; - end - else begin - FFTblGetRecordInfo(Table.Files[0], Database.TransactionInfo, Info); - RecordsMatched := Info.riRecCount; - RecordsRead := Info.riRecCount; - end; - Result:= DBIERR_NONE; - finally - { Shut down the rebuild status indicator } - rpRebuildStatus.MakeSnapshot(RecordsRead, - RecordsMatched, - Result); - RebuildDeregister(rpRebuildStatus.RebuildID); - end; - end; - finally - aRebuildParamsPtr^.rpCursor.RelContentLock(ffclmRead); - aRebuildParamsPtr^.rpCursor.Deactivate; - CursorClose(aRebuildParamsPtr^.rpCursor.CursorID); {!!.10} - end; -end; diff --git a/components/flashfiler/sourcelaz/ffsrrest.inc b/components/flashfiler/sourcelaz/ffsrrest.inc deleted file mode 100644 index b4200fdb5..000000000 --- a/components/flashfiler/sourcelaz/ffsrrest.inc +++ /dev/null @@ -1,328 +0,0 @@ -{*********************************************************} -{* FlashFiler: table restructure 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 ***** *) - -function TffServerEngine.TableRestructure(aDatabaseID : TffDatabaseID; - const aTableName : TffTableName; - aDictionary : TffDataDictionary; - aFieldMap : TffStringList; - var aRebuildID : LongInt): TffResult; -var - DB : TffSrDatabase; - RebuildParamsPtr: PffSrRebuildParams; - TargetBasename: TffFileName; - RecordInfo: TffRecordInfo; - CursorID: TffCursorID; - SourceClosed: Boolean; - SourceDeleted: Boolean; - I, L: Integer; - Inx: Integer; - KeyProcItem : TffKeyProcItem; - StartedTrans : boolean; - - function ValidateFieldMap(aSourceCursorID, - aTargetCursorID: LongInt; - aFieldExMap: TffSrFieldMapList): TffResult; - var - I: Integer; - begin - Result := DBIERR_NONE; - with aFieldExMap do begin - for I := 0 to Count - 1 do begin - Result := seConvertSingleField(nil, - nil, - aSourceCursorID, - aTargetCursorID, - SourceField[I].Number, - TargetField[I].Number, - nil, - 0); - if Result <> DBIERR_NONE then - FFRaiseException(EffServerException, ffStrResServer, fferrBadFieldXform, [SourceField[I].Name, TargetField[I].Name]); - end; - end; - end; - - function SetTargetBasename(Path: TffPath; Root: TffFileName): TffFileName; - var - I: Integer; - begin - I := 0; - repeat - Inc(I); - Result := Root + IntToStr(I); - until not FFFileExists(FFMakeFullFilename(Path, - FFMakeFileNameExt(Result, - ffc_ExtForData))); - end; - -begin - if IsReadOnly then begin {!!.01 - Start} - Result := DBIERR_TABLEREADONLY; - Exit; - end else {!!.01 - End} - Result := DBIERR_NONE; - aRebuildID := -1; - StartedTrans := False; - RebuildParamsPtr := nil; - - try - SourceClosed := False; - SourceDeleted := False; - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if Result <> DBIERR_NONE then - Exit; - try - Result := DB.NotifyExtenders(ffeaBeforeTabRestruct, ffeaTabRestructFail); - { Exit if the extenders give us an error. } - if Result <> DBIERR_NONE then - exit; - - FFGetMem(RebuildParamsPtr, SizeOf(RebuildParamsPtr^)); {!!.13} - FillChar(RebuildParamsPtr^, SizeOf(RebuildParamsPtr^), 0); - with RebuildParamsPtr^ do begin - rpDB := TffSrDatabase.Create(DB.Engine, - DB.Session, - DB.Folder, - DB.Alias, - DB.OpenMode, - DB.ShareMode, - DB.Timeout, - DB.CheckSpace); {!!.11} - rpDB.State := ffosActive; - { Update the folder's reference count. } - DB.Folder.IncRefCount; - rpTableName := aTableName; - rpIndexName := ''; - rpIndexID := 0; - { Open the table for exclusive write access; TablePackPrim - is responsible for closing the cursor. } - Result := TableOpen(rpDB.DatabaseID, - aTableName, False, '', 0, - omReadWrite, smExclusive, DB.Timeout, CursorID, - nil); - if Result <> DBIERR_NONE then Abort; - seCheckCursorIDAndGet(CursorID, TffSrBaseCursor(rpCursor)); - rpCursor.State := ffosActive; - rpCursor.CloseTable := True; - { Get the total nondeleted records in the table } - FFTblGetRecordInfo(rpCursor.Table.Files[0], - rpDB.TransactionInfo, - RecordInfo); - try - - { Check the source and target indexes. Can't preserve data if the - sequence of user-defined indexes has been altered. } - if Assigned(aFieldMap) then - with rpCursor.Table.Dictionary do begin - if IndexCount > aDictionary.IndexCount then begin - L := aDictionary.IndexCount; - { Deleting user-defined indexes is OK } - end - else begin - L := IndexCount; - { see if we've added user-defined indexes } - for I := L to aDictionary.IndexCount - 1 do - if (aDictionary.IndexType[I] = itUserDefined) and - (RecordInfo.riRecCount > 0) then begin {!!.13} - Result := DBIERR_INVALIDRESTROP; - Abort; { to trigger exception handlers } - end; - end; - - { See if there have been changes to existing user-defined indexes } - for I := 1 to L - 1 do - if (aDictionary.IndexType[I] = itUserDefined) and - ((IndexType[I] <> itUserDefined) or - (IndexKeyLength[I] <> aDictionary.IndexKeyLength[I])) then begin - Result := DBIERR_INVALIDRESTROP; - Abort; { to trigger exception handlers } - end; - end; - - { Setup the destination file(s). Use a basename of _REST<x> - where <x> starts at 1 and is incremented upward until a - nonexistant filename is found. } - TargetBasename := SetTargetBasename(DB.Folder.Path, '_REST'); - - { Setup the new (temporary) table } - Result := TableBuild(rpDB.DatabaseID, False, TargetBasename, False, - aDictionary); - if Result <> DBIERR_NONE then Abort; - try - - { If a field map is given to us, then pass info on so the - data can be reorganized. Otherwise, we just restructure - the table and lose all data. } - - if Assigned(aFieldMap) then begin - - { The underlying primitive method is responsible for - releasing this memory block } - rpFieldMap := TffSrFieldMapList.Create(rpCursor.Table.Dictionary, - aDictionary); - try - - { Bind the user-defined index routines (if any) to the - target table } - for I := 1 to aDictionary.IndexCount - 1 do - if (aDictionary.IndexType[I] = itUserDefined) then - with Configuration do begin - with rpCursor.Table do - Inx := KeyProcList.KeyProcIndex(Folder.Path, BaseName, - i); - if (Inx <> -1) then begin - KeyProcItem := KeyProcList[Inx]; - with KeyProcItem do begin - Link; - AddKeyProc(DB.Folder.Path, TargetBasename, I, - DLLName, BuildKeyName, CompareKeyName); - end; - end else - FFRaiseExceptionNoData(EffServerException, - ffStrResServer, - fferrResolveTableLinks); - end; - try - - { Open the destination table for exclusive write access; - TablePackPrim is responsible for closing the cursor } - Result := TableOpen(rpDB.DatabaseID, - TargetBasename, False, '', 0, - omReadWrite, smExclusive, DB.Timeout, - CursorID, nil); - if Result <> DBIERR_NONE then Abort; - seCheckCursorIDAndGet(CursorID, - TffSrBaseCursor(rpTargetCursor)); - rpTargetCursor.State := ffosActive; - rpTargetCursor.Table.AddAttribute(fffaBLOBChainSafe); {!!.03} - rpTargetCursor.CloseTable := True; - finally - - { Get rid of the temporary user-defined index bindings } - for I := 1 to aDictionary.IndexCount - 1 do - if (aDictionary.IndexType[I] = itUserDefined) then - with Configuration do - if KeyProcList.KeyProcExists(DB.Folder.Path, - TargetBaseName, I) then - KeyProcList.DeleteKeyProc(DB.Folder.Path, - TargetBaseName, I); - end; - - try - - { Expand the field map from string list to structured list } - Result := rpFieldMap.AddStringList(aFieldMap); - if Result <> DBIERR_NONE then Abort; - - { Validate the field map; translate into extended field map } - ValidateFieldMap(rpCursor.CursorID, - rpTargetCursor.CursorID, - rpFieldMap); - - rpRebuildStatus := RebuildRegister - (TffSrClient(rpDB.Client).ClientID, - RecordInfo.riRecCount); - try - aRebuildID := rpRebuildStatus.RebuildID; - - { Create a separate thread for the restructure operation } - TffSrRestructureThread.Create(Self, RebuildParamsPtr); - - { The thread constructor is responsible for deallocating - this memory block } - RebuildParamsPtr := nil; - except - RebuildDeregister(aRebuildID); - raise; - end; - except - rpTargetCursor.State := ffosInactive; - CursorClose(rpTargetCursor.CursorID); - raise; - end; - except - rpFieldMap.Free; - raise; - end; - end { if Assigned(aFieldMap) } - else begin - { No field map was given, so we just restructure the - table and lose the data } - - { Close the source cursor; the locks are cleared for us } - rpCursor.State := ffosInactive; - CursorClose(rpCursor.CursorID); - SourceClosed := True; { Defuse the exception handler } - - { Delete the original files, rename the working file } - Result := TableDelete(rpDB.DatabaseID, aTableName); - SourceDeleted := True; { Defuse the exception handler } - - { Rename the temporary work table to the original tablename } - if Result = DBIERR_NONE then - Result := TableRename(rpDB.DatabaseID, TargetBasename, aTableName); - - { Deallocate the parameters buffer } - FFFreeMem(RebuildParamsPtr, SizeOf(RebuildParamsPtr^)); {!!.13} - RebuildParamsPtr := nil; { Defuse the exception handler } - end;{ if not Assigned(aFieldMap) } - - { Clean up after ourselves if there are exeptions } - - except - { Clean up the files } - if not SourceDeleted then - seTableDeletePrim(rpDB, TargetBaseName); - raise; - end; - except - rpCursor.State := ffosInactive; - if not SourceClosed then - CursorClose(rpCursor.CursorID); - rpDB.State := ffosInactive; - raise; - end; - end; - finally - DB.Deactivate; - end; - except - on E : Exception do begin - if Result = DBIERR_NONE then - Result := ConvertServerExceptionEx(E, FEventLog, bseGetReadOnly); {!!.01} -{Begin !!.13} - if Assigned(RebuildParamsPtr) then begin - if StartedTrans then - seTransactionRollback(RebuildParamsPtr^.rpDB); - FFFreeMem(RebuildParamsPtr, SizeOf(RebuildParamsPtr^)); - end; { if } -{End !!.13} - end; - end; -end; diff --git a/components/flashfiler/sourcelaz/ffsrridx.inc b/components/flashfiler/sourcelaz/ffsrridx.inc deleted file mode 100644 index 08b7d4b43..000000000 --- a/components/flashfiler/sourcelaz/ffsrridx.inc +++ /dev/null @@ -1,395 +0,0 @@ -{*********************************************************} -{* FlashFiler: rebuild index 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 ***** *) - -function TffServerEngine.TableRebuildIndex(aDatabaseID : TffDatabaseID; - const aTableName : TffTableName; - const aIndexName : TffName; - aIndexID : LongInt; - var aRebuildID : LongInt): TffResult; - -var - DB : TffSrDatabase; - RebuildParamsPtr : PffSrRebuildParams; - CursorID : TffCursorID; - RecordInfo : TffRecordInfo; - StartedTrans : Boolean; - TransID : TffTransID; -begin - if IsReadOnly then begin {!!.01 - Start} - Result := DBIERR_TABLEREADONLY; - Exit; - end else {!!.01 - End} - Result := DBIERR_NONE; - aRebuildID := -1; - StartedTrans := False; - RebuildParamsPtr := nil; - try - Result := CheckDatabaseIDAndGet(aDatabaseID, DB); - if Result <> DBIERR_NONE then - Exit; - try - Result := DB.NotifyExtenders(ffeaBeforeRebuildInx, ffeaTabRebuildInxFail); - { Exit if the extenders give us an error. } - if Result <> DBIERR_NONE then - Exit; - - FFGetMem(RebuildParamsPtr, SizeOf(RebuildParamsPtr^)); {!!.13} - try - FillChar(RebuildParamsPtr^, SizeOf(RebuildParamsPtr^), 0); - with RebuildParamsPtr^ do begin - rpDB := TffSrDatabase.Create(DB.Engine, - DB.Session, - DB.Folder, - DB.Alias, - DB.OpenMode, - DB.ShareMode, - DB.Timeout, - DB.CheckSpace); {!!.11} - rpDB.State := ffosActive; - { Update the folder's reference count. } - DB.Folder.IncRefCount; - rpTableName := aTableName; - rpIndexName := aIndexName; - rpIndexID := aIndexID; - - try - { Open the table for exclusive write access; TableRebuildIndexPrim - is responsible for closing the cursor. } - Result := TableOpen(rpDB.DatabaseID, - aTableName, false, aIndexName, aIndexID, - omReadWrite, smExclusive, rpDB.Timeout, CursorID, - nil); - if Result <> DBIERR_NONE then Abort; - seCheckCursorIDAndGet(CursorID, TffSrBaseCursor(rpCursor)); - rpCursor.State := ffosActive; - rpCursor.CloseTable := True; - try - { Start an implicit, read-only transaction. } - if not assigned(rpDB.Transaction) then begin - Result := seTransactionStart(rpDB, false, - ffcl_TrImplicit, TransID); - StartedTrans := (Result = DBIERR_NONE); - end; - - if Result <> DBIERR_NONE then Abort; - - { Get the total nondeleted records in the table } - FFTblGetRecordInfo(rpCursor.Table.Files[0], - rpDB.TransactionInfo, RecordInfo); - - if StartedTrans then begin - seTransactionCommit(rpDB); - StartedTrans := False; - end; - - rpRebuildStatus := RebuildRegister - (TffSrClient(rpDB.Client).ClientID, - RecordInfo.riRecCount); - aRebuildID := rpRebuildStatus.RebuildID; - - { Lock the table; TableRebuildIndexPrim is responsible for - releasing the lock. } - Result := TableLockAcquire(CursorID, ffltWriteLock); - if Result <> DBIERR_NONE then Abort; - try - { Create a separate thread for the reindex operation } - TffSrReindexThread.Create(Self, RebuildParamsPtr); - - { The thread constructor is responsible for deallocating this - memory block } - RebuildParamsPtr := nil; - except - TableLockRelease(CursorID, false); - raise; - end; - except - rpCursor.State := ffosInactive; - CursorClose(CursorID); - raise; - end; - except - rpDB.State := ffosInactive; - RebuildDeregister(aRebuildID); - raise; - end; - end; - except - raise; - end; - finally - DB.Deactivate; - end; - except - on E : Exception do begin - if Result = DBIERR_NONE then - Result := ConvertServerException(E, FEventLog); -{Begin !!.13} - if Assigned(RebuildParamsPtr) then begin - if StartedTrans then - seTransactionRollback(RebuildParamsPtr^.rpDB); - FFFreeMem(RebuildParamsPtr, SizeOf(RebuildParamsPtr^)); - end; { if } -{End !!.13} - end; - end; -end; -{--------} -function TffServerEngine.seTableRebuildIndexPrim(aRebuildParamsPtr: PffSrRebuildParams): TffResult; -const - { Action intervals } -// aiFlush = 10; { every x records, flush dirty pages } {Deleted !!.05} - aiSnapshot = 10; { every x records, update the status snapshot } - aiYield = 10; { every x records, yield for other messages (16-bit) } -var - aiFlush : integer; {!!.05} - RecordInfo: TffRecordInfo; - RecordBuf: PffByteArray; - BufLength: LongInt; - Dict: TffServerDataDict; - OurTable: TffSrTable; - OurIndexID: longint; - OurIndexFileNumber: longint; - RefNr: TffInt64; - Compare: TffKeyCompareFunc; - OurKey: PffByteArray; - BuildKey: TffKeyBuildFunc; - CmpData : TffCompareData; - TransID : TffTransID; - - RecordsRead: LongInt; - RecordsWritten: LongInt; - - NextFlushPoint: LongInt; - NextSnapshotPoint: LongInt; - {$IFNDEF ThreadedRebuilds} - NextYieldPoint: LongInt; - {$ENDIF} - - IsComposite : Boolean; -begin - Result := DBIERR_NONE; - FFSetRetry(0); {!!.03} - - with aRebuildParamsPtr^ do begin - RecordsRead := 0; - RecordsWritten := 0; - try - try - try - try - - rpCursor.Timeout := 0; - rpDB.Timeout := 0; - - { Capture data dictionary, etc } - OurIndexID := rpCursor.IndexID; - OurTable := TffSrTable(rpCursor.Table); - Dict := OurTable.Dictionary; - OurIndexFileNumber := Dict.IndexFileNumber[OurIndexID]; - - { Set up the compare method for the index } - if (Dict.IndexType[OurIndexID] = itComposite) then begin - Compare := FFKeyCompareComposite; - IsComposite := true; - end - else begin - Compare := OurTable.stGetUserCompareKey(OurIndexID); - IsComposite := false; - end; - - { Start transaction -- to ensure all data changes are written to - the file } - Result := seTransactionStart(rpDB, False, False, TransID); - if Result <> DBIERR_NONE then Exit; - try - with CmpData do begin - cdKeyLen := Dict.IndexKeyLength[OurIndexID]; - cdIndex := OurIndexID; - cdDict := Dict; - cdFldCnt := 0; - cdPartLen := 0; - cdAscend := Dict.IndexIsAscending[OurIndexID]; - cdNoCase := Dict.IndexIsCaseInsensitive[OurIndexID]; - end; - - { Remove all the keys in the existing index } - rpCursor.ClearIndex; - if (Result <> DBIERR_NONE) then - FFRaiseExceptionNoData(EffServerException, ffStrResServer, fferrUnknownCursor); - { Post the dirty pages for the deleted keys } - if seTransactionCommitSubset(rpDB) <> DBIERR_NONE then - FFRaiseExceptionNoData(EffServerException, ffStrResServer, - fferrTransactionFailed); - - { Get the size of the record buffer } - FFTblGetRecordInfo(OurTable.Files[0], - rpDB.TransactionInfo, RecordInfo); - BufLength := RecordInfo.riRecLength; - - { Allocate a record buffer } - FFGetMem(RecordBuf, BufLength); -{Begin !!.05} - { Figure out how many records are to be processed before - flushing. } - aiFlush := (ffcl_1MB div BufLength); -{End !!.05} - try - - { Allocate key buffer } - FFGetMem(OurKey, CmpData.cdKeyLen); - try - NextFlushPoint := aiFlush; - NextSnapshotPoint := aiSnapshot; - {$IFNDEF ThreadedRebuilds} - NextYieldPoint := aiYield; - {$ENDIF} - - RefNr.iLow := 0; - RefNr.iHigh := 0; - - { Loop through all the nondeleted records... } - OurTable.GetNextRecordSeq(rpDB.TransactionInfo, - RefNr, RecordBuf); - while (not (RefNr.iLow = 0) and (RefNr.iHigh = 0)) do begin - Inc(RecordsRead); - - { Reindexing the Sequential Access Index } - if OurIndexID = 0 then begin - if OurTable.stInsertKeyPrim - (OurIndexFileNumber, - rpDB.TransactionInfo, - RefNr, - PffByteArray(@RefNr), - FFKeyCompareI64, - @CmpData) then - Inc(RecordsWritten) - else - FFRaiseExceptionNoData(EffServerException, ffStrResServer, - fferrKeyPresent); - end - else begin - - { Reindexing a composite index } - if IsComposite then begin - Result := OurTable.stBuildCompositeKey(OurIndexID, - RecordBuf, - OurKey, - 0, - 0); - end - - { Reindexing a user-defined index } - else begin - BuildKey := OurTable.stGetUserBuildKey(OurIndexID); - if not BuildKey(OurIndexID, - RecordBuf, - OurKey^, - CmpData.cdKeyLen) then - Result := DBIERR_KEYVIOL; - end; - if Result <> DBIERR_NONE then - Abort; - - if OurTable.stInsertKeyPrim - (OurIndexFileNumber, - rpDB.TransactionInfo, - RefNr, - OurKey, - Compare, - @CmpData) then - Inc(RecordsWritten) - else - Abort; - end; - - { See if it's time to flush our work so far } - if RecordsRead >= NextFlushPoint then begin - Inc(NextFlushPoint, aiFlush); - if seTransactionCommitSubset(rpDB) <> DBIERR_NONE then - FFRaiseExceptionNoData(EffServerException, - ffStrResServer, - fferrTransactionFailed); - end; - - { See if it's time to update the status packet } - if RecordsRead >= NextSnapshotPoint then begin - Inc(NextSnapshotPoint, aiSnapshot); - rpRebuildStatus.MakeSnapshot(RecordsRead, - RecordsWritten, - DBIERR_NONE); - end; - - {$IFNDEF ThreadedRebuilds} - { See if it's time to yield for other messages } - if RecordsRead >= NextYieldPoint then begin - Inc(NextYieldPoint, aiYield); - Application.ProcessMessages; - end; - {$ENDIF} - - OurTable.GetNextRecordSeq(rpDB.TransactionInfo, - RefNr, RecordBuf); - end; - finally - FFFreeMem(OurKey, CmpData.cdKeyLen); - end; - finally - FFFreeMem(RecordBuf, BufLength); - end; - finally - if seTransactionCommit(rpDB) <> DBIERR_NONE then - FFRaiseExceptionNoData(EffServerException, - ffStrResServer, - fferrTransactionFailed); - end; - finally - rpCursor.RelTableLock(false); - end; - finally - rpCursor.State := ffosInactive; - CursorClose(rpCursor.CursorID); - rpDB.State := ffosInactive; - rpDB.Free; - end; - except - on E : Exception do begin - if Result = DBIERR_NONE then - Result := ConvertServerExceptionEx(E, FEventLog, {!!.01} - bseGetReadOnly); {!!.01} - end; - end; - finally - rpRebuildStatus.MakeSnapshot(RecordsRead, - RecordsWritten, - Result); - RebuildDeregister(rpRebuildStatus.RebuildID); - end; - end; -end; - diff --git a/components/flashfiler/sourcelaz/ffsrsec.pas b/components/flashfiler/sourcelaz/ffsrsec.pas deleted file mode 100644 index 536aab567..000000000 --- a/components/flashfiler/sourcelaz/ffsrsec.pas +++ /dev/null @@ -1,216 +0,0 @@ -{*********************************************************} -{* FlashFiler: Client Security Monitor/Extender *} -{*********************************************************} - -(* ***** 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} //<-- soner added - -unit ffsrsec; - -interface - -uses - SysUtils, - fflleng, - ffllbase, - ffsreng, - ffsrbase, - ffsrbde; - -type - TffSecurityExtender = class(TffBaseEngineExtender) - public - constructor Create(aOwner : TffBaseEngineMonitor); override; - function Notify(aServerObject : TffObject; - aAction : TffEngineAction) : TffResult; override; - protected - end; - - TffSecurityMonitor = class(TffBaseEngineMonitor) - public - function Interested(aServerObject : TffObject) : TffBaseEngineExtender; override; - protected - procedure bemSetServerEngine(anEngine : TffBaseServerEngine); override; - end; - -implementation - -uses - ffsrcvex; - -{===TffSecurityMonitor===============================================} -function TffSecurityMonitor.Interested(aServerObject : TffObject) : TffBaseEngineExtender; -{Rewritten !!.11} -begin - { This should always be a TffSrBaseCursor, TffSrClient or TffDatabase, - but we need to check to be sure. } - Result := nil; - if (aServerObject is TffSrBaseCursor) then begin - { Do not create extenders for temporary files. Temporary files are - created by the SQL engine when it needs to build a result table. } - if not (fffaTemporary in - TffSrBaseCursor(aServerObject).Table.Files[0].fiAttributes) then - Result := TffSecurityExtender.Create(Self); - end - else if (aServerObject is TffSrDatabase) or - (aServerObject is TffSrClient) then - Result := TffSecurityExtender.Create(Self); -end; -{--------} -procedure TffSecurityMonitor.bemSetServerEngine(anEngine : TffBaseServerEngine); -begin - inherited bemSetServerEngine(anEngine); - AddInterest(TffSrClient); - AddInterest(TffSrDatabase); - AddInterest(TffSrBaseCursor); -end; -{====================================================================} - -{===TffSecurityExtender==============================================} -constructor TffSecurityExtender.Create(aOwner: TffBaseEngineMonitor); -begin - inherited Create(aOwner); - FActions := [ffeaBeforeAddInx, - ffeaBeforeBLOBCreate, - ffeaBeforeBLOBDelete, - ffeaBeforeBLOBGetLength, - ffeaBeforeBLOBRead, - ffeaBeforeBLOBTruncate, - ffeaBeforeBLOBWrite, - ffeaBeforeChgAliasPath, - ffeaBeforeDBDelete, - ffeaBeforeDBInsert, - ffeaBeforeDBRead, - ffeaBeforeFileBLOBAdd, - ffeaBeforeRebuildInx, - ffeaBeforeRecDelete, - ffeaBeforeRecInsert, - ffeaBeforeRecRead, - ffeaBeforeRecUpdate, - ffeaBeforeTabDelete, - ffeaBeforeTabInsert, - ffeaBeforeTableLock, - ffeaBeforeTabPack, - ffeaBeforeTabRead, - ffeaBeforeTabRestruct, - ffeaBeforeTabUpdate]; -end; - -function TffSecurityExtender.Notify(aServerObject : TffObject; - aAction : TffEngineAction) : TffResult; -var - ReqRights : TffUserRights; -begin - try - Result := DBIERR_NONE; - ReqRights := []; - - {don't check rights if this isn't a secure server} - if not TffServerEngine(FParent.ServerEngine).Configuration.GeneralInfo^.giIsSecure then - Exit; - { Ignore if this is not the right kind of server object. } - if (not (aServerObject is TffSrBaseCursor)) and {!!.01} - (not (aServerObject is TffSrDatabase)) and {!!.01} - (not (aServerObject is TffSrClient)) then - Exit; - {find what rights are needed for aAction} - case aAction of - {grouped by unique subsets of TffUserRights} - {record actions include actions for BLOBs - for example, - reading a BLOB would require the client to have the same - privileges as reading a record} - - {reading a record, BLOB, table, or database requires read privileges} - ffeaBeforeDBRead, - ffeaBeforeBLOBRead, - ffeaBeforeBLOBGetLength, - ffeaBeforeRecRead, - ffeaBeforeTabRead : ReqRights := [arRead]; - - {inserting a record, BLOB, table, or database requires insert privileges} - ffeaBeforeDBInsert, - ffeaBeforeBLOBCreate, - ffeaBeforeFileBLOBAdd, - ffeaBeforeRecInsert, - ffeaBeforeTabInsert : ReqRights := [arInsert]; - - {updating a table, writing to a BLOB, or truncating a BLOB requires - updates privileges} - ffeaBeforeBLOBWrite, - ffeaBeforeBLOBTruncate, - ffeaBeforeTabUpdate : ReqRights := [arUpdate]; - - {updating a record requires read and update privileges} - ffeaBeforeRecUpdate : ReqRights := [arRead, arUpdate]; - - {deleting a record, BLOB, table, or database requires delete privileges} - ffeaBeforeDBDelete, - ffeaBeforeBLOBDelete, - ffeaBeforeRecDelete, - ffeaBeforeTabDelete : ReqRights := [arDelete]; - - {restructuring a table requires the client to have delete, - insert, read, and update privileges} - ffeaBeforeTabRestruct : ReqRights := [arDelete, arInsert, arRead, arUpdate]; - - {packing a table requires delete and update privileges} - ffeaBeforeTabPack : ReqRights := [arDelete, arUpdate]; - - {adding or rebuilding an index requires insert, read, and - update privileges} - ffeaBeforeAddInx, - ffeaBeforeRebuildInx : ReqRights := [arInsert, arRead, arUpdate]; - - {locking a table or changing an alias requires read and - update privileges} - ffeaBeforeChgAliasPath, - ffeaBeforeTableLock : ReqRights := [arRead, arUpdate]; - end; {case} - - { If no rights required then exit. } - if ReqRights = [] then - exit; - - { Now that we know what rights are required, lets see if the - client has sufficient rights. } - if aServerObject is TffSrClient then begin - if (TffSrClient(aServerObject).Rights * ReqRights) <> ReqRights then - Result := DBIERR_NOTSUFFTABLERIGHTS; - end - else - if ((TffSrClient(TffServerObject(aServerObject).Client).Rights) * - ReqRights) <> ReqRights then - Result := DBIERR_NOTSUFFTABLERIGHTS; - except - on E : Exception do begin - Result := ConvertServerException(E, nil); - end; - end;{try..except} -end; -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/ffsrsort.pas b/components/flashfiler/sourcelaz/ffsrsort.pas deleted file mode 100644 index 61c7c93ba..000000000 --- a/components/flashfiler/sourcelaz/ffsrsort.pas +++ /dev/null @@ -1,728 +0,0 @@ -{*********************************************************} -{* FlashFiler: Sort 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 ffsrsort; - -interface - -uses - ffllbase, - fflldict, - ffsrcur, - ffsreng, - ffsrixhl; - -const - ffcl_MergeSortBufferSize : Longint = ffcl_1MB; - ffcl_MergeOrder = 5; - { # of merge files from which we are retrieving records at any one time. } - -type - TffSrSortEngineClass = class of TffSrBaseSortEngine; - - TffSrSortState = (ffspEmpty, ffspPutting, ffspGetting); - - { The following record type holds the information pertinent to each field - on which the records are being sorted. } - TffSrSortFieldInfo = packed record - fldDescriptor : TffFieldDescriptor; - fldInxHelper : TffSrIndexHelper; - fldLength : Longint; - fldNoCase : boolean; - fldOrderDir : TffOrderByDirection; - end; - - PffSrSortArray = ^TffSrSortArray; - TffSrSortArray = array[0..ffcl_MaxIndexFlds] of TffSrSortFieldInfo; - - PffSortBuffer = ^TffSortBuffer; - TffSortBuffer = array[0..ffcl_1MB] of byte; - - TffSrBaseSortEngine = class(TffObject) - protected - bsDB : TffSrDatabase; - {-The database containing the sorted table. } - - bsDict : TffDataDictionary; - {-The dictionary describing the sorted table. } - - bsEngine : TffServerEngine; - {-The engine managing the database & table. } - - bsNumFields : integer; - {-Number of fields on which sort is taking place. } - - bsRecLen : Longint; - {-The length of each record. } - - bsSortInfo : PffSrSortArray; - {-The set of sorting information required by the sorting engine. } - - public - constructor Create(anEngine : TffServerEngine; - aDB : TffSrDatabase; - aFieldsArray : TffFieldList; - const aOrderByArray : TffOrderByArray; - const aNumFields : integer; - aDict : TffDataDictionary; - const aIndexID : integer); virtual; - { Note: Creator is responsible for freeing the memory associated with - aFieldsArray & aOrderByArray. } - - destructor Destroy; override; - - function Get(aRecord : PffByteArray) : boolean; virtual; abstract; - function Put(aRecord : PffByteArray) : TffResult; virtual; abstract; - end; - - { This class performs a merge sort on a set of records. As methods are fed - to the engine via the Put method, this class places the records within a - buffer. When the buffer is full, the engine quick sorts the records and - writes them to a temporary cursor. - - The merge sort does not occur until the Get method is first called. - - When the Get method is first used to retrieve the sorted records, the - engine sorts the current buffer of records. It then ... } - TffSrMergeSortEngine = class(TffSrBaseSortEngine) - protected - msBuffer : PffSortBuffer; - {-The run buffer used to cache unsorted records during Put phase. } - - msBufferOffset : Longint; - {-The current offset into the buffer. } - - msCursorList : TffSrCursorList; - {-List of the cursor's containing the sorted buffers. } - - msCursorOnRec : array[0..pred(ffcl_MergeOrder)] of boolean; - {-Each element in this array has a one-to-one correspondence with the - elements in msMergeCursor. If an element in this array is set to True - then the corresponding cursor is positioned on a record that is to be - used for comparison. If the element is set to False then the cursor - is not set on a record to be used for comparison. } - - msMaxRecCount : Longint; - {-The maximum number of records that may be held in the buffer. } - - msMergeCursor : array[0..pred(ffcl_MergeOrder)] of TffSrSimpleCursor; - {-Array of cursors used for merging. } - - msMergeCursorCount : integer; - {-The number of cursors involved in one stage of merging. } - - msOutputCursor : TffSrSimpleCursor; - {-Cursor to which merged records are written. } - - msOutputStoreSize : TffWord32; - {-The calculated size for the output cursor's temporary storage file. - Calculated in msSetMergeCursors. } - - msPivotBuffer : PffByteArray; - {-Holds the pivot element during the quick sort. } - - msRecBuffer : PffByteArray; - {-Used to temporarily hold a record while it is being swapped with - another record. } - - msRecCount : Longint; - {-The number of records currently in msBuffer. } - - msRunIndex : Longint; - {-When a small number of records (i.e., fewer than can be stored in the - run buffer) are added to the engine, this variable serves as an index - into the run buffer during the Get phase. We retrieve the sorted - records from the run buffer instead of using any merge files. } - - msState : TffSrSortState; - {-The state of the sort engine. } - - msTotalCount : TffWord32; - {-The total number of records added to the sort engine. } - - { Protected methods } - function msCompRecs(PRec1, PRec2 : PffBytearray) : integer; - {-Used to compare two records. } - - function msFinalizeBuffer(const WriteToCursor : boolean) : TffResult; - {-Called when the in-memory run buffer is ready to be sorted and written - to a temporary cursor. If the run buffer is to be written to a - temporary cursor, set WriteToCursor to True. } - - procedure msGetNextRecord(aRecord : PffByteArray); - {-Finds the next record that should be written to the - output cursor. It pulls the records from a number of input cursors - that are being merged. } - - procedure msMerge; - {-Merges all the temporary cursors until there are ffcl_MergeOrder or - fewer temporary cursors left. } - - procedure msMergeCursors; - {-Used to merge a number of cursors into an output cursor. } - - procedure msNextRecord(const aCursorIndex : integer); - {-Positions a specific merge cursor to its next record. If the merge - cursor reaches EOF then this routine closes the cursor and adjusts - the msMergeCursor array. } - - procedure msSetMergeCursors; - {-Determines which cursors are to be used for merging. } - - procedure msSortBuffer; - {-Uses non-recursive quick sort algorithm to sort the in-memory record - buffer. The quick sort algorithm calculates the Median Of Three method - to calculate the pivot element. } - - procedure msSwapRecs(Rec1, Rec2 : Longint); - {-Used to swap two records within the in-memory buffer. } - - public - constructor Create(anEngine : TffServerEngine; - aDB : TffSrDatabase; - aFieldsArray : TffFieldList; - const aOrderByArray : TffOrderByArray; - const aNumFields : integer; - aDict : TffDataDictionary; - const aIndexID : integer); override; - { Note: Creator is responsible for freeing the memory associated with - aIndexHelperArray & aOrderByArray. } - - destructor Destroy; override; - - function Get(aRecord : PffByteArray) : boolean; override; - function Put(aRecord : PffByteArray) : TffResult; override; - end; - -var - ffcSortEngineClass : TffSrSortEngineClass = TffSrMergeSortEngine; - { The type of sort engine to be used by the server engine. } - -implementation - -uses - sysutils, - ffllexcp, - ffsrbase, - ffsrbde, - ffsrlock; - -{===TffSrBaseSortEngine==============================================} -constructor TffSrBaseSortEngine.Create(anEngine : TffServerEngine; - aDB : TffSrDatabase; - aFieldsArray : TffFieldList; - const aOrderByArray : TffOrderByArray; - const aNumFields : integer; - aDict : TffDataDictionary; - const aIndexID : integer); -var - FldInx, Index : integer; -begin - inherited Create; - bsDB := aDB; - bsDict := aDict; - bsEngine := anEngine; - bsNumFields := aNumFields; - bsRecLen := aDict.RecordLength; - - { Build the set of sorting information. } - FFGetMem(bsSortInfo, SizeOf(TffSrSortFieldInfo) * bsNumFields); - for Index := 0 to pred(aNumFields) do begin - FldInx := aFieldsArray[Index]; - with bsSortInfo^[Index] do begin - fldDescriptor := aDict.FieldDescriptor[FldInx]^; - fldInxHelper := aDict.IndexHelpers[aIndexID, Index]; - fldLength := aDict.FieldLength[FldInx]; - fldNoCase := aDict.IndexIsCaseInsensitive[aIndexID]; - fldOrderDir := aOrderByArray[Index]; - end; - end; -end; -{--------} -destructor TffSrBaseSortEngine.destroy; -begin - if assigned(bsSortInfo) then - FFFreeMem(bsSortInfo, SizeOf(TffSrSortFieldInfo) * bsNumFields); - inherited Destroy; -end; -{====================================================================} - -{===TffSrMergeSortEngine=============================================} -constructor TffSrMergeSortEngine.Create(anEngine : TffServerEngine; - aDB : TffSrDatabase; - aFieldsArray : TffFieldList; - const aOrderByArray : TffOrderByArray; - const aNumFields : integer; - aDict : TffDataDictionary; - const aIndexID : integer); -begin - inherited Create(anEngine, aDB, aFieldsArray, aOrderByArray, aNumFields, - aDict, aIndexID); - FFGetMem(msBuffer, ffcl_MergeSortBufferSize); - FfGetMem(msPivotBuffer, bsRecLen); - FFGetMem(msRecBuffer, bsRecLen); - msBufferOffset := 0; - msCursorList := TffSrCursorList.Create; - msMaxRecCount := ffcl_MergeSortBufferSize div bsRecLen; - msOutputStoreSize := ffcl_MergeSortBufferSize * ffcl_MergeOrder; - { Default value. Not really used. } - msRecCount := 0; - msState := ffspEmpty; - msTotalCount := 0; -end; -{--------} -destructor TffSrMergeSortEngine.Destroy; -var - aCursor : TffSrBaseCursor; - Index : Longint; -begin - if assigned(msBuffer) then - FFFreeMem(msBuffer, ffcl_MergeSortBufferSize); - if assigned(msPivotBuffer) then - FFFreeMem(msPivotBuffer, bsRecLen); - if assigned(msRecBuffer) then - FFFreeMem(msRecBuffer, bsRecLen); - if assigned(msCursorList) then begin - for Index := pred(msCursorList.CursorCount) downto 0 do begin - aCursor := msCursorList.Cursor[ftFromIndex, Index]; - msCursorList.DeleteCursor(aCursor.CursorID); - end; - msCursorList.Free; - end; - inherited; -end; -{--------} -function TffSrMergeSortEngine.Get(aRecord : PffByteArray) : boolean; -var - aStatus : TffResult; -begin - Result := false; - - { Is this the first get? } - if msState <> ffspGetting then begin - { Yes. } - msState := ffspGetting; - { Any records in the run buffer? } - if msRecCount > 0 then begin - { Yes. Sort the run buffer. Write to temp cursor only if we have - written other temporary cursors. This is a performance optimization. - If there aren't enough records to fill a run buffer then we will - just quick sort them and retrieve them from the run buffer. } - aStatus := msFinalizeBuffer(msCursorList.CursorCount > 0); - if aStatus <> DBIERR_NONE then - FFRaiseException(EffException, ffStrResServer, aStatus, - ['TffSrMergeSortEngine.Get']); - - { Do we have some temporary cursors? } - if msCursorList.CursorCount > 0 then - { Yes. Merge them until they are whittled down to ffcl_MergeOrder files - in number. } - msMerge - else - { No. But we do have records in the run buffer. Init an index into the - run buffer. } - msRunIndex := 0; - end - { Any records at all? } - else if msTotalCount = 0 then - { No. Nothing to sort. } - Exit; - end; - - { Get next record from merge files? } - if msMergeCursorCount > 0 then begin - { Yes. } - msGetNextRecord(aRecord); - Result := True; - end - else if msRunIndex < msRecCount then begin - { No. Not enough records for a merge file. Retrieve the next record from - the run buffer. } - Move(msBuffer^[msRunIndex * bsRecLen], aRecord^, bsRecLen); - inc(msRunIndex); - Result := True; - end; - -end; -{--------} -function TffSrMergeSortEngine.msCompRecs(PRec1, PRec2 : PffByteArray) : integer; -var - Fld1Null, Fld2Null : boolean; - Index : integer; - Offset : Longint; - SortInfo : TffSrSortFieldInfo; -begin - Result := 0; - Index := 0; - - { Compare each field until we see a non-zero result. } - while (Result = 0) and (Index < bsNumFields) do begin - SortInfo := bsSortInfo^[Index]; - - { Is either field a null? } - Fld1Null := bsDict.IsRecordFieldNull(SortInfo.fldDescriptor.fdNumber, PRec1); - Fld2Null := bsDict.IsRecordFieldNull(SortInfo.fldDescriptor.fdNumber, PRec2); - if Fld1Null then begin - if Fld2Null then - Result := 0 - else - Result := -1; - end - else if Fld2Null then - Result := 1 - else begin - Offset := bsSortInfo^[Index].fldDescriptor.fdOffset; - Result := bsSortInfo^[Index].fldInxHelper.CompareKey - (PRec1^[Offset], PRec2^[Offset], - @bsSortInfo^[Index].fldDescriptor, - bsSortInfo^[Index].fldLength, bsSortInfo^[Index].fldNoCase); - end; - - { The compare function always compares in ascending fashion. If this is - to be ordered in descending fashion and our result is non-zero, flip - some bits. } - if bsSortInfo^[Index].fldOrderDir = ffobDescending then - Result := -Result; - inc(Index); - end; -end; -{--------} -function TffSrMergeSortEngine.msFinalizeBuffer(const WriteToCursor : boolean) : TffResult; -var - Cursor : TffSrSimpleCursor; - Index : Longint; -begin - Result := DBIERR_NONE; - - { Sort the buffer. } - msSortBuffer; - - if WriteToCursor then begin - { Write the records to a temporary file. } - Cursor := TffSrSimpleCursor.Create(bsEngine, bsDB, FFGetRemainingTime); - Cursor.Build('', bsDict, omReadWrite, smExclusive, false, true, - [fffaTemporary, fffaBLOBChainSafe], ffcl_MergeSortBufferSize); {!!.05} - Cursor.CloseTable := True; - for Index := 0 to pred(msRecCount) do begin - Result := Cursor.InsertRecord(@msBuffer^[Index * bsRecLen], ffsltNone); - if Result <> DBIERR_NONE then - Exit; - end; - - { Add this cursor to our list of temporary files. } - msCursorList.AddCursor(Cursor); - - { Zero out the buffer. } - FillChar(msBuffer^, ffcl_MergeSortBufferSize, 0); - - msRecCount := 0; - end; - -end; -{--------} -procedure TffSrMergeSortEngine.msGetNextRecord(aRecord : PffByteArray); -var - aResult : TffResult; - Index, Index2 : integer; -begin - { Assumption: Each cursor in the merge is positioned on a record. If a cursor - reaches EOF then it is closed before we access it again. } - - { Get record for first cursor. } - aResult := msMergeCursor[0].GetRecord(aRecord, ffsltNone); - Index := 0; - - { Did an error occur? } - if (aResult <> DBIERR_NONE) then - { Yes. Raise an exception. } - FFRaiseException(EffException, ffStrResServer, aResult, - ['msGetNextRecord.1']); - - { Compare the records from the other cursors. } - for Index2 := 1 to pred(msMergeCursorCount) do begin - aResult := msMergeCursor[Index2].GetRecord(msRecBuffer, ffsltNone); - { Did an error occur? } - if (aResult <> DBIERR_NONE) then - { Yes. Raise an exception. } - FFRaiseException(EffException, ffStrResServer, aResult, - ['msGetNextRecord.2']); - - { Should this record be before the current record? } - if msCompRecs(msRecBuffer, aRecord) < 0 then begin - { Yes. Copy the record. } - Move(msRecBuffer^, aRecord^, bsRecLen); - Index := Index2; - end; - end; - - { By this point, we have found the next record. Move the cursor from which - the record was obtained to its next record. Note that this action may - result in the closing of the cursor. } - msNextRecord(Index); - -end; -{--------} -procedure TffSrMergeSortEngine.msMerge; -begin - { While we have more cursors to merge than the merge order, do some work. } - while msCursorList.CursorCount > ffcl_MergeOrder do begin - { Get some cursors to merge. } - msSetMergeCursors; - { Create an output cursor & add it to the cursor list. The records from - the merged cursors will go to the output cursor. } - msOutputCursor := TffSrSimpleCursor.Create(bsEngine, bsDB, - FFGetRemainingTime); - msOutputCursor.Build('', bsDict, omReadWrite, smExclusive, - false, true, [fffaTemporary, fffaBLOBChainSafe], {!!.05} - msOutputStoreSize); {!!.05} - msOutputCursor.CloseTable := True; - msCursorList.AddCursor(msOutputCursor); - { Merge the input cursors into the output cursor. } - msMergeCursors; - end; - msSetMergeCursors; -end; -{--------} -procedure TffSrMergeSortEngine.msMergeCursors; -var - aRecord : PffByteArray; - aStatus : TffResult; - aStr : string; -begin - FFGetMem(aRecord, bsRecLen); - try - try - while True do begin - { Find next record for output cursor. Did we find a record? } - msGetNextRecord(aRecord); - { Send to output cursor. } - aStatus := msOutputCursor.InsertRecord(aRecord, ffsltNone); - if aStatus <> DBIERR_NONE then - FFRaiseException(EffException, ffStrResServer, aStatus, - ['msMergeCursors']); - { All records merged? } - if msMergeCursorCount = 0 then - break; - end; - except - on E:Exception do begin - aStr := E.message; - end; - end; - finally - FFFreeMem(aRecord, bsRecLen); - end; -end; -{--------} -procedure TffSrMergeSortEngine.msNextRecord(const aCursorIndex : integer); -var - aResult : TffResult; -begin - aResult := msMergeCursor[aCursorIndex].GetNextRecord(msRecBuffer, ffsltNone); - if aResult = DBIERR_EOF then begin - { Close the cursor. } - msCursorList.DeleteCursor(msMergeCursor[aCursorIndex].CursorID); - - { Move the last cursor to this position. } - msMergeCursor[aCursorIndex] := msMergeCursor[pred(msMergeCursorCount)]; - dec(msMergeCursorCount); - end; -end; -{--------} -procedure TffSrMergeSortEngine.msSetMergeCursors; -var - aCount : Longint; - aCursor : TffSrSimpleCursor; - RecsPerBlock : Longint; -begin - msMergeCursorCount := 0; - msOutputStoreSize := 0; - - RecsPerBlock := (64 * 1024) div bsRecLen; - - { Obtain a merge cursor while we have not exceeded the merge order and - while we have not exceeded the number of temporary cursors. } - while (msMergeCursorCount < ffcl_MergeOrder) and - (msMergeCursorCount < msCursorList.CursorCount) do begin - inc(msMergeCursorCount); - aCursor := TffSrSimpleCursor(msCursorList.Cursor[ftFromIndex, - pred(msMergeCursorCount)]); - { Position to first record in each cursor. } - aCursor.SetToBegin; - aCursor.GetNextRecord(msRecBuffer, ffsltNone); - msMergeCursor[pred(msMergeCursorCount)] := aCursor; - msCursorOnRec[pred(msMergeCursorCount)] := false; - aCursor.GetRecordCount(aCount); - { Increment temp store size by # blocks needed to hold the data plus 2 - blocks for header and data dictionary. } - inc(msOutputStoreSize, (((aCount div RecsPerBlock) + 1) * 64 * 1024) + - (2 * 64 * 1024)); - end; -end; -{--------} -procedure TffSrMergeSortEngine.msSortBuffer; -const - MedianThreshold = 16; - StackSize = 32; -type - Stack = array[0..StackSize - 1] of Longint; -var - L : Longint; { The left edge, base zero. } - R : Longint; { The right edge, base zero. } - Pl : Longint; { Left edge within current partition, base zero. } - Pr : Longint; { Right edge within current partition, base zero. } - Pm : Longint; { Mid-point of current partition. } - PLen : Longint; { The size of the current partition. } - StackP : integer; { Stack pointer. } - LStack : Stack; { Pending partitions, left edge. } - RStack : Stack; { Pending partitions, right edge. } -begin - { Initialize the stack. } - StackP := 0; - LStack[0] := 0; - RStack[0] := msRecCount - 1; - - { Repeatedly take top partition from the stack. } - repeat - { Pop the stack. } - L := LStack[StackP]; - R := RStack[StackP]; - Dec(StackP); - - { Sort the current partition. } - repeat - Pl := L; - Pr := R; - PLen := Pr - Pl + 1; - - { Calculate the pivot element. } - Pm := Pl + (PLen shr 1); - if PLen >= MedianThreshold then begin - { Sort elements P1, Pm, & Pr. } - if msCompRecs(@msBuffer^[Pm * bsRecLen], @msBuffer^[Pl * bsRecLen]) < 0 then - msSwapRecs(Pm, Pl); - if msCompRecs(@msBuffer^[Pr * bsRecLen], @msBuffer^[Pl * bsRecLen]) < 0 then - msSwapRecs(Pr, Pl); - if msCompRecs(@msBuffer^[Pr * bsRecLen], @msBuffer^[Pm * bsRecLen]) < 0 then - msSwapRecs(Pr, Pm); - { Exchange Pm with Pr - 1 but use Pm's value as the pivot. } - msSwapRecs(Pm, Pr - 1); - Pm := Pr - 1; - - { Reduce range of swapping now that Pl and Pr are in the right - spots. } - inc(Pl); - dec(Pr, 2); - end; - - { Save the pivot element. } - Move(msBuffer^[Pm * bsRecLen], msPivotBuffer^, bsRecLen); - - { Swap items in sort order around the pivot. } - repeat - while msCompRecs(@msBuffer^[Pl * bsRecLen], msPivotBuffer) < 0 do - inc(Pl); - while msCompRecs(msPivotBuffer, @msBuffer^[Pr * bsRecLen]) < 0 do - dec(Pr); - - { Have we reached the pivot? } - if Pl = Pr then begin - Inc(Pl); - Dec(Pr); - end - else if Pl < Pr then begin - { No. Swap elements around the pivot. } - msSwapRecs(Pl, Pr); - inc(Pl); - dec(Pr); - end; - until Pl > Pr; - - { Decide which partition to sort next. Which partition is bigger? } - if (Pr - L) < (R - Pl) then begin - { Left partition is bigger. } - if Pl < R then begin - { Stack the request for sorting right partition. } - inc(StackP); - LStack[StackP] := Pl; - RStack[StackP] := R; - end; - { Continue sorting left partion. } - R := Pr; - end - else begin - { Right partition is bigger. } - if L < Pr then begin - { Stack the request for sorting left partition. } - inc(StackP); - LStack[StackP] := L; - RStack[StackP] := Pr; - end; - { Continue sorting right partition. } - L := Pl; - end; - until L >= R; - until StackP < 0; -end; -{--------} -procedure TffSrMergeSortEngine.msSwapRecs(Rec1, Rec2 : Longint); -begin - Move(msBuffer^[Rec1 * bsRecLen], msRecBuffer^, bsRecLen); - Move(msBuffer^[Rec2 * bsRecLen], msBuffer^[Rec1 * bsRecLen], bsRecLen); - Move(msRecBuffer^, msBuffer^[Rec2 * bsRecLen], bsRecLen); -end; -{--------} -function TffSrMergeSortEngine.Put(aRecord : PffByteArray) : TffResult; -begin - Result := DBIERR_NONE; - - { Did we start retrieving? } - Assert(not (msState = ffspGetting)); - - msState := ffspPutting; - - { Is the buffer full? } - if msRecCount = msMaxRecCount then begin - Result := msFinalizeBuffer(True); - msBufferOffset := 0; - end; - - if Result = DBIERR_NONE then begin - { Add the record to the buffer. } - Move(aRecord^, msBuffer^[msBufferOffset], bsRecLen); - inc(msBufferOffset, bsRecLen); - inc(msRecCount); - inc(msTotalCount); - end; - -end; -{====================================================================} -end. diff --git a/components/flashfiler/sourcelaz/ffsrstat.pas b/components/flashfiler/sourcelaz/ffsrstat.pas deleted file mode 100644 index 566dd8c1f..000000000 --- a/components/flashfiler/sourcelaz/ffsrstat.pas +++ /dev/null @@ -1,232 +0,0 @@ -{*********************************************************} -{* FlashFiler: Server Rebuild status *} -{*********************************************************} - -(* ***** 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 ffsrstat; - -interface - -uses - Windows, - SysUtils, - Classes, - ffconst, - ffllbase, - ffsrbase; - -type - TffSrRebuildStatus = class(TffSelfListItem) - protected {private} - rsPadlock : TffPadlock; - rsStatus : TffRebuildStatus; - rsClientID: longint; - protected - public - constructor Create(aClientID : longint; aTotalRecords : longint); - destructor Destroy; override; - - procedure GetLastSnapshot(var aRebuildStatus : TffRebuildStatus); - procedure MakeSnapshot(aRecsRead : longint; aRecsWritten : longint; aErrorCode : TffResult); - procedure MarkFinished; - property ClientID : longint read rsClientID; - property RebuildID : longint read KeyAsInt; - end; - - TffSrRebuildStatusList = class(TffObject) - protected {private} - FList : TffList; - rslPadlock : TffPadlock; - public - constructor Create; - destructor Destroy; override; - - function AddRebuildStatus(aClientID : longint; aTotalRecs : longint) : TffSrRebuildStatus; - procedure DeleteAllForClient(aClientID : longint); - function GetRebuildStatus(aRebuildID : longint; - var aStatus : TffRebuildStatus) : boolean; - procedure MarkRebuildStatusFinished(aRebuildID : longint); - end; - -implementation - -{===TffSrRebuildStatus===============================================} -constructor TffSrRebuildStatus.Create(aClientID : longint; aTotalRecords : longint); -begin - inherited Create; - rsPadlock := TffPadlock.Create; - rsStatus.rsTotalRecs := aTotalRecords; - rsStatus.rsStartTime := GetTickCount; - rsClientID := aClientID; -end; -{--------} -destructor TffSrRebuildStatus.Destroy; -begin - rsPadlock.Free; - inherited Destroy; -end; -{--------} -procedure TffSrRebuildStatus.GetLastSnapshot(var aRebuildStatus : TffRebuildStatus); -begin - rsPadlock.Lock; - try - aRebuildStatus := rsStatus; - finally - rsPadlock.Unlock; - end;{try..finally} -end; -{--------} -procedure TffSrRebuildStatus.MakeSnapshot(aRecsRead : longint; - aRecsWritten : longint; - aErrorCode : TffResult); -var - Dividend: LongInt; - Divisor: LongInt; -begin - rsPadlock.Lock; - try - with rsStatus do begin - rsRecsRead := aRecsRead; - rsRecsWritten := aRecsWritten; - rsErrorCode := aErrorCode; - rsSnapshotTime := GetTickCount; - if (rsRecsRead >= $1000000) then begin - Dividend := (rsRecsRead shr 7) * 100; - Divisor := rsTotalRecs shr 7; - end - else begin - Dividend := rsRecsRead * 100; - Divisor := rsTotalRecs; - end; - if Divisor <> 0 then - rsPercentDone := Dividend div Divisor; - end; - finally - rsPadlock.Unlock; - end;{try..finally} -end; -{--------} -procedure TffSrRebuildStatus.MarkFinished; -begin - rsStatus.rsFinished := true; -end; -{====================================================================} - - -{===TffSrRebuildStatusList===========================================} -constructor TffSrRebuildStatusList.Create; -begin - inherited Create; - FList := TffList.Create; - rslPadlock := TffPadlock.Create; -end; -{--------} -destructor TffSrRebuildStatusList.Destroy; -begin - rslPadlock.Free; - FList.Free; - inherited Destroy; -end; -{--------} -function TffSrRebuildStatusList.AddRebuildStatus(aClientID : longint; - aTotalRecs : longint) : TffSrRebuildStatus; -begin - rslPadlock.Lock; - try - Result := TffSrRebuildStatus.Create(aClientID, aTotalRecs); - try - FList.Insert(Result); - except - Result.Free; - raise; - end;{try..except} - finally - rslPadlock.Unlock; - end;{try..finally} -end; -{--------} -procedure TffSrRebuildStatusList.DeleteAllForClient(aClientID : longint); -var - Inx : integer; - TempStat : TffSrRebuildStatus; -begin - rslPadlock.Lock; - try - for Inx := pred(FList.Count) downto 0 do begin - TempStat := TffSrRebuildStatus(FList[Inx]); - if (TempStat.ClientID = aClientID) then - FList.DeleteAt(Inx); - end; - finally - rslPadlock.Unlock; - end;{try..finally} -end; -{--------} -function TffSrRebuildStatusList.GetRebuildStatus(aRebuildID : longint; - var aStatus : TffRebuildStatus) : boolean; -var - Inx : integer; - TempStat : TffSrRebuildStatus; -begin - rslPadlock.Lock; - try - Inx := FLIst.Index(aRebuildID); - if (Inx = -1) then - Result := false - else begin - Result := true; - TempStat := TffSrRebuildStatus(FList[Inx]); - TempStat.GetLastSnapshot(aStatus); - if (aStatus.rsFinished = true) then - FList.DeleteAt(Inx); - end; - finally - rslPadlock.Unlock; - end;{try..finally} -end; -{--------} -procedure TffSrRebuildStatusList.MarkRebuildStatusFinished(aRebuildID : longint); -var - Inx : integer; - TempStat : TffSrRebuildStatus; -begin - rslPadlock.Lock; - try - Inx := FLIst.Index(aRebuildID); - if (Inx <> -1) then begin - TempStat := TffSrRebuildStatus(FList[Inx]); - TempStat.MarkFinished; - end; - finally - rslPadlock.Unlock; - end;{try..finally} -end; -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/ffsrtran.pas b/components/flashfiler/sourcelaz/ffsrtran.pas deleted file mode 100644 index 612206a6e..000000000 --- a/components/flashfiler/sourcelaz/ffsrtran.pas +++ /dev/null @@ -1,761 +0,0 @@ -{*********************************************************} -{* FlashFiler: Transaction manager 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} - -{.$DEFINE TranLogging} - -unit FFSRTran; - -interface - -uses - {$IFDEF TranLogging} - fflllog, - {$ENDIF} - Windows, - Messages, - SysUtils, - ffllbase, - fflleng, - ffsrlock, - ffsrbase; - -type - - { TffSrTransactionMgr tracks active transactions. Each instance of - TffSrFolder has its own instance of TffSrTransactionMgr as the scope - of a transaction is limited to the tables within one database. - - Any number of transactions may be active per TffSrFolder. However, only - one transaction may be active per logical client database. This limitation - is in place to provide for backwards compatibility: - - 1. Existing applications call TffDatabase.StartTransaction. - 2. Existing applications can make mods to several cursors within the - context of one transaction. - - If a client app needs multiple transactions per physical database then - it should open several TffDatabase objects on the same alias. The client - may then have 1 transaction per TffDatabase. - - When freed, the transaction manager stores its NextLSN in a binary config - file located in the folder. When a transaction manager is next created - for that folder, it will open the config file in Exclusive mode so that - no other FF server may access the same folder. - - The format of the config file is as follows: - - Bytes Contents - ----- -------------------------------------------------- - 1 - 4 NextLSN for tables in this directory. - 5 - 12 TDateTime of the last LSN rollover. - } - TffSrTransactionMgr = class(TffObject) - protected {private} - {$IFDEF TranLogging} - FEventLog : TffEventLog; - {$ENDIF} - - FBufMgr : TffBufferManager; - {-The buffer manager handling file access. } - FByDatabase : TffThreadList; - {-Transactions indexed by DatabaseID. Contains instances of - TffIntListItem. The ExtraData property of each TffIntListItem - contains a reference to the transaction. } - FCommitLSN : TffWord32; - {-The starting LSN of the oldest uncommitted transaction. } - FConfigFile : PffFileInfo; - {-The binary file containing the transaction manager's persistent - information. } - FLockMgr : TffLockManager; - {-The lock manager coordinating locks for this database. } - FLSNRolltime : TDateTime; - {Time of last LSN rollover.} - FNextLSN : TffWord32; - {-The next LSN to be assigned to a transaction. } - FPath : string; - {-The directory for which this object manages transactions. } - FPortal : TffReadWritePortal; - {-Used to control access to CommitLSN. } - FReadOnly : boolean; - {-Used to control whether or not the last LSN is to be preserved - on disk. } - FTranList : TffThreadList; - {-Holds the list of active transactions sorted by - transaction ID. } - protected - - function tmGetCommitLSN : TffWord32; - {-Used to retrieve the CommitLSN. } - - function tmGetCount : Longint; - {-Returns the number of active transactions. } - - function tmGetLSNForTable(const FullTableName : TffFullFileName) {!!.06} - : TffWord32; {!!.06} - - function tmGetLSNFromTables : TffWord32; - {-Retrieves the NextLSN based on the number stored in the - header of the tables in the database.} - - function tmGetTransItem(Find : TffListFindType; Value : Longint) : TffSrTransaction; - {-Find an active transaction by ID or index. } - - procedure tmHandleLSNRollover; - {-Used to handle a NextLSN rollover. } - - procedure tmReadConfig; - {-Used to retrieve the transaction manager's last LSN from the config - file. } - - procedure tmRecalcCommitLSN; - {-Used to recalculate the CommitLSN after a commit or rollback. } - - function tmValidConfigFile : Boolean; - {-Returns True if config file exists and its file time is - greater than all the tables in the database.} - - procedure tmWriteConfig(const CloseFile : Boolean); {!!.13} - {-Used to store the transaction manager's last LSN in a config file. } - - public - constructor Create(aBufferMgr : TffBufferManager; - aLockMgr : TffLockManager; - const aPath : string; - const aReadOnly : boolean); - destructor Destroy; override; - - function Commit(const aTransID : TffTransID; - var wasNested : boolean) : TffResult; - { Commit a transaction. Returns DBIERR_NONE if the commit was - successful. Output parameter wasNested is set to True if a nested - transaction was committed. Otherwise it is set to False indicating - a transaction was fully committed. } - - procedure Rollback(const aTransID : TffTransID; var wasNested : boolean); - { Rollback a transaction. } - - function StartTransaction(const aDatabaseID : TffDatabaseID; - const aFailSafe, aImplicit, - readOnly : boolean; - const path : TffPath; - var aTran : TffSrTransaction) : TffResult; - { Starts a new transaction. } - - property CommitLSN : TffWord32 read tmGetCommitLSN; - { Returns the starting LSN of the oldest uncommitted transaction. - For now, this is really longInt(Self) of the oldest uncommitted - transaction. } - - property Count : longInt read tmGetCount; - { Returns the number of active transactions. } - - property IsReadOnly : boolean read FReadOnly; - { If False then the transaction manager stores its last LSN in a - config file when the transaction manager is freed (i.e., when the - FF server is shutdown). } - - property NextLSN : TffWord32 read FNextLSN; - { The next LSN to be assigned to a transaction. } - - property Path : string read FPath; - { The directory for which this object manages transactions. } - - end; - -implementation - -uses - Classes, - ffsrbde, - ffllexcp; - -const - { Config file } - ffc_ConfigFile = 'FFSTRAN.CFG'; - ffc_ConfigExt : string[ffcl_Extension] = 'CFG'; - -{$I FFCONST.INC} - - -{===TffSrTransactionMgr===============================================} -constructor TffSrTransactionMgr.Create(aBufferMgr : TffBufferManager; - aLockMgr : TffLockManager; - const aPath : string; - const aReadOnly : boolean); -begin - inherited Create; - FBufMgr := aBufferMgr; - FByDatabase := TffThreadList.Create; - FCommitLSN := High(TffWord32); - FLockMgr := aLockMgr; - FLSNRollTime := 0; - FNextLSN := 1; - FPath := aPath; - FPortal := TffReadWritePortal.Create; - FReadOnly := aReadOnly; - FTranList := TffThreadList.Create; - - {$IFDEF TranLogging} - FEventLog := TffEventLog.Create(nil); - FEventLog.FileName := '.\FFTran.LOG'; - FEventLog.Enabled := True; - FEventLog.WriteString(format('Transaction Mgr started for %s', - [aPath])); - {$ENDIF} - - if not FReadOnly then - tmReadConfig; -end; -{--------} -destructor TffSrTransactionMgr.Destroy; -begin -{$IFDEF TranLogging} - FEventLog.WriteString('Destroying transaction mgr'); -{$ENDIF} - if not FReadOnly then - tmWriteConfig(true); {!!.13} - FByDatabase.Free; - FPortal.Free; - FTranList.Free; - {$IFDEF TranLogging} - FEventLog.WriteStrings(['', - format('Transaction Mgr stopped for %s', - [FPath])]); - FEventLog.Free; - {$ENDIF} - - inherited Destroy; -end; -{--------} -function TffSrTransactionMgr.Commit(const aTransID : TffTransID; - var wasNested : boolean) : TffResult; -var - aTran : TffSrTransaction; -begin - Result := DBIERR_NONE; - aTran := tmGetTransItem(ftFromID, aTransID); - if assigned(aTran) then begin - - { Tell the buffer manager to commit the changes. } - FBufMgr.CommitTransaction(aTran); - - { Have all changes been committed to disk? } - if aTran.TransLevel.Level = 0 then begin {!!.10} - - FLockMgr.ReleaseTransactionLocks(aTran, False); - - { Yes. Remove the index entry for the transaction. } -{$IFDEF TranLogging} - FEventLog.WriteString('Commit: Delete transaction from FByDatabase.'); -{$ENDIF} - with FByDatabase.BeginWrite do - try - Delete(aTran.DatabaseID); - finally - EndWrite; - end; - - { Remove the transaction from the list. } - with FTranList.BeginWrite do - try - Delete(aTran); - tmRecalcCommitLSN; - finally - EndWrite; - end; - - wasNested := False; - end - else begin - { No. We just committed a nested transaction. Decrement the nesting - level. } - aTran.EndNested; {!!.10} - wasNested := True; - end; - end else begin - Result := DBIERR_INVALIDHNDL; - end; -end; -{--------} -procedure TffSrTransactionMgr.Rollback(const aTransID : TffTransID; - var wasNested : boolean); -var - aTran : TffSrTransaction; -begin - aTran := tmGetTransItem(ftFromID, aTransID); - if assigned(aTran) then begin - - { Tell the buffer manager to rollback the changes. } - FBufMgr.RollbackTransaction(aTran); - - { Did we rollback a nested transaction? } - if aTran.TransLevel.Level = 0 then begin {!!.10} - { No. Release the locks held by the transaction. } - FLockMgr.ReleaseTransactionLocks(aTran, False); - - { Remove the index entry for the transaction. } -{$IFDEF TranLogging} - FEventLog.WriteString('Rollback: Delete transaction from FByDatabase.'); -{$ENDIF} - with FByDatabase.BeginWrite do - try - Delete(aTran.DatabaseID); - finally - EndWrite; - end; - - { Remove the transaction from the list. } - with FTranList.BeginWrite do - try - Delete(aTran); - tmRecalcCommitLSN; - finally - EndWrite; - end; - - wasNested := false; - - end - else begin - { Yes. Decrement the nesting level. } - aTran.EndNested; {!!.10} - wasNested := true; - end; - end; -end; -{--------} -function TffSrTransactionMgr.StartTransaction(const aDatabaseID : TffDatabaseID; - const aFailSafe, aImplicit, - readOnly : boolean; - const path : TffPath; - var aTran : TffSrTransaction) : TffResult; -var - anIndex : Longint; - anItem : TffIntListItem; - JnlFileName : TffFullFileName; - TranName : TffShStr; -begin - { Assumption: A client may have multiple databases but one instance of a - TffSrDatabase is unique to a client. } - - Result := DBIERR_NONE; - - { Has a transaction already been started by this particular database? } -{$IFDEF TranLogging} - FEventLog.WriteString('StartTran: Obtain read access to FByDatabase.'); -{$ENDIF} - with FByDatabase.BeginRead do - try - anIndex := Index(aDatabaseID); -{Begin move !!.06} - { Does a transaction already exist on the database? } - if anIndex > -1 then begin - { Yes. Get the transaction. } - aTran := TffSrTransaction(TffIntListItem(FByDatabase.Items[anIndex]).ExtraData); - - { Increase its nesting level. } - aTran.StartNested; {!!.10} - end; -{End move !!.06} - finally - EndRead; -{$IFDEF TranLogging} - FEventLog.WriteString('StartTran: End read access to FByDatabase.'); -{$ENDIF} - end; - -{!!.06 - Code moved to previous try..finally block. } - if anIndex = -1 then begin - { No. Create a new transaction. } - aTran := TffSrTransaction.Create(aDatabaseID, aImplicit, readOnly); - - try - { Add the transaction to the active transaction list. } - with FTranList.BeginWrite do - try - Insert(aTran); - aTran.LSN := FNextLSN; - if FNextLSN = high(TffWord32) then - tmHandleLSNRollover - else - inc(FNextLSN); - finally - EndWrite; - end; - - { Add an index entry on the transaction's cursorID. } - anItem := TffIntListItem.Create(aDatabaseID); - anItem.ExtraData := pointer(aTran); -{$IFDEF TranLogging} - FEventLog.WriteString('StartTran: Insert transaction into FByDatabase.'); -{$ENDIF} - with FByDatabase.BeginWrite do - try - Insert(anItem); - finally - EndWrite; -{$IFDEF TranLogging} - FEventLog.WriteString('StartTran: Finished insert transaction ' + - 'into FByDatabase.'); -{$ENDIF} - end; - - { Determine the name of the journal file. } - if aFailSafe then begin - JnlFileName := path; - FFShStrAddChar( JnlFileName, '\' ); - Str(aTran.TransactionID, TranName); - FFShStrConcat(JnlFileName, TranName ); - FFShStrAddChar(JnlFileName, '.'); - FFShStrConcat(JnlFileName, ffc_ExtForTrans); - end else - JnlFileName := ''; - - { Recalculate the CommitLSN. } - if not readOnly then begin - FPortal.BeginWrite; - try - { Update the commitLSN. } - FCommitLSN := FFMinDW(FCommitLSN, aTran.LSN); - { Update the buffer manager's commitLSN. } -// FBufMgr.CommitLSN := FCommitLSN; {Deleted !!.10} - finally - FPortal.EndWrite; - end; - end; - - { Tell the buffer manager to start tracking changes for this transaction. } - FBufMgr.StartTransaction(aTran, aFailSafe, JnlFileName); - - except - if assigned(aTran) then - aTran.Free; - raise; - end; - end; -end; -{--------} -function TffSrTransactionMgr.tmGetCommitLSN : TffWord32; -begin - FPortal.BeginRead; - try - Result := FCommitLSN; - finally - FPortal.EndRead; - end; -end; -{--------} -function TffSrTransactionMgr.tmGetCount : longInt; -begin - with FTranList.BeginRead do - try - Result := FTranList.Count; - finally - EndRead; - end; -end; -{--------} -function TffSrTransactionMgr.tmGetLSNForTable(const FullTableName : TffFullFileName) {!!.06 - Added} - : TffWord32; -{!!.07 - Rewritten} -var - FileHandle : Integer; -begin - FileHandle := FileOpen(FullTableName, fmOpenRead); - try - { The LSN is stored in position 12 of block 0. } - if ((FileSeek(FileHandle, 12, 0) <> 12) or - (FileRead(FileHandle, Result, SizeOf(TffWord32)) <> SizeOf(TffWord32))) then - Result := 0; - finally - FileClose(FileHandle); - end; -end; {!!.06 - End added} -{--------} -function TffSrTransactionMgr.tmGetLSNFromTables : TffWord32; -var - SearchRec : TSearchRec; - {CurrFile : TFileStream;} {!!.06 - Deleted} - TempLSN : TffWord32; - Continue : Boolean; -begin - Result := 0; - if FindFirst(FPath + '\*.' + ffc_ExtForData, faAnyFile, SearchRec) = 0 then begin - Continue := True; - while Continue do begin - try - TempLSN := tmGetLSNForTable(FFMakeFullFileName(FPath, SearchRec.Name)); {!!.06 - Moved functionality this method} - if (TempLSN > Result) then - Result := TempLSN; - Continue := FindNext(SearchRec) = 0; - except - Continue := FindNext(SearchRec) = 0; - end; - end; - FindClose(SearchRec); - end; - {We have no idea when the last LSN rollover was so we just set it - to 0.} - FLSNRollTime := 0; - {Since the tables store the last used LSN we need to increment our - result to get the NextLSN.} - Inc(Result); -end; -{--------} -function TffSrTransactionMgr.tmGetTransItem(Find : TffListFindType; - Value : Longint) : TffSrTransaction; -var - Inx : Integer; -begin - { Assumption: Caller has not read- or write-locked the transaction list. } - Result := nil; - with FTranList.BeginRead do - try - if (Find = ftFromID) then begin - Inx := FTranList.Index(Value); - if (Inx <> -1) then - Result := TffSrTransaction(FTranList[Inx]); - end - else {Find = ftFromIndex} - if (0 <= Value) and (Value < FTranList.Count) then - Result := TffSrTransaction(FTranList[Value]); - finally - EndRead; - end; -end; -{--------} -procedure TffSrTransactionMgr.tmHandleLSNRollover; -var - anIndex : Longint; - LSNAdjustment : TffWord32; - NewLSN : TffWord32; -begin - - { Assumption: Transaction list is already write-locked. } - - { The situation is as follows: - - 1. We have reached the max LSN. - 2. A bunch of RAM pages are marked with LSNs < max(LSN). - - We have to rollover the LSN but we also need to adjust the LSNs on - the RAM pages. - - RAM pages that are not part of a transaction will have their LSNs set - to 1. - - We will set the CommitLSN to 2 and then adjust each transaction's LSN - based upon the difference between its current LSN and CommitLSN. - - The NextLSN will then be set to highest adjusted LSN + 1. - } - - { Write lock the CommitLSN. } - FPortal.BeginWrite; - try - { Calculate the adjustment. } - LSNAdjustment := FCommitLSN - 2; - - { Set the new CommitLSN. } - FCommitLSN := 2; - - { Set the rollover time.} - FLSNRollTime := Now; - - { Init next LSN. } - FNextLSN := 0; - - { Obtain a lock on the buffer manager's internal data structures. This - ensures no other threads mess with the RAM pages. } - FBufMgr.BeginWrite; - try - { Adjust the LSN of each transaction. } - for anIndex := 0 to pred(FTranList.Count) do begin - NewLSN := TffSrTransaction(FTranList.Items[anIndex]).AdjustLSN(LSNAdjustment); - FNextLSN := FFMaxDW(FNextLSN, NewLSN); - end; - inc(FNextLSN); - - { Set the LSN of the other RAM pages. } - FBufMgr.HandleLSNrollover; - finally - FBufMgr.EndWrite; - end; - - finally - FPortal.EndWrite; - end; -end; -{--------} -procedure TffSrTransactionMgr.tmReadConfig; -{ Revised !!.13} -var - PFileName : PAnsiChar; -begin - {$IFDEF TranLogging} - FEventLog.WriteStrings(['', - format('Tran Mgr tmReadConfig: %s', - [FPath])]); - {$ENDIF} - - { Allocate an in-memory structure for the config file & see if the config - file exists. } - FConfigFile := FFAllocFileInfo(FFMakeFullFileName(FPath, ffc_ConfigFile), - ffc_ConfigExt, nil); - FFGetMem(PFileName, Length(FConfigFile^.fiName^) + 1); - try - StrPCopy(PFileName, FConfigFile^.fiName^); - { Good config file? } - if tmValidConfigFile then begin - { Yes. Open the config file in Exclusive mode. } - try - FConfigFile^.fiHandle := FFOpenFilePrim(PFileName, - omReadWrite, - smShareRead, - True, - False); - { Read the NextLSN from the config file. } - FFReadFilePrim(FConfigFile, SizeOf(TffWord32), FNextLSN); - { Read the NextLSN from the config file. } - FFReadFilePrim(FConfigFile, SizeOf(TDateTime), FLSNRollTime); - except - {if reading from the file fails, we'll get the LSN from the tables.} - FNextLSN := tmGetLSNFromTables; - end; - end else begin - {No. Get the LSN info from the tables.} - FNextLSN := tmGetLSNFromTables; - { Write the LSN to the table. } - tmWriteConfig(false); - end; - finally - FFFreeMem(PFileName, StrLen(PFileName) + 1); - end; -end; -{--------} -procedure TffSrTransactionMgr.tmRecalcCommitLSN; -var - Index : Longint; -begin - - { Assumption: Transaction list is write-locked. } - - FPortal.BeginWrite; - try - FCommitLSN := high(TffWord32); - if FTranList.Count > 0 then - for index := 0 to pred(FTranList.Count) do - FCommitLSN := FFMinDW(FCommitLSN, - TffSrTransaction(FTranList.Items[index]).LSN); - { Update the buffer manager's commitLSN. } -// FBufMgr.CommitLSN := FCommitLSN; {Deleted !!.10} - finally - FPortal.EndWrite; - end; -end; -{--------} -function TffSrTransactionMgr.tmValidConfigFile : Boolean; -{Revised !!.13} -var - SearchRec : TSearchRec; - FullFileName : TffFullFileName; - PFullFileName : PAnsiChar; - CfgTime : Integer; - Continue : Boolean; -begin - { The config file is valid if it exists, it has a length greater than zero, - & its file time is greater than any of the tables in the database. } - FullFileName := FFMakeFullFileName(FPath, ffc_ConfigFile); - Result := (FindFirst(FullFileName, faAnyFile, SearchRec) = 0); - if Result then begin - Result := (SearchRec.Size > 0); - if Result then begin - CfgTime := (SearchRec.Time + 1000); - FindClose(SearchRec); - if (FindFirst(FPath + '\*.' + ffc_ExtForData, - faAnyFile, - SearchRec) = 0) then begin - Continue := True; - while Continue do begin - if (SearchRec.Time > CfgTime) then begin - Result := False; - Break; - end; - Continue := FindNext(SearchRec) = 0; - end; - FindClose(SearchRec); - end; { if } - end; { if } - end; { if } - - if not Result then begin - { Create the config file since it doesn't exist or has zero size. } - FFGetMem(PFullFileName, Length(FullFileName) + 1); - try - FConfigFile^.fiHandle := FFOpenFilePrim(StrPCopy(PFullFileName, - FullFileName), - omReadWrite, - smShareRead, - True, - True); - { NOTE: FConfigFile will be closed when the transaction manager - is destroyed. } - finally - FFFreeMem(PFullFileName, StrLen(PFullFileName) + 1); - end; - end; { if } -end; -{--------} -procedure TffSrTransactionMgr.tmWriteConfig(const CloseFile : Boolean); {!!.13} -var - TempPos : TffInt64; -begin - {$IFDEF TranLogging} - FEventLog.WriteStrings(['', - format('Tran Mgr tmWriteConfig: %s', - [FPath])]); - {$ENDIF} - if assigned(FConfigFile) and {Start !!.01} - (FConfigFile^.fiHandle <> INVALID_HANDLE_VALUE) then begin - if (not FReadOnly) then begin - FFInitI64(TempPos); - FFPositionFilePrim(FConfigFile, TempPos); - FFWriteFilePrim(FConfigFile, sizeOf(TffWord32), FNextLSN); - FFWriteFilePrim(FConfigFile, sizeOf(TDateTime), FLSNRollTime); - end; - if CloseFile then {!!.13} - FFCloseFilePrim(FConfigFile); - end; - if CloseFile then {!!.13} - FFFreeFileInfo(FConfigFile); {End !!.01} -end; -{=====================================================================} -end. diff --git a/components/flashfiler/sourcelaz/ffsrvdlg.dfm b/components/flashfiler/sourcelaz/ffsrvdlg.dfm deleted file mode 100644 index 4d8d22ae6..000000000 --- a/components/flashfiler/sourcelaz/ffsrvdlg.dfm +++ /dev/null @@ -1,49 +0,0 @@ -object FFPickServerDlg: TFFPickServerDlg - Left = 226 - Top = 174 - BorderIcons = [] - BorderStyle = bsDialog - Caption = 'FlashFiler Server Selection' - ClientHeight = 73 - ClientWidth = 432 - Color = clBtnFace - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'MS Sans Serif' - Font.Style = [] - FormStyle = fsStayOnTop - Position = poScreenCenter - PixelsPerInch = 96 - TextHeight = 13 - object Bevel1: TBevel - Left = 8 - Top = 8 - Width = 321 - Height = 57 - Shape = bsFrame - end - object Label1: TLabel - Left = 16 - Top = 32 - Width = 41 - Height = 13 - Caption = 'Login to:' - end - object CBNames: TComboBox - Left = 64 - Top = 24 - Width = 249 - Height = 21 - Style = csDropDownList - ItemHeight = 13 - TabOrder = 0 - end - object OKBtn: TBitBtn - Left = 344 - Top = 8 - Width = 75 - Height = 25 - TabOrder = 1 - Kind = bkOK - end -end diff --git a/components/flashfiler/sourcelaz/ffsrvdlg.pas b/components/flashfiler/sourcelaz/ffsrvdlg.pas deleted file mode 100644 index d1177d400..000000000 --- a/components/flashfiler/sourcelaz/ffsrvdlg.pas +++ /dev/null @@ -1,66 +0,0 @@ -{*********************************************************} -{* FlashFiler: Server 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 ffsrvdlg; - -interface - -uses - Windows, - SysUtils, - Classes, - Graphics, - Forms, - Controls, - StdCtrls, - Buttons, - ExtCtrls; - -type - TFFPickServerDlg = class(TForm) - Bevel1: TBevel; - CBNames: TComboBox; - Label1: TLabel; - OKBtn: TBitBtn; - private - { Private declarations } - public - { Public declarations } - end; - -var - FFPickServerDlg: TFFPickServerDlg; - -implementation - -{$R *.DFM} - -end. diff --git a/components/flashfiler/sourcelaz/ffstdate.pas b/components/flashfiler/sourcelaz/ffstdate.pas deleted file mode 100644 index 55743e0b2..000000000 --- a/components/flashfiler/sourcelaz/ffstdate.pas +++ /dev/null @@ -1,963 +0,0 @@ -{*********************************************************} -{* FlashFiler: Date and time calculations *} -{*********************************************************} - -(* ***** 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 ffstdate; - {-Date and time manipulation - from SysTools} - -interface - -uses - Windows, - SysUtils; - -type - TStDate = LongInt; - {In STDATE, dates are stored in long integer format as the number of days - since January 1, 1600} - - TDateArray = array[0..(MaxLongInt div SizeOf(TStDate))-1] of TStDate; - {Type for StDate open array} - - TStDayType = (Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday); - {An enumerated type used when representing a day of the week} - - TStBondDateType = (bdtActual, bdt30E360, bdt30360, bdt30360psa); - {An enumerated type used for calculating bond date differences} - - TStTime = LongInt; - {STDATE handles time in a manner similar to dates, representing a given - time of day as the number of seconds since midnight} - - TStDateTimeRec = - record - {This record type simply combines the two basic date types defined by - STDATE, Date and Time} - D : TStDate; - T : TStTime; - end; - -const - MinYear = 1600; {Minimum valid year for a date variable} - MaxYear = 3999; {Maximum valid year for a date variable} - Mindate = $00000000; {Minimum valid date for a date variable - 01/01/1600} - Maxdate = $000D6025; {Maximum valid date for a date variable - 12/31/3999} - Date1900 = $0001AC05; {This constant contains the Julian date for 01/01/1900} - Date1980 = $00021E28; {This constant contains the Julian date for 01/01/1980} - Date2000 = $00023AB1; {This constant contains the Julian date for 01/01/2000} - {This value is used to represent an invalid date, such as 12/32/1992} - BadDate = LongInt($FFFFFFFF); - - DeltaJD = $00232DA8; {Days between 1/1/-4173 and 1/1/1600} - - MinTime = 0; {Minimum valid time for a time variable - 00:00:00 am} - MaxTime = 86399; {Maximum valid time for a time variable - 23:59:59 pm} - {This value is used to represent an invalid time of day, such as 12:61:00} - BadTime = LongInt($FFFFFFFF); - - SecondsInDay = 86400; {Number of seconds in a day} - SecondsInHour = 3600; {Number of seconds in an hour} - SecondsInMinute = 60; {Number of seconds in a minute} - HoursInDay = 24; {Number of hours in a day} - MinutesInHour = 60; {Number of minutes in an hour} - MinutesInDay = 1440; {Number of minutes in a day} - -var - DefaultYear : Integer; {default year--used by DateStringToDMY} - DefaultMonth : ShortInt; {default month} - - {-------julian date routines---------------} - -function CurrentDate : TStDate; - {-returns today's date as a Julian date} - -function ValidDate(Day, Month, Year, Epoch : Integer) : Boolean; - {-Verify that day, month, year is a valid date} - -function DMYtoStDate(Day, Month, Year, Epoch : Integer) : TStDate; - {-Convert from day, month, year to a Julian date} - -procedure StDateToDMY(Julian : TStDate; var Day, Month, Year : Integer); - {-Convert from a Julian date to day, month, year} - -function IncDate(Julian : TStDate; Days, Months, Years : Integer) : TStDate; - {-Add (or subtract) the number of days, months, and years to a date} - -function IncDateTrunc(Julian : TStDate; Months, Years : Integer) : TStDate; - {-Add (or subtract) the specified number of months and years to a date} - -procedure DateDiff(Date1, Date2 : TStDate; - var Days, Months, Years : Integer); -{-Return the difference in days, months, and years between two valid Julian - dates} - -function BondDateDiff(Date1, Date2 : TStDate; DayBasis : TStBondDateType) : TStDate; - {-Return the difference in days between two valid Julian - dates using a specific financial basis} - -function WeekOfYear(Julian : TStDate) : Byte; - {-Returns the week number of the year given the Julian Date} - -function AstJulianDate(Julian : TStDate) : Double; - {-Returns the Astronomical Julian Date from a TStDate} - -function AstJulianDatetoStDate(AstJulian : Double; Truncate : Boolean) : TStDate; - {-Returns a TStDate from an Astronomical Julian Date. - Truncate TRUE Converts to appropriate 0 hours then truncates - FALSE Converts to appropriate 0 hours, then rounds to - nearest;} - -function AstJulianDatePrim(Year, Month, Date : Integer; UT : TStTime) : Double; - {-Returns an Astronomical Julian Date for any year, even those outside - MinYear..MaxYear} - -function DayOfWeek(Julian : TStDate) : TStDayType; - {-Return the day of the week for a Julian date} - -function DayOfWeekDMY(Day, Month, Year, Epoch : Integer) : TStDayType; - {-Return the day of the week for the day, month, year} - -function IsLeapYear(Year : Integer) : Boolean; - {-Return True if Year is a leap year} - -function DaysInMonth(Month : Integer; Year, Epoch : Integer) : Integer; - {-Return the number of days in the specified month of a given year} - -function ResolveEpoch(Year, Epoch : Integer) : Integer; - {-Convert 2 digit year to 4 digit year according to Epoch} - - {-------time routines---------------} - -function ValidTime(Hours, Minutes, Seconds : Integer) : Boolean; - {-Return True if Hours:Minutes:Seconds is a valid time} - -procedure StTimeToHMS(T : TStTime; - var Hours, Minutes, Seconds : Byte); - {-Convert a time variable to hours, minutes, seconds} - -function HMStoStTime(Hours, Minutes, Seconds : Byte) : TStTime; - {-Convert hours, minutes, seconds to a time variable} - -function CurrentTime : TStTime; - {-Return the current time in seconds since midnight} - -procedure TimeDiff(Time1, Time2 : TStTime; - var Hours, Minutes, Seconds : Byte); - {-Return the difference in hours, minutes, and seconds between two times} - -function IncTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime; - {-Add the specified hours, minutes, and seconds to a given time of day} - -function DecTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime; - {-Subtract the specified hours, minutes, and seconds from a given time of day} - -function RoundToNearestHour(T : TStTime; Truncate : Boolean) : TStTime; - {-Given a time, round it to the nearest hour, or truncate minutes and - seconds} - -function RoundToNearestMinute(const T : TStTime; Truncate : Boolean) : TStTime; - {-Given a time, round it to the nearest minute, or truncate seconds} - - {-------- routines for DateTimeRec records ---------} - -procedure DateTimeDiff(DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; - var Days : LongInt; var Secs : LongInt); - {-Return the difference in days and seconds between two points in time} - -procedure IncDateTime(DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; - Days : Integer; Secs : LongInt); - {-Increment (or decrement) a date and time by the specified number of days - and seconds} - -function DateTimeToStDate(DT : TDateTime) : TStDate; - {-Convert Delphi TDateTime to TStDate} - -function DateTimeToStTime(DT : TDateTime) : TStTime; - {-Convert Delphi TDateTime to TStTime} - -function StDateToDateTime(D : TStDate) : TDateTime; - {-Convert TStDate to TDateTime} - -function StTimeToDateTime(T : TStTime) : TDateTime; - {-Convert TStTime to TDateTime} - -function Convert2ByteDate(TwoByteDate : Word) : TStDate; - {-Convert an Object Professional two byte date into a SysTools date} - -function Convert4ByteDate(FourByteDate : TStDate) : Word; - {-Convert a SysTools date into an Object Professional two byte date} - -function FFStDateToString(const ADate : TStDate) : string; -function FFStringToStDate(const ADateStr : string) : TStDate; -function FFStTimeToString(const ATime : TStTime) : string; -function FFStringToStTime(const ATimeStr : string) : TStTime; - -implementation - -const - First2Months = 59; {1600 was a leap year} - FirstDayOfWeek = Saturday; {01/01/1600 was a Saturday} - DateLen = 40; {maximum length of Picture strings} - MaxMonthName = 15; - MaxDayName = 15; - StDateConv = 109571; - -type -{ DateString = string[DateLen];} - SString = string[255]; - -function IsLeapYear(Year : Integer) : Boolean; - {-Return True if Year is a leap year} -begin - Result := (Year mod 4 = 0) and (Year mod 4000 <> 0) and - ((Year mod 100 <> 0) or (Year mod 400 = 0)); -end; - -function IsLastDayofMonth(Day, Month, Year : Integer) : Boolean; - {-Return True if date is the last day in month} -var - Epoch : Integer; -begin - Epoch := (Year div 100) * 100; - if ValidDate(Day + 1, Month, Year, Epoch) then - Result := false - else - Result := true; -end; - -function IsLastDayofFeb(Date : TStDate) : Boolean; - {-Return True if date is the last day in February} -var - Day, Month, Year : Integer; -begin - StDateToDMY(Date, Day, Month, Year); - if (Month = 2) and IsLastDayOfMonth(Day, Month, Year) then - Result := true - else - Result := false; -end; - -procedure ExchangeLongInts(var I, J : LongInt); -register; -asm - mov ecx, [eax] - push ecx - mov ecx, [edx] - mov [eax], ecx - pop ecx - mov [edx], ecx -end; - -procedure ExchangeStructs(var I, J; Size : Cardinal); -register; -asm - push edi - push ebx - push ecx - shr ecx, 2 - jz @@LessThanFour - -@@AgainDWords: - mov ebx, [eax] - mov edi, [edx] - mov [edx], ebx - mov [eax], edi - add eax, 4 - add edx, 4 - dec ecx - jnz @@AgainDWords - -@@LessThanFour: - pop ecx - and ecx, $3 - jz @@Done - mov bl, [eax] - mov bh, [edx] - mov [edx], bl - mov [eax], bh - inc eax - inc edx - dec ecx - jz @@Done - - mov bl, [eax] - mov bh, [edx] - mov [edx], bl - mov [eax], bh - inc eax - inc edx - dec ecx - jz @@Done - - mov bl, [eax] - mov bh, [edx] - mov [edx], bl - mov [eax], bh - -@@Done: - pop ebx - pop edi -end; - -function ResolveEpoch(Year, Epoch : Integer) : Integer; - {-Convert 2-digit year to 4-digit year according to Epoch} -var - EpochYear, - EpochCent : Integer; -begin - if Word(Year) < 100 then begin - EpochYear := Epoch mod 100; - EpochCent := (Epoch div 100) * 100; - if (Year < EpochYear) then - Inc(Year,EpochCent+100) - else - Inc(Year,EpochCent); - end; - Result := Year; -end; - -function CurrentDate : TStDate; - {-Returns today's date as a julian} -var - Year, Month, Date : Word; -begin - DecodeDate(Now,Year,Month,Date); - Result := DMYToStDate(Date,Month,Year,0); -end; - -function DaysInMonth(Month : integer; Year, Epoch : Integer) : Integer; - {-Return the number of days in the specified month of a given year} -begin - Year := ResolveEpoch(Year, Epoch); - - if (Year < MinYear) OR (Year > MaxYear) then - begin - Result := 0; - Exit; - end; - - case Month of - 1, 3, 5, 7, 8, 10, 12 : - Result := 31; - 4, 6, 9, 11 : - Result := 30; - 2 : - Result := 28+Ord(IsLeapYear(Year)); - else - Result := 0; - end; -end; - -function ValidDate(Day, Month, Year, Epoch : Integer) : Boolean; - {-Verify that day, month, year is a valid date} -begin - Year := ResolveEpoch(Year, Epoch); - - if (Day < 1) or (Year < MinYear) or (Year > MaxYear) then - Result := False - else case Month of - 1..12 : - Result := Day <= DaysInMonth(Month, Year, Epoch); - else - Result := False; - end -end; - -function DMYtoStDate(Day, Month, Year, Epoch : Integer) : TStDate; - {-Convert from day, month, year to a julian date} -begin - Year := ResolveEpoch(Year, Epoch); - - if not ValidDate(Day, Month, Year, Epoch) then - Result := BadDate - else if (Year = MinYear) and (Month < 3) then - if Month = 1 then - Result := Pred(Day) - else - Result := Day+30 - else begin - if Month > 2 then - Dec(Month, 3) - else begin - Inc(Month, 9); - Dec(Year); - end; - Dec(Year, MinYear); - Result := - ((LongInt(Year div 100)*146097) div 4)+ - ((LongInt(Year mod 100)*1461) div 4)+ - (((153*Month)+2) div 5)+Day+First2Months; - end; -end; - -function WeekOfYear(Julian : TStDate) : Byte; - {-Returns the week number of the year given the Julian Date} -var - Day, Month, Year : Integer; - FirstJulian : TStDate; -begin - if (Julian < MinDate) or (Julian > MaxDate) then - begin - Result := 0; - Exit; - end; - - Julian := Julian + 3 - ((6 + Ord(DayOfWeek(Julian))) mod 7); - StDateToDMY(Julian,Day,Month,Year); - FirstJulian := DMYToStDate(1,1,Year,0); - Result := 1 + (Julian - FirstJulian) div 7; -end; - -function AstJulianDate(Julian : TStDate) : Double; - {-Returns the Astronomical Julian Date from a TStDate} -begin - {Subtract 0.5d since Astronomical JD starts at noon - while TStDate (with implied .0) starts at midnight} - Result := Julian - 0.5 + DeltaJD; -end; - - -function AstJulianDatePrim(Year, Month, Date : Integer; UT : TStTime) : Double; -var - A, B : integer; - LY, - GC : Boolean; - -begin - Result := -MaxLongInt; - if (not (Month in [1..12])) or (Date < 1) then - Exit - else if (Month in [1, 3, 5, 7, 8, 10, 12]) and (Date > 31) then - Exit - else if (Month in [4, 6, 9, 11]) and (Date > 30) then - Exit - else if (Month = 2) then begin - LY := IsLeapYear(Year); - if ((LY) and (Date > 29)) or (not (LY) and (Date > 28)) then - Exit; - end else if ((UT < 0) or (UT >= SecondsInDay)) then - Exit; - - if (Month <= 2) then begin - Year := Year - 1; - Month := Month + 12; - end; - A := abs(Year div 100); - - if (Year > 1582) then - GC := True - else if (Year = 1582) then begin - if (Month > 10) then - GC := True - else if (Month < 10) then - GC := False - else begin - if (Date >= 15) then - GC := True - else - GC := False; - end; - end else - GC := False; - if (GC) then - B := 2 - A + abs(A div 4) - else - B := 0; - - Result := Trunc(365.25 * (Year + 4716)) - + Trunc(30.6001 * (Month + 1)) - + Date + B - 1524.5 - + UT / SecondsInDay; -end; - - -function AstJulianDatetoStDate(AstJulian : Double; Truncate : Boolean) : TStDate; - {-Returns a TStDate from an Astronomical Julian Date. - Truncate TRUE Converts to appropriate 0 hours then truncates - FALSE Converts to appropriate 0 hours, then rounds to - nearest;} -begin - {Convert to TStDate, adding 0.5d for implied .0d of TStDate} - AstJulian := AstJulian + 0.5 - DeltaJD; - if (AstJulian < MinDate) OR (AstJulian > MaxDate) then - begin - Result := BadDate; - Exit; - end; - - if Truncate then - Result := Trunc(AstJulian) - else - Result := Trunc(AstJulian + 0.5); -end; - -procedure StDateToDMY(Julian : TStDate; var Day, Month, Year : Integer); - {-Convert from a julian date to month, day, year} -var - I, J : LongInt; -begin - if Julian = BadDate then begin - Day := 0; - Month := 0; - Year := 0; - end else if Julian <= First2Months then begin - Year := MinYear; - if Julian <= 30 then begin - Month := 1; - Day := Succ(Julian); - end else begin - Month := 2; - Day := Julian-30; - end; - end else begin - I := (4*LongInt(Julian-First2Months))-1; - - J := (4*((I mod 146097) div 4))+3; - Year := (100*(I div 146097))+(J div 1461); - I := (5*(((J mod 1461)+4) div 4))-3; - Day := ((I mod 153)+5) div 5; - - Month := I div 153; - if Month < 10 then - Inc(Month, 3) - else begin - Dec(Month, 9); - Inc(Year); - end; - Inc(Year, MinYear); - end; -end; - -function IncDate(Julian : TStDate; Days, Months, Years : Integer) : TStDate; - {-Add (or subtract) the number of months, days, and years to a date. - Months and years are added before days. No overflow/underflow - checks are made} -var - Day, Month, Year, Day28Delta : Integer; -begin - StDateToDMY(Julian, Day, Month, Year); - Day28Delta := Day-28; - if Day28Delta < 0 then - Day28Delta := 0 - else - Day := 28; - - Inc(Year, Years); - Inc(Year, Months div 12); - Inc(Month, Months mod 12); - if Month < 1 then begin - Inc(Month, 12); - Dec(Year); - end - else if Month > 12 then begin - Dec(Month, 12); - Inc(Year); - end; - - Julian := DMYtoStDate(Day, Month, Year,0); - if Julian <> BadDate then begin - Inc(Julian, Days); - Inc(Julian, Day28Delta); - end; - Result := Julian; -end; - -function IncDateTrunc(Julian : TStDate; Months, Years : Integer) : TStDate; - {-Add (or subtract) the specified number of months and years to a date} -var - Day, Month, Year : Integer; - MaxDay, Day28Delta : Integer; -begin - StDateToDMY(Julian, Day, Month, Year); - Day28Delta := Day-28; - if Day28Delta < 0 then - Day28Delta := 0 - else - Day := 28; - - Inc(Year, Years); - Inc(Year, Months div 12); - Inc(Month, Months mod 12); - if Month < 1 then begin - Inc(Month, 12); - Dec(Year); - end - else if Month > 12 then begin - Dec(Month, 12); - Inc(Year); - end; - - Julian := DMYtoStDate(Day, Month, Year,0); - if Julian <> BadDate then begin - MaxDay := DaysInMonth(Month, Year,0); - if Day+Day28Delta > MaxDay then - Inc(Julian, MaxDay-Day) - else - Inc(Julian, Day28Delta); - end; - Result := Julian; -end; - -procedure DateDiff(Date1, Date2 : TStDate; var Days, Months, Years : Integer); - {-Return the difference in days,months,years between two valid julian dates} -var - Day1, Day2, Month1, Month2, Year1, Year2 : Integer; -begin - {we want Date2 > Date1} - if Date1 > Date2 then - ExchangeLongInts(Date1, Date2); - - {convert dates to day,month,year} - StDateToDMY(Date1, Day1, Month1, Year1); - StDateToDMY(Date2, Day2, Month2, Year2); - - {days first} - if Day2 < Day1 then begin - Dec(Month2); - if Month2 = 0 then begin - Month2 := 12; - Dec(Year2); - end; - Inc(Day2, DaysInMonth(Month2, Year2,0)); - end; - Days := Day2-Day1; - - {now months and years} - if Month2 < Month1 then begin - Inc(Month2, 12); - Dec(Year2); - end; - Months := Month2-Month1; - Years := Year2-Year1; -end; - -function BondDateDiff(Date1, Date2 : TStDate; DayBasis : TStBondDateType) : TStDate; - {-Return the difference in days between two valid Julian - dates using one a specific accrual method} -var - Day1, - Month1, - Year1, - Day2, - Month2, - Year2 : Integer; - IY : LongInt; -begin - {we want Date2 > Date1} - if Date1 > Date2 then - ExchangeLongInts(Date1, Date2); - - if (DayBasis = bdtActual) then - Result := Date2-Date1 - else - begin - StDateToDMY(Date1, Day1, Month1, Year1); - StDateToDMY(Date2, Day2, Month2, Year2); - - if ((DayBasis = bdt30360PSA) and IsLastDayofFeb(Date1)) or (Day1 = 31) then - Day1 := 30; - if (DayBasis = bdt30E360) then - begin - if (Day2 = 31) then - Day2 := 30 - end else - if (Day2 = 31) and (Day1 >= 30) then - Day2 := 30; - - IY := 360 * (Year2 - Year1); - Result := IY + 30 * (Month2 - Month1) + (Day2 - Day1); - end; -end; - -function DayOfWeek(Julian : TStDate) : TStDayType; - {-Return the day of the week for the date. Returns TStDayType(7) if Julian = - BadDate.} -var - B : Byte; -begin - if Julian = BadDate then begin - B := 7; - Result := TStDayType(B); - end else - Result := TStDayType( (Julian+Ord(FirstDayOfWeek)) mod 7 ); -end; - -function DayOfWeekDMY(Day, Month, Year, Epoch : Integer) : TStDayType; - {-Return the day of the week for the day, month, year} -begin - Result := DayOfWeek( DMYtoStDate(Day, Month, Year, Epoch) ); -end; - -procedure StTimeToHMS(T : TStTime; var Hours, Minutes, Seconds : Byte); - {-Convert a Time variable to Hours, Minutes, Seconds} -begin - if T = BadTime then begin - Hours := 0; - Minutes := 0; - Seconds := 0; - end - else begin - Hours := T div SecondsInHour; - Dec(T, LongInt(Hours)*SecondsInHour); - Minutes := T div SecondsInMinute; - Dec(T, LongInt(Minutes)*SecondsInMinute); - Seconds := T; - end; -end; - -function HMStoStTime(Hours, Minutes, Seconds : Byte) : TStTime; - {-Convert Hours, Minutes, Seconds to a Time variable} -var - T : TStTime; -begin - Hours := Hours mod HoursInDay; - T := (LongInt(Hours)*SecondsInHour)+(LongInt(Minutes)*SecondsInMinute)+Seconds; - Result := T mod SecondsInDay; -end; - -function ValidTime(Hours, Minutes, Seconds : Integer) : Boolean; - {-Return true if Hours:Minutes:Seconds is a valid time} -begin - if (Hours < 0) or (Hours > 23) or - (Minutes < 0) or (Minutes >= 60) or - (Seconds < 0) or (Seconds >= 60) then - Result := False - else - Result := True; -end; - -function CurrentTime : TStTime; - {-Returns current time in seconds since midnight} -begin - Result := Trunc(SysUtils.Time * SecondsInDay); -end; - -procedure TimeDiff(Time1, Time2 : TStTime; var Hours, Minutes, Seconds : Byte); - {-Return the difference in hours,minutes,seconds between two times} -begin - StTimeToHMS(Abs(Time1-Time2), Hours, Minutes, Seconds); -end; - -function IncTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime; - {-Add the specified hours,minutes,seconds to T and return the result} -begin - Inc(T, HMStoStTime(Hours, Minutes, Seconds)); - Result := T mod SecondsInDay; -end; - -function DecTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime; - {-Subtract the specified hours,minutes,seconds from T and return the result} -begin - Hours := Hours mod HoursInDay; - Dec(T, HMStoStTime(Hours, Minutes, Seconds)); - if T < 0 then - Result := T+SecondsInDay - else - Result := T; -end; - -function RoundToNearestHour(T : TStTime; Truncate : Boolean) : TStTime; - {-Round T to the nearest hour, or Truncate minutes and seconds from T} -var - Hours, Minutes, Seconds : Byte; -begin - StTimeToHMS(T, Hours, Minutes, Seconds); - Seconds := 0; - if not Truncate then - if Minutes >= (MinutesInHour div 2) then - Inc(Hours); - Minutes := 0; - Result := HMStoStTime(Hours, Minutes, Seconds); -end; - -function RoundToNearestMinute(const T : TStTime; Truncate : Boolean) : TStTime; - {-Round T to the nearest minute, or Truncate seconds from T} -var - Hours, Minutes, Seconds : Byte; -begin - StTimeToHMS(T, Hours, Minutes, Seconds); - if not Truncate then - if Seconds >= (SecondsInMinute div 2) then - Inc(Minutes); - Seconds := 0; - Result := HMStoStTime(Hours, Minutes, Seconds); -end; - - -procedure DateTimeDiff(DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; - var Days : LongInt; var Secs : LongInt); - {-Return the difference in days and seconds between two points in time} -var - tDT1, tDT2 : TStDateTimeRec; -begin - tDT1 := DT1; - tDT2 := DT2; - {swap if tDT1 later than tDT2} - if (tDT1.D > tDT2.D) or ((tDT1.D = tDT2.D) and (tDT1.T > tDT2.T)) then - ExchangeStructs(tDT1, tDT2,sizeof(TStDateTimeRec)); - - {the difference in days is easy} - Days := tDT2.D-tDT1.D; - - {difference in seconds} - if tDT2.T < tDT1.T then begin - {subtract one day, add 24 hours} - Dec(Days); - Inc(tDT2.T, SecondsInDay); - end; - Secs := tDT2.T-tDT1.T; -end; - -function DateTimeToStDate(DT : TDateTime) : TStDate; - {-Convert Delphi TDateTime to TStDate} -var - Day, Month, Year : Word; -begin - DecodeDate(DT, Year, Month, Day); - Result := DMYToStDate(Day, Month, Year, 0); -end; - -function DateTimeToStTime(DT : TDateTime) : TStTime; - {-Convert Delphi TDateTime to TStTime} -var - Hour, Min, Sec, MSec : Word; -begin - DecodeTime(DT, Hour, Min, Sec, MSec); - Result := HMSToStTime(Hour, Min, Sec); -end; - -function StDateToDateTime(D : TStDate) : TDateTime; - {-Convert TStDate to TDateTime} -var - Day, Month, Year : Integer; -begin - Result := 0; - if D <> BadDate then begin - StDateToDMY(D, Day, Month, Year); - Result := EncodeDate(Year, Month, Day); - end; -end; - -function StTimeToDateTime(T : TStTime) : TDateTime; - {-Convert TStTime to TDateTime} -var - Hour, Min, Sec : Byte; -begin - Result := 0; - if T <> BadTime then begin - StTimeToHMS(T, Hour, Min, Sec); - Result := EncodeTime(Hour, Min, Sec, 0); - end; -end; - -procedure IncDateTime(DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; Days : Integer; Secs : LongInt); - {-Increment (or decrement) DT1 by the specified number of days and seconds - and put the result in DT2} -begin - DT2 := DT1; - - {date first} - Inc(DT2.D, LongInt(Days)); - - if Secs < 0 then begin - {change the sign} - Secs := -Secs; - - {adjust the date} - Dec(DT2.D, Secs div SecondsInDay); - Secs := Secs mod SecondsInDay; - - if Secs > DT2.T then begin - {subtract a day from DT2.D and add a day's worth of seconds to DT2.T} - Dec(DT2.D); - Inc(DT2.T, SecondsInDay); - end; - - {now subtract the seconds} - Dec(DT2.T, Secs); - end - else begin - {increment the seconds} - Inc(DT2.T, Secs); - - {adjust date if necessary} - Inc(DT2.D, DT2.T div SecondsInDay); - - {force time to 0..SecondsInDay-1 range} - DT2.T := DT2.T mod SecondsInDay; - end; -end; - -function Convert2ByteDate(TwoByteDate : Word) : TStDate; -begin - Result := LongInt(TwoByteDate) + Date1900; -end; - -function Convert4ByteDate(FourByteDate : TStDate) : Word; -begin - Result := Word(FourByteDate - Date1900); -end; - -procedure SetDefaultYear; - {-Initialize DefaultYear and DefaultMonth} -var - Month, Day, Year : Word; - T : TDateTime; -begin - T := Now; - DecodeDate(T, Year, Month, Day); - DefaultYear := Year; - DefaultMonth := Month; -end; - -function FFStDateToString(const ADate : TStDate) : string; -begin - Result := FormatDateTime(ShortDateFormat, ADate - StDateConv); -end; - -function FFStringToStDate(const ADateStr : string) : TStDate; -begin - Result := Trunc(StrToDateTime(ADateStr)) + StDateConv; -end; - -function FFStTimeToString(const ATime : TStTime) : string; -begin - Result := FormatDateTime(ShortTimeFormat, StTimeToDateTime(ATime)); -end; - -function FFStringToStTime(const ATimeStr : string) : TStTime; -begin - Result := DateTimeToStTime(StrToDateTime(ATimeStr)); -end; - -initialization - {initialize DefaultYear and DefaultMonth} - SetDefaultYear; -end. diff --git a/components/flashfiler/sourcelaz/fftbbase.pas b/components/flashfiler/sourcelaz/fftbbase.pas deleted file mode 100644 index 57058cb56..000000000 --- a/components/flashfiler/sourcelaz/fftbbase.pas +++ /dev/null @@ -1,616 +0,0 @@ -{*********************************************************} -{* FlashFiler: Table access - general & helper 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 fftbbase; - -interface - -uses - Windows, - SysUtils, - Classes, - ffconst, - ffllbase, - ffsrlock, - ffsrmgr, - ffllexcp, - ffsrbase, - fffile, - ffsrintf, - fflldict; - -{---Field comparison routine---} -function FFKeyCompareField(const Key1, Key2; - FieldType : TffFieldType; - FieldLen : Integer; - NoCase : Boolean) : integer; - {-Treat Key1 and Key2 as Filer typed fields, compare} - -{---Table helper routines---} -function FFTblHlpGetNewBlock(aFI : PffFileInfo; - aTI : PffTransInfo; - var aReleaseMethod : TffReleaseMethod) - : PffBlock; - {-Return a new block, pre-marked as dirty. Exclusively locks the - file header block and recycled block (if one is available). } -procedure FFTblHlpDelete(const aPath : TffPath; - const aTableName : TffTableName; - const aDict : TffDataDictionary); - {-Delete all files associated with a table} -procedure FFTblHlpDeleteBlock(aFI : PffFileInfo; - aFileHeader : PffBlockHeaderFile; - aBlock : PffBlock); - {-Delete the block, add it to the deleted block chain. Assumes the block - has been exclusively locked. } - -procedure FFTblHlpRename(const aPath : TffPath; - const aTableName : TffTableName; - const aNewName : TffTableName; - const aDict : TffDataDictionary); - {-Renames all files associated with a table} - -{---Buffer manager access routines---} -function FFBMAddBlock(aFI : PffFileInfo; - aTI : PffTransInfo; - const aBlockNum : TffWord32; - var aReleaseMethod : TffReleaseMethod) : PffBlock; - {-Return address of a new block} -procedure FFBMDirtyBlock(aFI : PffFileInfo; - const aBlockNum : TffWord32; - aTI : PffTransInfo; - var aModifiableBlock : PffBlock); - {-Mark a block dirty. The block *must* be in the buffer already. - Returns a pointer to the modifiable copy of the block in output variable - aModifiableBlock. The calling function *MUST* - use the modifiable copy instead of the read-only copy it currently - possesses. } -function FFBMGetBlock(aFI : PffFileInfo; - aTI : PffTransInfo; - const aBlockNum : TffWord32; - const aMarkDirty : Boolean; - var aReleaseMethod : TffReleaseMethod) : PffBlock; - {-Retrieves the specified file block. If aMarkDirty is False then returns - a pointer to the read-only copy of the block. If aMarkDirty is True then - returns a modifiable copy of the block. } -function FFBMGetFileHeaderBlock(aFI : PffFileInfo; - aTI : PffTransInfo; - const aMarkDirty : Boolean; - var aReleaseMethod : TffReleaseMethod) : PffBlock; - {-Reads a file header (block 0) into buffer, returns address. - Note: this routine verifies the header block to be a valid header - block, so it must be used IMMEDIATELY after opening a file; - also sets the block size for the file} -procedure FFBMRemoveFile(aFI : PffFileInfo); - {-Mark a file's blocks in the buffer manager as available for reuse} -procedure FFBMUnlockBlock(aFI : PffFileInfo; aBlockNum : TffWord32); - {-Unlock a block making it available for reuse immediately.} - -{---Lock manager access routines---} -procedure FFAcqRecordLock(aFI : PffFileInfo; - aTI : PffTransInfo; - const aRefNum : TffInt64; - const aLockType : TffSrLockType; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.02} - const aConditional : Boolean); {!!.02} - { Use this procedure to obtain a lock on a record. If the lock is not - granted then an exception is raised. } - -{Begin !!.10} -procedure FFRelaxRecordLock(aFI : PffFileInfo; - aTI : PffTransInfo; - const aCursorID : TffCursorID; - const aRefNum : TffInt64); - { Used by data modification operations to make a modified record available - to other cursors within the same transaction. } -{End !!.10} - -procedure FFRelRecordLock(aFI : PffFileInfo; - aTI : PffTransInfo; - const aRefNum : TffInt64; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID); - { Use this procedure to release an existing record lock. } - -implementation - -uses {!!.11} - FFSrEng; {!!.11} - -resourcestring - ffcRecord = 'record %d:%d (high:low)'; - -{== Field comparison routine =========================================} -function FFKeyCompareField(const Key1, Key2; - FieldType : TffFieldType; - FieldLen : Integer; - NoCase : Boolean) - : Integer; -var - CompareData : TffCompareData; - Ch1, Ch2 : AnsiChar; -begin - CompareData.cdPartLen := 0; - {we'll use an ascending type comparison here, our caller will flip - the sign of our result if required} - CompareData.cdAscend := True; - CompareData.cdNoCase := NoCase; - case FieldType of - fftBoolean : - begin - {assumption: True is greater than False} - if boolean(Key1) then - if boolean(Key2) then Result := 0 - else Result := 1 - else - if boolean(Key2) then Result := -1 - else Result := 0; - end; - fftChar : - begin - if NoCase then begin - Ch1 := upcase(AnsiChar(Key1)); - Ch2 := upcase(AnsiChar(Key2)); - Result := FFCmpB(byte(Ch1), byte(Ch2)); - end - else - Result := FFCmpB(byte(Key1), byte(Key2)); - end; - fftWideChar : - begin - CompareData.cdKeyLen := 1; - Result := FFKeyCompareWideChar(Key1, Key2, @CompareData); - end; - fftByte : - begin - Result := FFCmpB(byte(Key1), byte(Key2)); - end; - fftWord16 : - begin - Result := FFCmpW(TffWord16(Key1), TffWord16(Key2)); - end; - fftWord32 : - begin - Result := FFCmpDW(TffWord32(Key1), TffWord32(Key2)); - end; - fftInt8 : - begin - Result := FFCmpI8(shortint(Key1), shortint(Key2)); - end; - fftInt16 : - begin - Result := FFCmpI16(smallint(Key1), smallint(Key2)); - end; - fftInt32 : - begin - Result := FFCmpI32(longint(Key1), longint(Key2)); - end; - fftAutoInc : - begin - Result := FFCmpDW(TffWord32(Key1), TffWord32(Key2)); - end; - fftSingle : - begin - if single(Key1) = single(Key2) then Result := 0 - else if single(Key1) > single(Key2) then Result := 1 - else Result := -1; - end; - fftDouble : - begin - if double(Key1) = double(Key2) then Result := 0 - else if double(Key1) > double(Key2) then Result := 1 - else Result := -1; - end; - fftExtended : - begin - if extended(Key1) = extended(Key2) then Result := 0 - else if extended(Key1) > extended(Key2) then Result := 1 - else Result := -1; - end; - fftComp, - fftCurrency : - begin - if comp(Key1) = comp(Key2) then Result := 0 - else if comp(Key1) > comp(Key2) then Result := 1 - else Result := -1; - end; - fftStDate, - fftStTime : - begin - Result := FFCmpI32(longint(Key1), longint(Key2)); - end; - fftDateTime : - begin - if double(Key1) = double(Key2) then Result := 0 - else if double(Key1) > double(Key2) then Result := 1 - else Result := -1; - end; - fftBLOB, - fftBLOBMemo, - fftBLOBFmtMemo, - fftBLOBOLEObj, - fftBLOBGraphic, - fftBLOBDBSOLEObj, - fftBLOBTypedBin, - fftBLOBFile : - begin - Result := 0; {a spurious value} - FFRaiseExceptionNoData(EffServerException, ffStrResServer, fferrCannotCompare); - end; - fftByteArray : - begin - CompareData.cdKeyLen := FieldLen; - Result := FFKeyCompareBytes(Key1, Key2, @CompareData); - end; - fftShortString : - begin - CompareData.cdKeyLen := FieldLen - 1; - Result := FFKeyCompareStr(Key1, Key2, @CompareData); - end; - fftShortAnsiStr : - begin - CompareData.cdKeyLen := FieldLen - 1; - Result := FFKeyCompareAnsiStr(Key1, Key2, @CompareData); - end; - fftNullString : - begin - CompareData.cdKeyLen := FieldLen; - Result := FFKeyCompareStrZ(Key1, Key2, @CompareData); - end; - fftNullAnsiStr : - begin - CompareData.cdKeyLen := FieldLen; - Result := FFKeyCompareAnsiStrZ(Key1, Key2, @CompareData); - end; - fftWideString : - begin - CompareData.cdKeyLen := FieldLen div sizeof(WideChar); - Result := FFKeyCompareWideStr(Key1, Key2, @CompareData); - end; - else - Result := 0; {a spurious value} - FFRaiseExceptionNoData(EffServerException, ffStrResServer, fferrBadFieldType); - end;{case} -end; -{=====================================================================} - -{== Internal Table Helper routines ===================================} -function FFTblHlpGetNewBlock(aFI : PffFileInfo; - aTI : PffTransInfo; - var aReleaseMethod : TffReleaseMethod) {!!.11} - : PffBlock; -var - aFileHeader : PffBlockHeaderFile; - BlockHdr : PffBlockHeaderFile absolute Result; {a convenient typecast} - BlockNumber : Longint; - aFHRelMethod : TffReleaseMethod; -begin - - aFileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, - aTI, - 0, - True, - aFHRelMethod)); - try - {find a new block} - with aFileHeader^ do begin - {if there are no deleted blocks...} - if (bhfAvailBlocks = 0) then begin - {Have we reached the max # of blocks? } - if (bhfUsedBlocks = aFI^.fiMaxBlocks) then - FFRaiseExceptionNoData(EffServerException, - ffStrResServer, - fferrTableFull); -{Begin !!.11} - if ((TffSrDatabase(aTI^.tirTrans.DatabaseID).CheckSpace) and - (not (fffaTemporary in aFI^.fiAttributes)) and {!!.12} - (FFGetDiskFreeSpace(ExtractFileDir(aFI^.fiName^)) < - aFI^.fiBlockSizeK)) then - FFRaiseExceptionNoData(EffServerException, - ffStrResServer, - fferrDiskFull); -{End !!.11} - - {get a brand new block} - BlockNumber := bhfUsedBlocks; - {Note: We don't need to lock the new block because the file's - header block is exclusively locked. This prevents - other threads from adding the same block to the file - and doesn't allow them to read it since they don't know - about it yet. } - Result := FFBMAddBlock(aFI, aTI, BlockNumber, aReleaseMethod); - inc(bhfUsedBlocks); - aFI^.fiUsedBlocks := bhfUsedBlocks; - if not (fffaTemporary in aFI^.fiAttributes) then {!!.12} - aTI^.tirTrans.NewSpace := aTI^.tirTrans.NewSpace + aFI^.fiBlockSizeK; {!!.11} - end - else {...there are some deleted blocks} begin - { Reuse the first in the deleted block chain. } - BlockNumber := bhf1stFreeBlock; - Result := FFBMGetBlock(aFI, - aTI, - BlockNumber, - True, - aReleaseMethod); - bhf1stFreeBlock := BlockHdr^.bhfNextBlock; - dec(bhfAvailBlocks); - end; - end; - {set the only field in the block header we can} - BlockHdr^.bhfThisBlock := BlockNumber; - finally - aFHRelMethod(PffBlock(aFileHeader)); - end; -end; -{--------} -procedure FFTblHlpDelete(const aPath : TffPath; - const aTableName : TffTableName; - const aDict : TffDataDictionary); -var - SL : TffStringList; - i : integer; - TblName : TffTableName; - FullName : TffFullFileName; -begin - SL := TffStringList.Create; - try - if (FFExtractExtension(aTableName) = ffc_ExtForData) then - TblName := FFExtractFileName(aTableName) - else - TblName := aTableName; - - for i := 0 to Pred(aDict.FileCount) do begin - if i = 0 then - { Force file extension. } - FullName := FFMakeFullFileName(aPath, - FFMakeFileNameExt(TblName, - ffc_ExtForData)) - else - { Use file extension from data dictionary. } - FullName := FFMakeFullFileName(aPath, - FFMakeFileNameExt(TblName, - aDict.FileExt[i])); - FFDeleteFile(FullName); - end; - finally - SL.Free; - end; -end; -{--------} -procedure FFTblHlpDeleteBlock(aFI : PffFileInfo; - aFileHeader : PffBlockHeaderFile; - aBlock : PffBlock); -var - BlockHdr : PffBlockHeaderFile absolute aBlock; {a convenient typecast} -begin - { Assumption: File header block & aBlock have been exclusively locked. } - - {add it to the deleted block chain} - with aFileHeader^ do begin - {destroy the info in the block header} - BlockHdr^.bhfSignature := ffc_SigFreeBlock; - BlockHdr^.bhfNextBlock := bhf1stFreeBlock; - {add it to the deleted block chain} - bhf1stFreeBlock := BlockHdr^.bhfThisBlock; - inc(bhfAvailBlocks); - end; -end; -{--------} -procedure FFTblHlpRename(const aPath : TffPath; - const aTableName : TffTableName; - const aNewName : TffTableName; - const aDict : TffDataDictionary); -var - SL : TffStringList; - i : integer; - TblName : TffTableName; - NewName : TffTableName; - FullName : TffFullFileName; - FullNewName : TffFullFileName; -begin - SL := TffStringList.Create; - try - if (FFExtractExtension(aTableName) = ffc_ExtForData) then - TblName := FFExtractFileName(aTableName) - else - TblName := aTableName; - - if (FFExtractExtension(aNewName) = ffc_ExtForData) then - NewName := FFExtractFileName(aNewname) - else - NewName := aNewName; - - for i := 0 to Pred(aDict.FileCount) do begin - if i = 0 then begin - { Force file extension. } - FullName := FFMakeFullFileName(aPath, - FFMakeFileNameExt(TblName, - ffc_ExtForData)); - FullNewName := FFMakeFullFileName(aPath, - FFMakeFileNameExt(NewName, - ffc_ExtForData)); - end else begin - { Use file extension from data dictionary. } - FullName := FFMakeFullFileName(aPath, - FFMakeFileNameExt(TblName, - aDict.FileExt[i])); - FullNewName := FFMakeFullFileName(aPath, - FFMakeFileNameExt(NewName, - aDict.FileExt[i])); - end; - FFRenameFile(FullName, FullNewName); - end; - finally - SL.Free; - end; -end; -{====================================================================} - - -{===Buffer manager access routines===================================} -function FFBMAddBlock(aFI : PffFileInfo; - aTI : PffTransInfo; - const aBlockNum : TffWord32; - var aReleaseMethod : TffReleaseMethod) : PffBlock; -begin - Assert(assigned(aFI) and assigned(aFI^.fiBufMgr)); - Result := aFI^.fiBufMgr.AddBlock(aFI, aTI, aBlockNum, aReleaseMethod) -end; -{--------} -procedure FFBMDirtyBlock(aFI : PffFileInfo; - const aBlockNum : TffWord32; - aTI : PffTransInfo; - var aModifiableBlock : PffBlock); -begin - Assert(assigned(aFI)); - aFI^.fiBufMgr.DirtyBlock(aFI, aBlockNum, aTI, aModifiableBlock); -end; -{--------} -function FFBMGetBlock(aFI : PffFileInfo; - aTI : PffTransInfo; - const aBlockNum : TffWord32; - const aMarkDirty : Boolean; - var aReleaseMethod : TffReleaseMethod) : PffBlock; -begin - Assert(aTI <> nil, 'No transaction specified.'); {!!.03} - if Assigned(aFI) and Assigned(aFI^.fiBufMgr) then - Result := aFI^.fiBufMgr.GetBlock(aFI, aBlockNum, aTI, aMarkDirty, - aReleaseMethod) - else - Result := nil; -end; -{--------} -function FFBMGetFileHeaderBlock(aFI : PffFileInfo; - aTI : PffTransInfo; - const aMarkDirty : Boolean; - var aReleaseMethod : TffReleaseMethod) : PffBlock; -begin - if Assigned(aFI) and Assigned(aFI^.fiBufMgr) then - Result := aFI^.fiBufMgr.AddFile(aFI, aTI, aMarkDirty, aReleaseMethod) - else - Result := nil; -end; -{--------} -procedure FFBMRemoveFile(aFI : PffFileInfo); -begin - if Assigned(aFI) and Assigned(aFI^.fiBufMgr) then - aFI^.fiBufMgr.RemoveFile(aFI); -end; -{--------} -procedure FFBMUnlockBlock(aFI : PffFileInfo; aBlockNum : TffWord32); -begin - if Assigned(aFI) and Assigned(aFI^.fiBufMgr) then - aFI^.fiBufMgr.UnlockBlock(aFI, aBlockNum); -end; -{====================================================================} - -{===Lock manager access routines=====================================} -procedure FFAcqRecordLock(aFI : PffFileInfo; - aTI : PffTransInfo; - const aRefNum : TffInt64; - const aLockType : TffSrLockType; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID; {!!.02} - const aConditional : Boolean); {!!.02} -var - LockStatus : TffLockRequestStatus; - RecStr : string; - RetryUntil : DWORD; - TickCount : DWORD; -begin - - { We support only exclusive locking of records. } - if (aFI^.fiExclOwner = aCursorID) or (aLockType <> ffsltExclusive) then - Exit; - - RetryUntil := FFGetRetry; - TickCount := GetTickCount; - - { Do we have any time left? Note that we are doing this check to avoid - the situation where we ask for a lock and pass a negative timeout. } - if (RetryUntil > TickCount) and - ((RetryUntil - TickCount) >= 5) then begin - { Obtain an exclusive lock on the record. } - LockStatus := TffLockManager(aTI^.tirLockMgr).AcquireRecordLock - (aRefNum, aFI, - aLockType, - aConditional, {!!.02} - (RetryUntil - TickCount), - aTI^.tirTrans, - aDatabaseID, {!!.10} - aCursorID); - - { Raise an exception if something went awry. } - if LockStatus <> fflrsGranted then - RecStr := format(ffcRecord,[aRefNum.iHigh, aRefNum.iLow]); - case LockStatus of - fflrsTimeout : - FFRaiseException(EffServerException, ffStrResServer, fferrLockTimeout, - [FFMapLockToName(aLockType), RecStr, aFI^.fiName^]); - fflrsRejected : - FFRaiseException(EffServerException, ffStrResServer, fferrLockRejected, - [FFMapLockToName(aLockType), RecStr, aFI^.fiName^]); - end; { case } - end - else - { No. Assume we will time out waiting for the resource. } - FFRaiseExceptionNoData(EffServerException, ffStrResServer, - fferrGeneralTimeout); -end; -{Begin !!.10} -{--------} -procedure FFRelaxRecordLock(aFI : PffFileInfo; - aTI : PffTransInfo; - const aCursorID : TffCursorID; - const aRefNum : TffInt64); -begin - if (aFI^.fiExclOwner = aCursorID) then - Exit; - - TffLockManager(aTI^.tirLockMgr).RelaxRecordLock - (aRefNum, aFI, aTI^.tirTrans.DatabaseID); -end; -{End !!.10} -{--------} -procedure FFRelRecordLock(aFI : PffFileInfo; aTI : PffTransInfo; - const aRefNum : TffInt64; - const aDatabaseID : TffDatabaseID; {!!.10} - const aCursorID : TffCursorID); -begin - if (aFI^.fiExclOwner = aCursorID) then - Exit; - - TffLockManager(aTI^.tirLockMgr).ReleaseRecordLock - (aRefNum, aFI, aTI^.tirTrans, aDatabaseID); {!!.10} -end; -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/fftbblob.pas b/components/flashfiler/sourcelaz/fftbblob.pas deleted file mode 100644 index 3a66ec910..000000000 --- a/components/flashfiler/sourcelaz/fftbblob.pas +++ /dev/null @@ -1,3254 +0,0 @@ -{*********************************************************} -{* FlashFiler: Table BLOB access *} -{*********************************************************} - -(* ***** 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} - -{!!.11 - Added logging} -{ Uncomment the following define to enable BLOB tracing. } -{.$DEFINE BLOBTrace} - -unit fftbblob; - -interface - -uses - Classes, {!!.03} - Windows, - SysUtils, - ffconst, - ffllbase, - ffsrmgr, - ffllexcp, - ffsrbase, - ffsrlock, - fffile, - fftbbase; - -{---BLOB Link method types---} -type - TffBLOBLinkGetLength = function(const aTableName : TffTableName; - const aBLOBNr : TffInt64; - var aLength : Longint) : TffResult of object; - { Declaration of method to be called when trying to find the length - of a BLOB visible through a BLOB link. } - - TffBLOBLinkRead = function(const aTableName : TffTableName; - const aBLOBNr : TffInt64; - const aOffset : TffWord32; {!!.06} - const aLen : TffWord32; {!!.06} - var aBLOB; - var aBytesRead : TffWord32) {!!.06} - : TffResult of object; - { Declaration of a method to be called when trying to read a BLOB visible - through a BLOB link. } - -{---BLOB maintenance---} -procedure FFTblAddBLOB(aFI : PffFileInfo; - aTI : PffTransInfo; - var aBLOBNr : TffInt64); - {-add a new, empty (length 0) BLOB, return new BLOB number} - -procedure FFTblAddBLOBLink(aFI : PffFileInfo; - aTI : PffTransInfo; - const aTableName : TffTableName; - const aTableBLOBNr : TffInt64; - var aBLOBNr : TffInt64); - {-Add a new BLOB link, return new BLOB number. } - -procedure FFTblAddFileBLOB(aFI : PffFileInfo; - aTI : PffTransInfo; - const aFileName : TffFullFileName; - var aBLOBNr : TffInt64); - {-add a new file BLOB, return new BLOB number} - -procedure FFTblDeleteBLOB(aFI : PffFileInfo; - aTI : PffTransInfo; - const aBLOBNr : TffInt64); - {-delete a BLOB; BLOB number will no longer be valid after this} - -function FFTblFreeBLOB(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64) : boolean; - {-if the BLOB length is zero, delete it; return true if deleted} - -function FFTblGetBLOBLength(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aLengthMethod : TffBLOBLinkGetLength; - var aFBError: TffResult) : Longint; - {-return the length of the BLOB} - -function FFTblGetFileNameBLOB(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - var aFileName : TffFullFileName ) : Boolean; - {-return True if the given BLOB nr refers to a file BLOB, and the - filename is returned in aFileName} - -function FFTblIsBLOBLink(aFI : PffFileInfo; {!!.11 - New} - aTI : PffTransInfo; - aBLOBNr : TffInt64; - var aSrcTableName : TffTableName; - var aSrcTableBLOBNr : TffInt64) - : Boolean; - { Checks to see if aBLOBNr is a BLOB Link. If it is, it returns the - the offset of the source as aSrcTableBLOBNr in aSrcTableName - -{Begin !!.03} -procedure FFTblListBLOBSegments(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aStream : TStream); - { List the segments comprising the BLOB. } -{End !!.03} - -{Begin !!.11} -type - TffBaseBLOBEngine = class; { foward declaration } - TffBLOBEngineClass = class of TffBaseBLOBEngine; - - TffBaseBLOBEngine = class(TffObject) - { Base class representing an engine to read, write, & truncate BLOBs. } - public - class function GetEngine(aFI : PffFileInfo) : TffBaseBLOBEngine; - { Returns the engine instance to be used for the specified file. } - - procedure Read(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aOffset : TffWord32; - aLen : TffWord32; - aReadMethod : TffBLOBLinkRead; - var aBLOB; - var aBytesRead : TffWord32; - var aFBError : TffResult); virtual; abstract; - { Read all or part of a BLOB} - - procedure Truncate(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aLen : TffWord32); virtual; abstract; - { Truncate the BLOB to the specified length. Does *not* delete BLOB if - length 0. } - - procedure Write(aFI : PffFileInfo; - aTI : PffTransInfo; - const aBLOBNr : TffInt64; - aOffset : TffWord32; - aLen : TffWord32; - const aBLOB); virtual; abstract; - { Write to or append to a BLOB. } - end; - - TffBLOBEngine = class(TffBaseBLOBEngine) - { This class provides an interface to BLOBs in 2.1.0.1 and later. The logic - supports the improved nesting algorithm that recycles all available - BLOB segments regardless of size. } -{Begin !!.12} - protected - function IsEmptyLookupEntry(Entry : PffBLOBLookupEntry) : Boolean; -{End !!.12} - public - procedure Read(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aOffset : TffWord32; - aLen : TffWord32; - aReadMethod : TffBLOBLinkRead; - var aBLOB; - var aBytesRead : TffWord32; - var aFBError : TffResult); override; - { Read all or part of a BLOB} - - procedure Truncate(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aLen : TffWord32); override; - { Truncate the BLOB to the specified length. Does *not* delete BLOB if - length 0. } - - procedure Write(aFI : PffFileInfo; - aTI : PffTransInfo; - const aBLOBNr : TffInt64; - aOffset : TffWord32; - aLen : TffWord32; - const aBLOB); override; - { Write to or append to a BLOB. } - end; - - Tff210BLOBEngine = class(TffBaseBLOBEngine) - { This class provides an interface to BLOBs that is compatible with tables - created under versions 2.0.0.0 to 2.1.0.0. } - public - procedure Read(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aOffset : TffWord32; - aLen : TffWord32; - aReadMethod : TffBLOBLinkRead; - var aBLOB; - var aBytesRead : TffWord32; - var aFBError : TffResult); override; - { Read all or part of a BLOB} - - procedure Truncate(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aLen : TffWord32); override; - { Truncate the BLOB to the specified length. Does *not* delete BLOB if - length 0. } - - procedure Write(aFI : PffFileInfo; - aTI : PffTransInfo; - const aBLOBNr : TffInt64; - aOffset : TffWord32; - aLen : TffWord32; - const aBLOB); override; - { Write to or append to a BLOB. } - end; - -function FFTblRebuildLookupSegments(aFI : PffFileInfo; - aTI : PffTransInfo; - aNewBLOBSize : TffWord32; - aOldBLOBSize : TffWord32; - const aBLOBNr : TffInt64) - : TffInt64; - {-rebuilds all lookup segment(s) for a BLOB that is growing} - -{End !!.11} - -implementation - -uses - fflllog, {!!.13} - ffsrbde, - ffsrblob; - -resourcestring - ffcBLOBSegExpected = ' Expected %s segment but segment marked with ''%s''.'; - ffcBLOBSegHeader = 'header'; - -const - ffc_FileBLOB = -1; - ffc_BLOBLink = -2; - -{Begin !!.11} -var - FFBLOBEngine : TffBLOBEngine; - FF210BLOBEngine : Tff210BLOBEngine; -{End !!.11} - -{Begin !!.13} -{$IFDEF BLOBTrace} -var - btLog : TffEventLog; - -procedure Logbt(aMsg : string; args : array of const); -begin - if btLog <> nil then - btLog.WriteStringFmt(aMsg, args); -end; -{$ENDIF} -{End !!.13} - -{== Calculation routines =============================================} -function EstimateSegmentCount(const aBLOBSize, aMaxSegSize : Integer) - : Integer; -begin - Result := ((aBLOBSize * 2) div aMaxSegSize) + 1; -end; - -{Begin !!.11} -function CalcBLOBSegNumber(const aOffset : TffWord32; - const aBlockSize : TffWord32; - var aOfsInSeg : TffWord32) : TffWord32; - {-Calculate the segment number for an offset into a BLOB.} - {-aOfsInSeg tells us how much of the last segment (result) - we're using} -var - MaxSegSize : TffWord32; -begin - {offset 0 is in the 1st segment} - if aOffset = 0 then begin - Result := 1; - aOfsInSeg := 0; - end else begin - MaxSegSize := (((aBlockSize - ffc_BlockHeaderSizeBLOB) - div ffc_BLOBSegmentIncrement) * ffc_BLOBSegmentIncrement) - - sizeof(TffBLOBSegmentHeader); - aOfsInSeg := 0; - - Result := aOffset div MaxSegSize; - aOfsInSeg := aOffset - (Result * MaxSegSize); - if aOfsInSeg > 0 then - inc(Result) - else if (aOfsInSeg = 0) and - (aOffset <> 0) then - aOfsInSeg := MaxSegSize; - end; {if..else} -end; -{=====================================================================} - -{== BLOB link routines ===============================================} -function BLOBLinkGetLength(aBLOBHeader : PffBLOBHeader; - aGetLengthMethod : TffBLOBLinkGetLength; - var aLength : Longint) - : TffResult; -var - BLOBData : PffByteArray absolute aBLOBHeader; - BLOBNr : TffInt64; - TableName : TffFullFileName; - TableNameLen : Byte; -begin - { Get the length of the table name. } - Move(BLOBData^[sizeof(TffBLOBHeader)], TableNameLen, sizeOf(TableNameLen)); - Inc(TableNameLen); - { Copy the file name to TableName. } - Move(BLOBData^[sizeof(TffBLOBHeader)], TableName, TableNameLen); - { Get the table's BLOB number. } - Move(BLOBData^[SizeOf(TffBLOBHeader) + TableNameLen], BlobNr, - SizeOf(TffInt64)); - - Result := aGetLengthMethod(TableName, BlobNr, aLength); - -end; -{--------} -procedure BLOBLinkGetTableNameAndRefNr(aBLOBBlock : PffBlock; {!!.11 - New} - aBlockOffset : Integer; - var aTableName : TffTableName; - var aBLOBNr : TffInt64); -var - TableNameLen : Byte; -begin - { Get the length of the table name. } - Inc(aBlockOffset, SizeOf(TffBLOBHeader)); - Move(aBLOBBlock^[aBlockOffset], TableNameLen, SizeOf(TableNameLen)); - Inc(TableNameLen); - { Copy the file name to TableName. } - Move(aBLOBBlock^[aBlockOffset], aTableName, TableNameLen); - { Get the table's BLOB number. } - Move(aBLOBBlock^[aBlockOffset + TableNameLen], - aBLOBNr, - SizeOf(TffInt64)); -end; -{--------} -function BLOBLinkRead(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aOffset : Longint; - aLen : Longint; - aReadMethod : TffBLOBLinkRead; - var aBLOB; - var aBytesRead : TffWord32) {!!.06} - : TffResult; -var - BLOBBlock : PffBlock; - BLOBNr : TffInt64; - OffsetInBlock : TffWord32; {!!.11} - {TableNameLen : Byte;} {!!.11} - TableName : TffTableName; - aFHRelMethod : TffReleaseMethod; -begin - BLOBBlock := ReadVfyBlobBlock(aFI, - aTI, - ffc_ReadOnly, - aBLOBNr, - OffsetInBlock, - aFHRelMethod); - try - BLOBLinkGetTableNameAndRefNr(BLOBBlock, {!!.11} - OffsetInBlock, - TableName, - BLOBNr); - Result := aReadMethod(TableName, - BlobNr, - aOffset, - aLen, - aBLOB, - aBytesRead); - finally - aFHRelMethod(BLOBBlock); - end; -end; -{=====================================================================} - -{== File BLOB routines ===============================================} -function FileBLOBLength(aBLOBHeader : PffBLOBHeader; - var aLength : Longint) - : TffResult; -var - BLOBFile : PffFileInfo; - BLOBData : PffByteArray absolute aBLOBHeader; - FileName : TffFullFileName; - FileNameLen : Byte; - TmpLen : TffInt64; -begin - Result := 0; - - {Get the length of the file name} - Move(BLOBData^[sizeof(TffBLOBHeader)], FileNameLen, sizeOf(FileNameLen)); - {copy the file name to FileName} - Move(BLOBData^[sizeof(TffBLOBHeader)], FileName, succ(FileNameLen)); - - try - BLOBFile := FFAllocFileInfo(FileName, FFExtractExtension(FileName), nil); - try - FFOpenFile(BLOBFile, omReadOnly, smShared, false, false); - try - TmpLen := FFPositionFileEOF(BLOBFile); - aLength := TmpLen.iLow; - finally - FFCloseFile(BLOBFile); - end;{try..finally} - finally - FFFreeFileInfo(BLOBFile); - end;{try..finally} - except - on E : EffException do begin - case E.ErrorCode of - fferrOpenFailed : Result := DBIERR_FF_FileBLOBOpen; - fferrCloseFailed : Result := DBIERR_FF_FileBLOBClose; - fferrReadFailed : Result := DBIERR_FF_FileBLOBRead; - fferrSeekFailed : Result := DBIERR_FF_FileBLOBRead; - else - raise - end;{case} - end; - end;{try..except} -end; -{--------} -function FileBLOBRead(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aOffset : Longint; - aLen : Longint; - var aBLOB; - var aBytesRead : TffWord32) {!!.06} - : TffResult; -var - BLOBFile : PffFileInfo; - BLOBBlock : PffBlock; - OffsetInBlock : TffWord32; {!!.11} - FileNameLen : Byte; - FileName : TffFullFileName; - TempI64 : TffInt64; - aFHRelMethod : TffReleaseMethod; -begin - Result := 0; - BLOBBlock := ReadVfyBlobBlock(aFI, - aTI, - ffc_ReadOnly, - aBLOBNr, - OffsetInBlock, - aFHRelMethod); - try - {Get the length of the file name} - Move(BLOBBlock^[(OffsetInBlock + sizeof(TffBLOBHeader))], - FileNameLen, sizeOf(FileNameLen)); - {copy the file name to FileName} - Move(BLOBBlock^[(OffsetInBlock + sizeof(TffBLOBHeader))], - FileName, succ(FileNameLen)); - try - BLOBFile := FFAllocFileInfo(FileName, FFExtractExtension(FileName), nil); - try - FFOpenFile(BLOBFile, omReadOnly, smShared, false, false); - try - TempI64.iLow := aOffset; - TempI64.iHigh := 0; - FFPositionFile(BLOBFile, TempI64); - aBytesRead := FFReadFile(BLOBFile, aLen, aBLOB); - finally - FFCloseFile(BLOBFile); - end;{try..finally} - finally - FFFreeFileInfo(BLOBFile); - end;{try..finally} - except - on E : EffException do begin - case E.ErrorCode of - fferrOpenFailed : Result := DBIERR_FF_FileBLOBOpen; - fferrCloseFailed : Result := DBIERR_FF_FileBLOBClose; - fferrReadFailed : Result := DBIERR_FF_FileBLOBRead; - fferrSeekFailed : Result := DBIERR_FF_FileBLOBRead; - else - raise - end;{case} - end; - end;{try..except} - finally - aFHRelMethod(BLOBBlock); - end; -end; -{=====================================================================} - -{== BLOB maintenance =================================================} -procedure FFTblAddBLOB(aFI : PffFileInfo; - aTI : PffTransInfo; - var aBLOBNr : TffInt64); -var - FileHeader : PffBlockHeaderFile; - BLOBHeaderPtr : PffBLOBHeader; - BLOBBlock : PffBlock; - SegSize : TffWord32; {!!.11} - OffsetInBlock : TffWord32; {!!.11} - aBlkRelMethod, - aFHRelMethod : TffReleaseMethod; -begin -{$IFDEF BLOBTrace} {!!.11} - Logbt('FFTblAddBLOB.Begin', []); -{$ENDIF} - { First get the file header, block 0. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, - aTI, - 0, - ffc_MarkDirty, - aFHRelMethod)); - try - { Create a new BLOB header. } - SegSize := ffc_BLOBHeaderSize; {!!.11} - aBLOBNr := aFI^.fiBLOBrscMgr.NewSegment(aFI, - aTI, - SegSize, {!!.11} - SegSize); {!!.11} - BLOBBlock := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - aBLOBNr, - OffsetInBlock, - aBlkRelMethod); - try - BLOBHeaderPtr := @BLOBBlock^[OffsetInBlock]; - {set up the new BLOB header} - with BLOBHeaderPtr^ do begin - bbhSignature := ffc_SigBLOBSegHeader; - bbhSegmentLen := (((sizeof(TffBLOBHeader) + pred(ffc_BLOBSegmentIncrement)) div - ffc_BLOBSegmentIncrement) * ffc_BLOBSegmentIncrement); - bbhBLOBLength := 0; - bbhSegCount := 0; - bbh1stLookupSeg.iLow := ffc_W32NoValue; {!!.11} - end; - {we've got one more BLOB} - inc(FileHeader^.bhfBLOBCount); - finally - aBlkRelMethod(BLOBBlock); - end; - finally - aFHRelMethod(PffBlock(FileHeader)); - end; -end; -{--------} -procedure FFTblAddBLOBLink(aFI : PffFileInfo; - aTI : PffTransInfo; - const aTableName : TffTableName; - const aTableBLOBNr : TffInt64; - var aBLOBNr : TffInt64); -var - FileHeader : PffBlockHeaderFile; - BLOBBlock : PffBlock; - BLOBBlockHdr : PffBlockHeaderBLOB absolute BLOBBlock; - SegSize : TffWord32; {!!.11} - OffsetInBlock : TffWord32; {!!.11} - BLOBHeaderPtr : PffBLOBHeader; - LinkLen, - NameLen : TffWord32; {!!.11} - aBlkRelMethod, - aFHRelMethod : TffReleaseMethod; -begin - { First get the file header, block 0. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, - aTI, - 0, - ffc_MarkDirty, - aFHRelMethod)); - try - { Create a new BLOB header. } - NameLen := succ(Length(aTableName)); - LinkLen := succ(Length(aTableName) + SizeOf(aTableBLOBNr)); - SegSize := ffc_BLOBHeaderSize + LinkLen; {!!.11} - aBLOBNr := aFI^.fiBLOBrscMgr.NewSegment(aFI, - aTI, - SegSize, {!!.11} - SegSize); {!!.11} - if (aBLOBNr.iLow <> ffc_W32NoValue) then begin - BLOBBlock := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - aBLOBNr, - OffsetInBlock, - aBlkRelMethod); - BLOBHeaderPtr := @BLOBBlock^[OffsetInBlock]; - end else begin - aBLOBNr.iLow := ffc_W32NoValue; - Exit; - end; - { Set up the new BLOB header. } - with BLOBHeaderPtr^ do begin - bbhSignature := ffc_SigBLOBSegHeader; - bbhBLOBLength := 0; - bbhSegCount := ffc_BLOBLink; - bbh1stLookupSeg.iLow := ffc_W32NoValue; - end; - { Write aTableName & the table's BLOB number after BLOBHeader. Note that - length of string is automatically stored as the first byte of the string. } - Move(aTableName, BLOBBlock^[(OffsetInBlock + sizeof(TffBLOBHeader))], - NameLen); - Move(aTableBLOBNr, BLOBBlock^[(OffsetInBlock + SizeOf(TffBLOBHeader) + - NameLen)], SizeOf(TffInt64)); - { We've got one more BLOB. } - inc(FileHeader.bhfBLOBCount); - aBlkRelMethod(BLOBBlock); - finally - aFHRelMethod(PffBlock(FileHeader)); - end; -end; -{--------} -procedure FFTblAddFileBLOB(aFI : PffFileInfo; - aTI : PffTransInfo; - const aFileName : TffFullFileName; - var aBLOBNr : TffInt64); -var - FileHeader : PffBlockHeaderFile; - BLOBBlock : PffBlock; - BLOBBlockHdr : PffBlockHeaderBLOB absolute BLOBBlock; - SegSize : TffWord32; {!!.11} - OffsetInBlock : TffWord32; {!!.11} - BLOBHeaderPtr : PffBLOBHeader; - FileNameLen : Integer; - aBlkRelMethod, - aFHRelMethod : TffReleaseMethod; -begin - {first get the file header, block 0} - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, - aTI, - 0, - ffc_MarkDirty, - aFHRelMethod)); - try - {create a new BLOB header} - FileNameLen := succ(Length(aFileName)); - SegSize := ffc_BLOBHeaderSize + FileNameLen; {!!.11} - aBLOBNr := aFI^.fiBLOBrscMgr.NewSegment(aFI, - aTI, - SegSize, {!!.11} - SegSize); {!!.11} - if (aBLOBNr.iLow <> ffc_W32NoValue) then begin - BLOBBlock := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - aBLOBNr, - OffsetInBlock, - aBlkRelMethod); - BLOBHeaderPtr := @BLOBBlock^[OffsetInBlock]; - end else begin - aBLOBNr.iLow := ffc_W32NoValue; - exit; - end; - {set up the new BLOB header} - with BLOBHeaderPtr^ do begin - bbhSignature := ffc_SigBLOBSegHeader; - bbhBLOBLength := 0; - bbhSegCount := ffc_FileBLOB; - bbh1stLookupSeg.iLow := ffc_W32NoValue; - end; - { Write aFileName after BLOBHeader. Note that length of string is - automatically stored as the first byte of the string. } - Move(aFileName, BLOBBlock^[(OffsetInBlock + sizeof(TffBLOBHeader))], FileNameLen); - {we've got one more BLOB} - inc(FileHeader.bhfBLOBCount); - aBlkRelMethod(BLOBBlock); - finally - aFHRelMethod(PffBlock(FileHeader)); - end; -end; -{--------} -procedure FFTblDeleteBLOBPrim(aFI : PffFileInfo; - aTI : PffTransInfo; - BLOBHeader : PffBLOBHeader); -var - OffsetInBlock : TffWord32; {!!.11} - LookupSegBlk : PffBlock; - LookupSegOfs, {!!.03} - TmpSegOfs : TffInt64; {!!.03} - LookupSegPtr : PffBLOBSegmentHeader; - LookupEntOfs : integer; - LookupEntPtr : PffBLOBLookupEntry; - EntryCount, {!!.03} - RemainEntries : Integer; {!!.03} - i : Integer; - aRelMethod : TffReleaseMethod; -begin -{$IFDEF BLOBTrace} {!!.11} - Logbt('FFTblDeleteBLOBPrim.Begin', []); -{$ENDIF} - - { Assumption: File header block is exclusively locked. } - - { Get the BLOB's first lookup segment. } - LookupSegOfs := BLOBHeader^.bbh1stLookupSeg; - -{Begin !!.03} - { BLOB truncated to length 0? } - if LookupSegOfs.iLow = ffc_W32NoValue then - Exit; -{End !!.03} - - LookupSegBlk := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - LookupSegOfs, - OffsetInBlock, - aRelMethod); - LookupSegPtr := @LookupSegBlk^[OffsetInBlock]; - LookupEntOfs := OffsetInBlock + sizeof(TffBLOBSegmentHeader); - - try - { Get the first lookup entry in the lookup segment. } - LookupEntPtr := @LookupSegBlk^[LookupEntOfs]; - - { Is this the only lookup segment? } - if LookupSegPtr^.bshNextSegment.iLow <> ffc_W32NoValue then - { No. Figure out number of lookup entries based on segment size. } - EntryCount := FFCalcMaxLookupEntries(LookupSegPtr) - else - { Yes. Number of lookup entries = number of content segments. } - EntryCount := BLOBHeader^.bbhSegCount; - - RemainEntries := BLOBHeader^.bbhSegCount; {!!.03} - - { Free each content segment. } - dec(RemainEntries, EntryCount); {!!.03} - for i := 1 to BLOBHeader^.bbhSegCount do begin - aFI^.fiBLOBrscMgr.DeleteSegment(aFI, aTI, LookupEntPtr^.bleSegmentOffset); - dec(EntryCount); - - { Need to move to another lookup segment? } - if ((EntryCount = 0) and (LookupSegPtr^.bshNextSegment.iLow <> ffc_W32NoValue)) then begin - {Yes. Get the location of the next lookup segment and delete the - existing lookup segment. } - TmpSegOfs := LookupSegPtr^.bshNextSegment; {!!.03} - aFI^.fiBLOBrscMgr.DeleteSegment(aFI, aTI, LookupSegOfs); - LookupSegOfs := TmpSegOfs; {!!.03} - - { Grab the next lookup segment. } - aRelMethod(LookupSegBlk); - LookupSegBlk := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - LookupSegOfs, OffsetInBlock, - aRelMethod); - LookupSegPtr := @LookupSegBlk^[OffsetInBlock]; - LookupEntOfs := OffsetInBlock + sizeof(TffBLOBSegmentHeader); - EntryCount := FFCalcMaxLookupEntries(LookupSegPtr); -{Begin !!.03} - if RemainEntries > EntryCount then - dec(RemainEntries, EntryCount) - else begin - EntryCount := RemainEntries; - RemainEntries := 0; - end; - end - else - { Grab the next lookup entry. } - LookupEntOfs := LookupEntOfs + sizeof(TffBLOBLookupEntry); - - LookupEntPtr := @LookupSegBlk^[LookupEntOfs]; -{End !!.03} - end; {for} - - { Delete the last lookup segment.} - aFI^.fiBLOBrscMgr.DeleteSegment(aFI, aTI, LookupSegOfs); - finally - aRelMethod(LookupSegBlk); - end; -end; -{--------} -procedure FFTblDeleteBLOB(aFI : PffFileInfo; - aTI : PffTransInfo; - const aBLOBNr : TffInt64); -var - FileHeader : PffBlockHeaderFile; - BLOBBlock : PffBlock; - BLOBBlockHdr : PffBlockHeaderBLOB absolute BLOBBlock; - BLOBHeader : PffBLOBHeader; - OffsetInBlock : TffWord32; {!!.11} - aBlkRelMethod, - aFHRelMethod : TffReleaseMethod; -begin -{$IFDEF BLOBTrace} {!!.11} - Logbt('FFTblDeleteBLOB.Begin', []); -{$ENDIF} - {first get the file header, block 0} - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_MarkDirty, - aFHRelMethod)); - try - {read and verify the BLOB header block} - BLOBBlock := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - aBLOBNr, - OffsetInBlock, - aBlkRelMethod); - BLOBHeader := @BLOBBlock^[OffsetInBlock]; -{Begin !!.01} - { Verify the BLOB has not been deleted. } - if (BLOBHeader^.bbhSignature = ffc_SigBLOBSegDeleted) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBLOBDeleted, - [aFI^.fiName^, aBLOBNr.iHigh, aBLOBNr.iLow]); -{End !!.01} - - try - FFTblDeleteBLOBPrim(aFI, aTI, BLOBHeader); - - { Delete the BLOB header} - aFI^.fiBLOBrscMgr.DeleteSegment(aFI, aTI, aBLOBNr); - - { We've got one less BLOB. } - dec(FileHeader.bhfBLOBCount); - finally - aBlkRelMethod(BLOBBlock); - end; - finally - aFHRelMethod(PffBlock(FileHeader)); - end; -end; -{--------} -function FFTblFreeBLOB(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64) - : Boolean; -var - BLOBBlock : PffBlock; - BLOBBlockHdr : PffBlockHeaderBLOB absolute BLOBBlock; - BLOBBlockNum : TffWord32; - BLOBHeader : PffBLOBHeader; - FileHeader : PffBlockHeaderFile; - OffsetInBlock: TffWord32; {!!.11} - TempI64 : TffInt64; - aBlkRelMethod, - aFHRelMethod : TffReleaseMethod; -begin -{$IFDEF BLOBTrace} {!!.11} - Logbt('FFTblFreeBLOB.Begin', []); - Logbt(' aBLOBNr = %d:%d', [aBLOBNr.iLow, aBLOBNr.iHigh]); -{$ENDIF} - { Assume we won't delete. } - Result := false; - FileHeader := nil; - - {now get the BLOB block} - ffShiftI64R(aBLOBNr, aFI^.fiLog2BlockSize, TempI64); - BLOBBlockNum := TempI64.iLow; - - { Read and verify the BLOB header block. } - BLOBBlock := ReadVfyBlobBlock2(aFI, - aTI, - ffc_ReadOnly, - aBLOBNr, - BLOBBlockNum, - OffsetInBlock, - aBlkRelMethod); - BLOBHeader := @BLOBBlock^[OffsetInBlock]; -{Begin !!.01} - { Verify the BLOB has not been deleted. } - if (BLOBHeader^.bbhSignature = ffc_SigBLOBSegDeleted) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBLOBDeleted, - [aFI^.fiName^, aBLOBNr.iHigh, aBLOBNr.iLow]); -{End !!.01} - - try - {don't bother doing anything if the BLOB's length > 0} - if (BLOBHeader^.bbhBLOBLength > 0) then - Exit; - - { We don't need to obtain exclusive locks on file header page or BLOB page - because the BLOB resource manager's DeleteSegment routine will do so. } - - { Delete the BLOB's header. } - aFI^.fiBLOBrscMgr.DeleteSegment(aFI, aTI, aBLOBNr); - - { One less BLOB. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_MarkDirty, - aFHRelMethod)); - dec(FileHeader.bhfBLOBCount); - - { We did delete. } - Result := true; - finally - if assigned(FileHeader) then - aFHRelMethod(PffBlock(FileHeader)); - aBlkRelMethod(BLOBBlock); - end; -end; -{--------} -function FFTblGetBLOBLength(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aLengthMethod : TffBLOBLinkGetLength; - var aFBError : TffResult) - : Longint; -var - BLOBBlock : PffBlock; - BLOBBlockHdr : PffBlockHeaderBLOB absolute BLOBBlock; - BLOBBlockNum : TffWord32; - BLOBHeader : PffBLOBHeader; - OffsetInBlock : TffWord32; {!!.11} - aRelMethod : TffReleaseMethod; -begin -{$IFDEF BLOBTrace} {!!.11} - Logbt('FFTblGetBLOBLength.Begin', []); - Logbt(' aBLOBNr = %d:%d', [aBLOBNr.iLow, aBLOBNr.iHigh]); -{$ENDIF} - aFBError := DBIERR_NONE; - { Read and verify the BLOB header block for this BLOB number. } - BLOBBlock := ReadVfyBlobBlock2(aFI, - aTI, - ffc_ReadOnly, - aBLOBNr, - BLOBBlockNum, - OffsetInBlock, - aRelMethod); - try - BLOBHeader := @BLOBBlock^[OffsetInBlock]; -{Begin !!.01} - { Verify the BLOB has not been deleted. } - if (BLOBHeader^.bbhSignature = ffc_SigBLOBSegDeleted) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBLOBDeleted, - [aFI^.fiName^, aBLOBNr.iHigh, aBLOBNr.iLow]); -{End !!.01} - { Verify this is a header segment. } - if (BLOBHeader^.bbhSignature <> ffc_SigBLOBSegHeader) then - FFRaiseException(EffServerException, ffStrResServer, fferrBadBLOBSeg, - [aFI^.fiName^, aBLOBNr.iLow, aBLOBNr.iHigh, - format(ffcBLOBSegExpected, - [ffcBLOBSegHeader, - char(BLOBHeader^.bbhSignature)])]); - { What kind of BLOB are we dealing with? } - case BLOBHeader^.bbhSegCount of - ffc_FileBLOB : { File BLOB } - aFBError := FileBLOBLength(BLOBHeader, Result); - ffc_BLOBLink : { BLOB link } - begin - Assert(assigned(aLengthMethod)); - aFBError := BLOBLinkGetLength(BLOBHeader, aLengthMethod, Result); - end; - else { Standard BLOB } - Result := BLOBHeader^.bbhBLOBLength; - end; - finally - aRelMethod(BLOBBlock); - end; -end; -{--------} -function FFTblGetFileNameBLOB(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - var aFileName : TffFullFileName ) - : Boolean; -var - BLOBBlock : PffBlock; - BLOBBlockHdr : PffBlockHeaderBLOB absolute BLOBBlock; - BLOBBlockNum : TffWord32; - BLOBHeader : PffBLOBHeader; - FileNameLen : Integer; - OffsetInBlock : TffWord32; {!!.11} - aRelMethod : TffReleaseMethod; -begin - {read and verify the BLOB header block for this BLOB number} - BLOBBlock := ReadVfyBlobBlock2(aFI, - aTI, - ffc_ReadOnly, - aBLOBNr, - BLOBBlockNum, - OffsetInBlock, - aRelMethod); - BLOBHeader := @BLOBBlock^[OffsetInBlock]; -{Begin !!.01} - { Verify the BLOB has not been deleted. } - if (BLOBHeader^.bbhSignature = ffc_SigBLOBSegDeleted) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBLOBDeleted, - [aFI^.fiName^, aBLOBNr.iHigh, aBLOBNr.iLow]); -{End !!.01} - Result := BLOBHeader^.bbhSegCount = ffc_FileBLOB; - if Result then begin - {get the length of the file name} - Move(BLOBBlock^[(OffsetInBlock + sizeof(TffBLOBHeader))], - FileNameLen, 1); - {move the file name to aFileName} - Move(BLOBBlock^[(OffsetInBlock + sizeof(TffBLOBHeader))], - aFileName, succ(FileNameLen)); - end; - aRelMethod(BLOBBlock); -end; -{--------} -function FFTblIsBLOBLink(aFI : PffFileInfo; {!!.11 - Start} - aTI : PffTransInfo; - aBLOBNr : TffInt64; - var aSrcTableName : TffTableName; - var aSrcTableBLOBNr : TffInt64) - : Boolean; -var - BLOBBlock : PffBlock; - BLOBHeader : PffBLOBHeader; - aHdRelMethod : TffReleaseMethod; - BLOBBLockNum : TffWord32; - OffsetInBlock : TffWord32; {!!.11} -begin - { Read and verify the BLOB header block for this BLOB number. } - BLOBBlock := ReadVfyBlobBlock2(aFI, - aTI, - ffc_ReadOnly, - aBLOBNr, - BLOBBlockNum, - OffsetInBlock, - aHdRelMethod); - try - BLOBHeader := @BLOBBlock^[OffsetInBlock]; - - Result := BLOBHeader^.bbhSegCount = ffc_BLOBLink; - - if (Result) then - BLOBLinkGetTableNameAndRefNr(BLOBBlock, - OffsetInBlock, - aSrcTableName, - aSrcTableBLOBNr); - finally - aHdRelMethod(BLOBBlock); - end; -end; -{--------} {!!.11 - End} -{Begin !!.03} -{--------} -procedure WriteToStream(const aMsg : string; aStream : TStream); -begin - aStream.Write(aMsg[1], Length(aMsg)); -end; -{--------} -procedure FFTblListBLOBSegments(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aStream : TStream); -var - BLOBBlock : PffBlock; - BLOBBlockHdr : PffBlockHeaderBLOB absolute BLOBBlock; - BLOBBlockNum : TffWord32; - BLOBHeader : PffBLOBHeader; - EntryCount : Integer; - LookupBlock, ContentBlock : TffWord32; {!!.11} - LookupEntry : PffBLOBLookupEntry; - ContentEntry : PffBLOBSegmentHeader; {!!.11} - LookupSegBlk, ContentSegBlk : PffBlock; {!!.11} - LookupSegPtr : PffBLOBSegmentHeader; - NextSeg : TffInt64; - OffsetInBlock, ContentOffsetInBlock : TffWord32; {!!.11} - aLkpRelMethod, - aContRelMethod, {!!.11} - aHdRelMethod : TffReleaseMethod; -begin - LookupSegBlk := nil; - - { Read and verify the BLOB header block for this BLOB number. } - BLOBBlock := ReadVfyBlobBlock2(aFI, - aTI, - ffc_ReadOnly, - aBLOBNr, - BLOBBlockNum, - OffsetInBlock, - aHdRelMethod); - BLOBHeader := @BLOBBlock^[OffsetInBlock]; - - { Verify the BLOB has not been deleted. } - if (BLOBHeader^.bbhSignature = ffc_SigBLOBSegDeleted) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBLOBDeleted, - [aFI^.fiName^, aBLOBNr.iHigh, aBLOBNr.iLow]); - - { BLOB truncated to length zero? } - if BLOBHeader^.bbh1stLookupSeg.iLow = ffc_W32NoValue then begin - WriteToStream('BLOB has been truncated to length zero.', aStream); - WriteToStream(#0, aStream); - Exit; - end; - - try - { Are we dealing with a file BLOB or a BLOB link? } - case BLOBHeader^.bbhSegCount of - ffc_FileBLOB : { file BLOB } - begin - WriteToStream('This is a file BLOB.', aStream); - Exit; - end; - ffc_BLOBLink : { BLOB link } - begin - WriteToStream('This is a BLOB link.', aStream); - Exit; - end; - end; { case } - - { Get the lookup segment block and set up offset for 1st lookup entry. } - LookupSegBlk := ReadVfyBlobBlock2(aFI, aTI, ffc_ReadOnly, - BLOBHeader^.bbh1stLookupSeg, - LookupBlock, OffsetInBlock, - aLkpRelMethod); - LookupSegPtr := @LookupSegBlk^[OffsetInBlock]; - OffsetInBlock := OffsetInBlock + sizeof(TffBLOBSegmentHeader); - - { Walk through the BLOB segment linked list. } - WriteToStream(Format('Segment list for BLOB %d:%d '+ #13#10, - [aBLOBNr.iHigh, aBLOBNr.iLow]), aStream); - EntryCount := 0; - while True do begin - inc(EntryCount); - LookupEntry := @LookupSegBlk^[OffsetInBlock]; -{Begin !!.11} - { Verify the segment is valid. } - ContentSegBlk := ReadVfyBlobBlock2(aFI, aTI, ffc_ReadOnly, - LookupEntry^.bleSegmentOffset, - ContentBlock, ContentOffsetInBlock, - aContRelMethod); - - ContentEntry := @ContentSegBlk^[ContentOffsetInBlock]; - if PffBlockHeaderBLOB(ContentSegBlk)^.bhbSignature <> ffc_SigBLOBBlock then - raise Exception.CreateFmt - ('Invalid BLOB block signature, block: %d', [ContentBlock]) - else if ContentEntry^.bshSignature <> ffc_SigBLOBSegContent then - raise Exception.CreateFmt - ('Invalid signature for content segment, offset: %d,%d, signature: %s', - [LookupEntry^.bleSegmentOffset.iHigh, - LookupEntry^.bleSegmentOffset.iLow, - char(ContentEntry^.bshSignature)]) - else begin - - WriteToStream(Format('Segment %d, %d:%d, Len %d' + #13#10, - [EntryCount, LookupEntry^.bleSegmentOffset.iHigh, - LookupEntry^.bleSegmentOffset.iLow, - LookupEntry^.bleContentLength]), aStream); - - {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); - LookupSegBlk := ReadVfyBlobBlock2(aFI, aTI, ffc_ReadOnly, - NextSeg, {!!.11} - LookupBlock, OffsetInBlock, - aLkpRelMethod); - LookupSegPtr := @LookupSegBlk^[OffsetInBlock]; - OffsetInBlock := OffsetInBlock + sizeof(TffBLOBSegmentHeader); - EntryCount := 0; - end - else - break; - end else - OffsetInBlock := OffsetInBlock + sizeof(TffBLOBLookupEntry); - end; -{End !!.11} - end; {while} - finally - if assigned(LookupSegBlk) then - aLkpRelMethod(LookupSegBlk); - aHdRelMethod(BLOBBlock); - WriteToStream(#0, aStream); - end; -end; -{ End !!.03} -{Begin !!.11} -{--------} -function FFTblRebuildLookupSegments(aFI : PffFileInfo; - aTI : PffTransInfo; - aNewBLOBSize : TffWord32; - aOldBLOBSize : TffWord32; - const aBLOBNr : TffInt64) - : TffInt64; -{This function takes an existing lookup segment chain & grows it to - accomodate a larger BLOB. } -var - NewBLOBBlock : PffBlock; - NewLookupHeader : PffBLOBSegmentHeader; - OldBLOBBlock : PffBlock; - OldLookupHeader : PffBLOBSegmentHeader; - OldLookupEntry : PffBLOBLookupEntry; - OldLookupBlk : PffBlock; - OldLookupOfs : TffWord32; - OldBLOBHeader : PffBLOBHeader; - NewSegCount : TffWord32; - OldSegCount : Longint; - SegBytesUsed : TffWord32; - EntriesToGo : Longint; - MaxEntries : Longint; - NewOfsInBlock : TffWord32; - OldOfsInBlock : TffWord32; - EntInOldSeg : Longint; - EntInNewSeg : Longint; - CurrentCount : Longint; - OldHeaderOfs : TffInt64; - TempI64 : TffInt64; - aRelMethod : TffReleaseMethod; - aRelList : TffPointerList; - SegSize : TffWord32; -begin - { We use the following list to track the RAM pages we've accessed and - the release method associated with each RAM page. At the end of this - routine, we will call the release method for each RAM page. } - aRelList := TffPointerList.Create; - - try - { Get the old lookup header before we replace it with a new one. } - OldBLOBBlock := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - aBLOBNr, OldOfsInBlock, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(OldBLOBBlock, TffInt64(aRelMethod))); - OldBLOBHeader := PffBLOBHeader(@OldBLOBBlock^[OldOfsInBlock]); - OldHeaderOfs := OldBLOBHeader^.bbh1stLookupSeg; - - { Determine number of segments needed to hold the entire BLOB. } - NewSegCount := CalcBLOBSegNumber(aNewBLOBSize, aFI^.fiBlockSize, SegBytesUsed); - - { Can the number of lookup entries required for the number of segments - fit within one lookup segment? } - if ((NewSegCount * ffc_BLOBLookupEntrySize) <= - (aFI^.fiMaxSegSize - ffc_BLOBSegmentHeaderSize)) then begin - { Yes. Create a new lookup segment. } - SegSize := (NewSegCount * ffc_BLOBLookupEntrySize) + - ffc_BLOBSegmentHeaderSize; - Result := aFI^.fiBLOBrscMgr.NewSegment(aFI, aTI, SegSize, SegSize); - NewBLOBBlock := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, Result, - NewOfsInBlock, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(NewBLOBBlock, TffInt64(aRelMethod))); - NewLookupHeader := @NewBLOBBlock^[NewOfsInBlock]; - - { Setup our new lookup header. } - with NewLookupHeader^ do begin - bshSignature := ffc_SigBLOBSegLookup; - bshParentBLOB := aBLOBNr; - bshNextSegment.iLow := ffc_W32NoValue; - end; - end else begin - { No. We need a chain of lookup segments. } - EntriesToGo := NewSegCount; - MaxEntries := (aFI^.fiMaxSegSize - ffc_BLOBSegmentHeaderSize) div - ffc_BLOBLookupEntrySize; - SegSize := (MaxEntries * ffc_BLOBLookupEntrySize) + - ffc_BLOBSegmentHeaderSize; - Result := aFI^.fiBLOBrscMgr.NewSegment(aFI, aTI, SegSize, SegSize); - dec(EntriesToGo, MaxEntries); - NewBLOBBlock := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - Result, NewOfsInBlock, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(NewBLOBBlock, TffInt64(aRelMethod))); - NewLookupHeader := @NewBLOBBlock^[NewOfsInBlock]; - NewLookupHeader^.bshSignature := ffc_SigBLOBSegHeader; - NewLookupHeader^.bshParentBLOB := aBLOBNr; - while EntriesToGo > 0 do begin - if EntriesToGo > MaxEntries then begin - { We need this lookup segment & at least one more. } - SegSize := (MaxEntries * ffc_BLOBLookupEntrySize) + - ffc_BLOBSegmentHeaderSize; - NewLookupHeader^.bshNextSegment := aFI^.fiBLOBrscMgr.NewSegment - (aFI, aTI, SegSize, SegSize); - dec(EntriesToGo, MaxEntries); - NewBLOBBlock := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - NewLookupHeader^.bshNextSegment, - NewOfsInBlock, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(NewBLOBBlock, TffInt64(aRelMethod))); - end else begin - { This is the last lookup segment needed. } - SegSize := (EntriesToGo * ffc_BLOBLookupEntrySize) + - ffc_BLOBSegmentHeaderSize; - NewLookupHeader^.bshNextSegment := aFI^.fiBLOBrscMgr.NewSegment - (aFI, aTI, SegSize, SegSize); - dec(EntriesToGo, EntriesToGo); - NewBLOBBlock := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - NewLookupHeader^.bshNextSegment, - NewOfsInBlock, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(NewBLOBBlock, TffInt64(aRelMethod))); - end; {if..else} - - { Initialize the segment. } - NewLookupHeader := @NewBLOBBlock^[NewOfsInBlock]; - NewLookupHeader^.bshSignature := ffc_SigBLOBSegHeader; - NewLookupHeader^.bshParentBLOB := aBLOBNr; - NewLookupHeader^.bshNextSegment.iLow := ffc_W32NoValue; - - end; {while} - {Reset the new lookup segment to the 1st one in the chain.} - NewBLOBBlock := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - Result, - NewOfsInBlock, aRelMethod); - NewLookupHeader := @NewBLOBBlock^[NewOfsInBlock]; - - end; {if..else} - - { Now that we have our newly-sized lookup header(s) and entries, we - need to copy the old entries into the new header. } - if aOldBLOBSize = 0 then - OldSegCount := 0 - else - OldSegCount := CalcBLOBSegNumber(aOldBLOBSize, aFI^.fiBlockSize, - SegBytesUsed); - - if OldSegCount <> 0 then begin - OldLookupBlk := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - OldBLOBHeader^.bbh1stLookupSeg, - OldLookupOfs, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(OldLookupBlk, TffInt64(aRelMethod))); - OldLookupHeader := @OldLookupBlk^[OldLookupOfs]; - OldLookupOfs := OldLookupOfs + sizeof(TffBLOBSegmentHeader); - { Point to the 1st lookup entry. } - OldLookupEntry := PffBLOBLookupEntry(@OldLookupBlk^[OldLookupOfs]); - - { Get the block offset to where the first new lookup entry goes. } - NewBLOBBlock := ReadBLOBBlock(aFI, aTI, Result, NewOfsInBlock, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(NewBLOBBlock, TffInt64(aRelMethod))); - NewOfsInBlock := NewOfsInBlock + sizeof(TffBLOBSegmentHeader); - - { Is the old lookup segment followed by another lookup segment? } - if OldLookupHeader^.bshNextSegment.iLow <> ffc_W32NoValue then - { Yes. It must have the maximum number of lookup entries so figure out - how many that is. } - EntInOldSeg := FFCalcMaxLookupEntries(OldLookupHeader) - else - { No. The number of lookup entries equals the number of segments in - the BLOB. } - EntInOldSeg := OldSegCount; - - { Figure out the maximum number of entries for the new lookup segment. } - EntInNewSeg := FFCalcMaxLookupEntries(NewLookupHeader); - - CurrentCount := 0; - while CurrentCount < OldSegCount do begin - { Move over all lookup entries from the old lookup segment to the new - lookup segment. } - Move(OldLookupEntry^, NewBLOBBlock^[NewOfsInBlock], - EntInOldSeg * sizeof(TffBLOBLookupEntry)); - inc(CurrentCount, EntInOldSeg); - dec(EntInNewSeg, EntInOldSeg); - - { Save a pointer to the beginning of our old lookup segment. - We will need it to delete the lookup segment later. } - TempI64 := OldHeaderOfs; - - { Is there a lookup segment after this one? } - if OldLookupHeader^.bshNextSegment.iLow <> ffc_W32NoValue then begin - { Yes. Move to it. } - OldHeaderOfs := OldLookupHeader^.bshNextSegment; - OldBLOBBlock := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - OldHeaderOfs, OldLookupOfs, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(OldBLOBBlock, TffInt64(aRelMethod))); - OldLookupBlk := - ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - OldLookupHeader^.bshNextSegment, - OldLookupOfs, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(OldLookupBlk, - TffInt64(aRelMethod))); - OldLookupHeader := @OldLookupBlk^[OldLookupOfs]; - inc(OldLookupOfs, sizeof(TffBLOBSegmentHeader)); - OldLookupEntry := PffBLOBLookupEntry(@OldBLOBBlock^[OldLookupOfs]); - - { Since the lookup segment was followed by another lookup segment, - we know this is a max-size segment full of entries. } - EntInOldSeg := FFCalcMaxLookupEntries(OldLookupHeader); - end; - - { Delete the old lookup segment now that we have copied all its - entries. } - aFI^.fiBLOBrscMgr.DeleteSegment(aFI, aTI, TempI64); - - { Check if we've filled up our current (target) header} - if (EntInNewSeg = 0) and - (NewLookupHeader^.bshNextSegment.iLow <> ffc_W32NoValue) then begin - NewBLOBBlock := ReadBlobBlock(aFI, - aTI, - NewLookupHeader^.bshNextSegment, - NewOfsInBlock, - aRelMethod); - - aRelList.Append(FFAllocReleaseInfo(NewBLOBBlock, TffInt64(aRelMethod))); - NewLookupHeader := @NewBLOBBlock^[NewOfsInBlock]; - NewOfsInBlock := - NewOfsInBlock + sizeof(TffBLOBSegmentHeader); - EntInNewSeg := FFCalcMaxLookupEntries(NewLookupHeader); - end; - end; {while} - end; {if} - OldBLOBHeader^.bbh1stLookupSeg := Result; - finally - for CurrentCount := 0 to pred(aRelList.Count) do begin - FFDeallocReleaseInfo(aRelList[CurrentCount]); - end; - aRelList.Free; - end; -end; -{====================================================================} - -{===TffBaseBLOBEngine================================================} -class function TffBaseBLOBEngine.GetEngine(aFI : PffFileInfo) : TffBaseBLOBEngine; -begin - if aFI.fiFFVersion <= ffVersion2_10 then - Result := FF210BLOBEngine - else - Result := FFBLOBEngine; -end; -{====================================================================} - -{===TffBLOBEngine====================================================} -procedure TffBLOBEngine.Read(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aOffset : TffWord32; - aLen : TffWord32; - aReadMethod : TffBLOBLinkRead; - var aBLOB; - var aBytesRead : TffWord32; - var aFBError : TffResult); -var - aCntRelMethod, - aLkpRelMethod, - aHdRelMethod : TffReleaseMethod; - BLOBAsBytes : PffBLOBArray; - BLOBBlock : PffBlock; - BLOBBlockHdr : PffBlockHeaderBLOB absolute BLOBBlock; - BLOBBlockNum : TffWord32; - BLOBHeader : PffBLOBHeader; - BytesToCopy : TffWord32; - ContentBlock, - LookupSegOfs : TffWord32; - ContentSegBlk : PffBlock; - ContentSegOfs : TffInt64; - DestOffset : TffWord32; - MaxLookupEntries : Integer; - LookupBlock : TffWord32; - LookupEntry : PffBLOBLookupEntry; - LookupSegBlk : PffBlock; - LookupSegPtr : PffBLOBSegmentHeader; - OffsetInBlock : TffWord32; - StartBytesUsed, - BLOBPos : TffWord32; - CurrLookupEntry : Integer; -{$IFDEF BLOBTrace} - LookupSegCount : Integer; -{$ENDIF} - NextSeg : TffInt64; {!!.11} -begin -{$IFDEF BLOBTrace} - Logbt('FFTblReadBLOB.Begin', []); - Logbt(' aBLOBNr = %d:%d', [aBLOBNr.iLow, aBLOBNr.iHigh]); - Logbt(' aOffset = %d', [aOffset]); - Logbt(' aLen = %d', [aLen]); - try -{$ENDIF} - - BLOBAsBytes := @aBLOB; - ContentSegBlk := nil; - LookupSegBlk := nil; - DestOffset := 0; - - aFBError := 0; - - {Exit if aLen = 0} - if aLen = 0 then - Exit; - - { Read and verify the BLOB header block for this BLOB number. } - BLOBBlock := ReadVfyBlobBlock2(aFI, - aTI, - ffc_ReadOnly, - aBLOBNr, - BLOBBlockNum, - OffsetInBlock, - aHdRelMethod); - BLOBHeader := @BLOBBlock^[OffsetInBlock]; - {$IFDEF BLOBTrace} - Logbt(' BLOB.Length: %d, 1st lookup segment: %d:%d', - [BLOBHeader^.bbhBLOBLength, - BLOBHeader^.bbh1stLookupSeg.iLow, - BLOBHeader^.bbh1stLookupSeg.iHigh]); - {$ENDIF} - - { Verify the BLOB has not been deleted. } - if (BLOBHeader^.bbhSignature = ffc_SigBLOBSegDeleted) then - FFRaiseException(EffServerException, - ffStrResServer, - fferrBLOBDeleted, - [aFI^.fiName^, - aBLOBNr.iHigh, - aBLOBNr.iLow]); - - try - { Are we dealing with a file BLOB or a BLOB link? } - case BLOBHeader^.bbhSegCount of - ffc_FileBLOB : { file BLOB } - begin - aFBError := FileBLOBRead(aFI, - aTI, - aBLOBNr, - aOffset, - aLen, - aBLOB, - aBytesRead); - Exit; - end; - ffc_BLOBLink : { BLOB link } - begin - aFBError := BLOBLinkRead(aFI, - aTI, - aBLOBNr, - aOffset, - aLen, - aReadMethod, - aBLOB, - aBytesRead); - Exit; - end; - end; { case } - - { Make sure that the offset is within BLOB. } - if (FFCmpDW(aOffset, BLOBHeader^.bbhBLOBLength) >= 0) then begin - aBytesRead := 0; - Exit; - end; - { Get the lookup segment block and set up offset for 1st lookup entry. } - LookupSegBlk := ReadVfyBlobBlock2(aFI, - aTI, - ffc_ReadOnly, - BLOBHeader^.bbh1stLookupSeg, - LookupBlock, - LookupSegOfs, - aLkpRelMethod); - LookupSegPtr := @LookupSegBlk^[LookupSegOfs]; - LookupSegOfs := LookupSegOfs + ffc_BLOBSegmentHeaderSize; - - { Calculate the number of bytes we can (= "are going to") read. } - aBytesRead := ffMinDW(aLen, BLOBHeader^.bbhBLOBLength - aOffset); - - { How many entries are in the current lookup segment? } - MaxLookupEntries := FFCalcMaxLookupEntries(LookupSegPtr); - CurrLookupEntry := 1; - {$IFDEF BLOBTrace} - LookupSegCount := 1; - Logbt(' Lookup segment - Max entries: %d', - [MaxLookupEntries]); - {$ENDIF} - - { Position to where we are to start reading. } - BLOBPos := 0; - StartBytesUsed := 0; - while (BLOBPos < aOffset) do begin - LookupEntry := @LookupSegBlk^[LookupSegOfs]; - {$IFDEF BLOBTrace} - Logbt(' Lookup entry %d points to ' + - 'segment %d:%d with %d bytes', - [CurrLookupEntry, - LookupEntry^.bleSegmentOffset.iHigh, - LookupEntry^.bleSegmentOffset.iLow, - LookupEntry^.bleContentLength]); - {$ENDIF} - { Does this entry point to the segment where we should start - copying data? } - if ((BLOBPos + LookupEntry^.bleContentLength) >= aOffset) then begin - { Yes. We found the starting point. } - ContentSegOfs := LookupEntry^.bleSegmentOffset; - StartBytesUsed := aOffset - BLOBPos; - { NOTE: We will start reading from this segment, so we don't - want to move past it. } - Break; - end else begin - { Nope. Update and keep moving. } - BLOBPos := BLOBPos + LookupEntry^.bleContentLength; - LookupSegOfs := LookupSegOfs + ffc_BLOBLookupEntrySize; - CurrLookupEntry := CurrLookupEntry + 1; - end; - - { Have we reached the end of this lookup segment? } - if (CurrLookupEntry > MaxLookupEntries) then begin - { Get the lookup segment block and set up offset for 1st lookup entry. } - NextSeg := LookupSegPtr^.bshNextSegment; {!!.11} - aLkpRelMethod(LookupSegBlk); - LookupSegBlk := ReadVfyBlobBlock2(aFI, - aTI, - ffc_ReadOnly, - NextSeg, {!!.11} - LookupBlock, - LookupSegOfs, - aLkpRelMethod); - LookupSegPtr := @LookupSegBlk^[LookupSegOfs]; - LookupSegOfs := LookupSegOfs + ffc_BLOBSegmentHeaderSize; - - { How many entries are in the current lookup segment? } - MaxLookupEntries := FFCalcMaxLookupEntries(LookupSegPtr); - CurrLookupEntry := 1; - {$IFDEF BLOBTrace} - LookupSegCount := LookupSegCount + 1; - Logbt(' Moving to lookup segment %d', - [LookupSegCount]); - Logbt(' Lookup segment - Max entries: %d', - [MaxLookupEntries]); - {$ENDIF} - end; - end; - - { Read what we need. } - BLOBPos := 0; - while (BLOBPos < aBytesRead) do begin - { Read the BLOB content segment. } - if (ContentSegBlk <> nil) then - aCntRelMethod(ContentSegBlk); - LookupEntry := @LookupSegBlk^[LookupSegOfs]; - {$IFDEF BLOBTrace} - Logbt(' Lookup entry %d points to segment %d:%d with %d bytes', - [CurrLookupEntry, - LookupEntry^.bleSegmentOffset.iHigh, - LookupEntry^.bleSegmentOffset.iLow, - LookupEntry^.bleContentLength]); - {$ENDIF} - ContentSegBlk := ReadVfyBlobBlock2(aFI, - aTI, - ffc_ReadOnly, - LookupEntry^.bleSegmentOffset, - ContentBlock, - OffsetInBlock, - aCntRelMethod); - OffsetInBlock := OffsetInBlock + ffc_BLOBSegmentHeaderSize; - - if (StartBytesUsed > 0) then begin - { This is the first segment we're reading from. This will - normally be in the middle of a segment. } - BytesToCopy := LookupEntry^.bleContentLength - StartBytesUsed; - OffsetInBlock := OffsetInBlock + StartBytesUsed; - end else begin - { copying from middle segments } - BytesToCopy := LookupEntry^.bleContentLength; - end; - - BytesToCopy := ffMinL(BytesToCopy, (aBytesRead - BLOBPos)); - Move(ContentSegBlk^[OffsetInBlock], - BLOBAsBytes^[DestOffset], - BytesToCopy); - BLOBPos := BLOBPos + BytesToCopy; - DestOffset := DestOffset + BytesToCopy; - {$IFDEF BLOBTrace} - Logbt(' Read %d bytes from lookup segment %d, entry %d', - [BytesToCopy, LookupSegCount, CurrLookupEntry]); - {$ENDIF} - CurrLookupEntry := CurrLookupEntry + 1; - StartBytesUsed := 0; - - { Have we reached the end of this lookup segment? } - if ((BLOBPos < aBytesRead) and - (CurrLookupEntry > MaxLookupEntries)) then begin - NextSeg := LookupSegPtr^.bshNextSegment; {!!.11} - aLkpRelMethod(LookupSegBlk); - { Get the lookup segment block and set up offset for 1st - lookup entry. } - LookupSegBlk := ReadVfyBlobBlock2(aFI, - aTI, - ffc_ReadOnly, - NextSeg, {!!.11} - LookupBlock, - LookupSegOfs, - aLkpRelMethod); - LookupSegPtr := @LookupSegBlk^[LookupSegOfs]; - LookupSegOfs := LookupSegOfs + ffc_BLOBSegmentHeaderSize; - - { How many entries are in the current lookup segment? } - MaxLookupEntries := FFCalcMaxLookupEntries(LookupSegPtr); - CurrLookupEntry := 1; - {$IFDEF BLOBTrace} - LookupSegCount := LookupSegCount + 1; - Logbt(' Moving to lookup segment %d', - [LookupSegCount]); - Logbt(' Lookup segment - Max entries: %d', - [MaxLookupEntries]); - {$ENDIF} - end else begin - LookupSegOfs := LookupSegOfs + ffc_BLOBLookupEntrySize; - end; - end; {while} - finally - if assigned(ContentSegBlk) then - aCntRelMethod(ContentSegBlk); - if assigned(LookupSegBlk) then - aLkpRelMethod(LookupSegBlk); - aHdRelMethod(BLOBBlock); - end; -{$IFDEF BLOBTrace} - except - Logbt('*** FFTblReadBLOB Exception ***', []); - raise; - end -{$ENDIF} -end; -{--------} -function TffBLOBEngine.IsEmptyLookupEntry(Entry : PffBLOBLookupEntry) : Boolean; -{ Revised !!.13} -const - ciEmptyVal1 = 808464432; - { This is because lookup segments prior to 2.13 were 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 = ffc_W32NoValue) or - ((Entry^.bleSegmentOffset.iLow = 0) and - (Entry^.bleSegmentOffset.iHigh = 0)) or - ((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 TffBLOBEngine.Truncate(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aLen : TffWord32); -{Updated !!.12} -var - aRelList : TffPointerList; -// aLkpRelMethod, {Deleted !!.13} - aRelMethod : TffReleaseMethod; - NextLookupSeg : TffInt64; - ContOffset, {!!.13} - BLOBPos, - CurrLookupEntry, - LookupBlock, - MaxLookupEntries, - OffsetInBlock, - StartBytesUsed : TffWord32; - NewSegCount : Integer; - BLOBBlock : PffBlock; - ContentSegBlk, {!!.13} - LookupSegBlk : PffBlock; - BLOBBlockHdr : PffBlockHeaderBLOB absolute BLOBBlock; - BLOBHeader : PffBLOBHeader; -{Begin !!.13} - ContentSegOfs : TffInt64; - ContentSegPtr, -{End !!.13} - LookupSegPtr : PffBLOBSegmentHeader; - LookupEntry : PffBLOBLookupEntry; -{$IFDEF BLOBTrace} - LookupSegCount : Integer; -{$ENDIF} -begin -{$IFDEF BLOBTrace} - Logbt('Entering FFTblTruncateBLOB', []); - Logbt(' aBLOBNr = %d:%d', [aBLOBNr.iLow, aBLOBNr.iHigh]); - Logbt(' aLen = %d', [aLen]); - LookupSegCount := 1; -{$ENDIF} - -// aLkpRelMethod := nil; {Deleted !!.13} - - { We use the following list to track the RAM pages we've accessed and - the release method associated with each RAM page. At the end of this - routine, we will call the release method for each RAM page. } - aRelList := TffPointerList.Create; - - try - { Read and verify the BLOB header block for this BLOB number. } - BLOBBlock := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - aBLOBNr, - OffsetInBlock, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(BLOBBlock,TffInt64(aRelMethod))); - - BLOBHeader := @BLOBBlock^[OffsetInBlock]; - - { Check if we're trying to truncate a zero-length BLOB or to the - BLOB's current length. } - if (BLOBHeader^.bbhBLOBLength = aLen) then - Exit; - - { Verify the BLOB has not been deleted. } - if (BLOBHeader^.bbhSignature = ffc_SigBLOBSegDeleted) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBLOBDeleted, - [aFI^.fiName^, aBLOBNr.iHigh, aBLOBNr.iLow]); - - { Verify this is a header segment. } - if (BLOBHeader^.bbhSignature <> ffc_SigBLOBSegHeader) then - FFRaiseException(EffServerException, - ffStrResServer, - fferrBadBLOBSeg, - [aFI^.fiName^, - aBLOBNr.iLow, - aBLOBNr.iHigh, - Format(ffcBLOBSegExpected, - [ffcBLOBSegHeader, - Char(BLOBHeader^.bbhSignature)])]); - - { We can't write to a file BLOB. } - if (BLOBHeader^.bbhSegCount = -1) then - FFRaiseException(EffServerException, - ffStrResServer, - fferrFileBLOBWrite, - [aFI^.fiName^, - aBLOBNr.iLow, - aBLOBNr.iHigh]); - - { Make sure the truncated length <= current BLOB length. } - if (aLen > BLOBHeader^.bbhBLOBLength) then - FFRaiseException(EffServerException, - ffStrResServer, - fferrLenMismatch, - [aFI^.fiName^, - aBLOBNr.iLow, - aBLOBNr.iHigh, - aLen, - BLOBHeader^.bbhBLOBLength]); - - { If the new length is greater than 0, we will lop off some - content segments. The content segment that becomes the last - content segment must be updated. } - NewSegCount := 0; - if (aLen > 0) then begin - { Grab the first lookup segment. } - NextLookupSeg := BLOBHeader^.bbh1stLookupSeg; - LookupSegBlk := ReadVfyBlobBlock2(aFI, - aTI, - ffc_MarkDirty, {!!.13} - NextLookupSeg, - LookupBlock, - OffsetInBlock, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(LookupSegBlk,TffInt64(aRelMethod))); - LookupSegPtr := PffBLOBSegmentHeader(@LookupSegBlk^[OffsetInBlock]); - MaxLookupEntries := FFCalcMaxLookupEntries(LookupSegPtr); - - OffsetInBlock := OffsetInBlock + - ffc_BLOBSegmentHeaderSize; - CurrLookupEntry := 1; - - { Position to where we are to start truncating. } - BLOBPos := 0; - StartBytesUsed := 0; - while (BLOBPos < aLen) do begin - NewSegCount := NewSegCount + 1; - LookupEntry := @LookupSegBlk^[OffsetInBlock]; - {$IFDEF BLOBTrace} - Logbt(' Lookup entry %d points to a segment with %d bytes', - [CurrLookupEntry, - LookupEntry^.bleContentLength]); - {$ENDIF} - - if ((BLOBPos + LookupEntry^.bleContentLength) >= aLen) then begin {!!.13} - { We found the starting point. } - StartBytesUsed := aLen - BLOBPos; - Break; - end else begin - BLOBPos := BLOBPos + LookupEntry^.bleContentLength; - CurrLookupEntry := CurrLookupEntry + 1; - end; - - { Have we reached the end of this lookup segment? } - if ((BLOBPos < aLen) and - (CurrLookupEntry > MaxLookupEntries)) then begin - { Get the lookup segment block and set up offset for 1st - lookup entry. } - NextLookupSeg := LookupSegPtr^.bshNextSegment; -// if Assigned(aLkpRelMethod) then {Deleted !!.13} -// aLkpRelMethod(LookupSegBlk); {Deleted !!.13} - LookupSegBlk := ReadVfyBlobBlock2(aFI, - aTI, - ffc_MarkDirty, {!!.13} - NextLookupSeg, - LookupBlock, - OffsetInBlock, - aRelMethod); {!!.13} - aRelList.Append(FFAllocReleaseInfo(LookupSegBlk,TffInt64(aRelMethod))); {!!.13} - LookupSegPtr := @LookupSegBlk^[OffsetInBlock]; - OffsetInBlock := OffsetInBlock + ffc_BLOBSegmentHeaderSize; - - { How many entries are in the current lookup segment? } - MaxLookupEntries := FFCalcMaxLookupEntries(LookupSegPtr); - CurrLookupEntry := 1; - {$IFDEF BLOBTrace} - LookupSegCount := LookupSegCount + 1; - Logbt(' Moving to lookup segment %d', - [LookupSegCount]); - Logbt(' Lookup segment - Max entries: %d', - [MaxLookupEntries]); - {$ENDIF} - end - else - OffsetInBlock := OffsetInBlock + ffc_BLOBLookupEntrySize; - end; { while } - - { We should now be positioned on the last lookup entry to be retained - by the truncation. Update the length of its content segment. } - LookupEntry := @LookupSegBlk^[OffsetInBlock]; - BLOBPos := BLOBPos + LookupEntry^.bleContentLength; - LookupEntry^.bleContentLength := StartBytesUsed; - -{Begin !!.13} - { Update the content segment's NextSegment pointer. } - ContentSegOfs := LookupEntry^.bleSegmentOffset; - ContentSegBlk := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - ContentSegOfs, - ContOffset, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(ContentSegBlk,TffInt64(aRelMethod))); {!!.13} - ContentSegPtr := @ContentSegBlk^[ContOffset]; - ContentSegPtr^.bshNextSegment.iLow := ffc_W32NoValue; -{End !!.13} - - { Delete the content & lookup segments that are no longer needed. - First, obtain the number of extraneous lookup entries in the - current lookup segment. } - while (BLOBPos < BLOBHeader^.bbhBLOBLength) do begin - CurrLookupEntry := CurrLookupEntry + 1; - OffsetInBlock := OffsetInBlock + ffc_BLOBLookupEntrySize; - LookupEntry := @LookupSegBlk^[OffsetInBlock]; - { Have we reached the end of this lookup segment? } - if (CurrLookupEntry > MaxLookupEntries) then begin - if LookupSegPtr^.bshNextSegment.iLow = ffc_W32NoValue then - Break - else begin - { Get the lookup segment block and set up offset for 1st - lookup entry. } - NextLookupSeg := LookupSegPtr^.bshNextSegment; -// if Assigned(aLkpRelMethod) then {Deleted !!.13} -// aLkpRelMethod(LookupSegBlk); {Deleted !!.13} - LookupSegBlk := ReadVfyBlobBlock2(aFI, - aTI, - ffc_MarkDirty, - NextLookupSeg, - LookupBlock, - OffsetInBlock, - aRelMethod); {!!.13} - aRelList.Append(FFAllocReleaseInfo(LookupSegBlk,TffInt64(aRelMethod))); {!!.13} - LookupSegPtr^.bshNextSegment.iLow := ffc_W32NoValue; - LookupSegPtr := @LookupSegBlk^[OffsetInBlock]; - { Move ahead to first lookup entry. } - OffsetInBlock := OffSetInBlock + ffc_BLOBSegmentHeaderSize; - LookupEntry := @LookupSegBlk^[OffsetInBlock]; - - { How many entries are in the current lookup segment? } - MaxLookupEntries := FFCalcMaxLookupEntries(LookupSegPtr); - CurrLookupEntry := 1; - - {$IFDEF BLOBTrace} - LookupSegCount := LookupSegCount + 1; - Logbt(' Moving to lookup segment %d', - [LookupSegCount]); - Logbt(' Lookup segment - Max entries: %d', - [MaxLookupEntries]); - {$ENDIF} - end - end - else if IsEmptyLookupEntry(LookupEntry) then - { Have we encountered an empty lookup segment? If so then this - indicates the end of the BLOB content. } - Break; - - if (StartBytesUsed = 0) then - BLOBPos := BLOBPos + LookupEntry^.bleContentLength - else - StartBytesUsed := 0; - - aFI^.fiBLOBrscMgr.DeleteSegment(aFI, - aTI, - LookupEntry^.bleSegmentOffset); - FillChar(LookupEntry^, ffc_BLOBLookupEntrySize, 0); {!!.13} - - end; { while } - LookupSegPtr^.bshNextSegment.iLow := ffc_W32NoValue; - end else begin - { We are truncating to length of 0. } - FFTblDeleteBLOBPrim(aFI, aTI, BLOBHeader); - - { Reset the lookup segment field and the segment count. - FFTblFreeBLOB will get rid of the BLOB header if the BLOB is - still at length 0. } - BLOBHeader^.bbh1stLookupSeg.iLow := ffc_W32NoValue; - end; - { Set the new BLOB length and segment count in the BLOB header. } - BLOBHeader^.bbhBLOBLength := aLen; - - { Set the new segment count in the BLOB header. } - BLOBHeader^.bbhSegCount := NewSegCount; - finally - for OffsetInBlock := 0 to (aRelList.Count - 1) do - FFDeallocReleaseInfo(aRelList[OffsetInBlock]); - aRelList.Free; - end; -end; -{--------} -procedure TffBLOBEngine.Write(aFI : PffFileInfo; - aTI : PffTransInfo; - const aBLOBNr : TffInt64; - aOffset : TffWord32; {offset in blob to start writing} - aLen : TffWord32; {bytes from aOffset to stop writing} - const aBLOB); -var - aLkpRelMethod, - aRelMethod : TffReleaseMethod; - aRelList : TffPointerList; - ContentSegOfs : TffInt64; - BLOBPos, - BytesCopied, - BytesToCopy, - BytesToGo, - CurrLookupEntry, - LookupBlock, - LookupEntOfs, - LookupSegOfs, - MaxLookupEntries, - NewSize, - OffsetInBlock, - SegBytesLeft, - SegSize, - StartBytesUsed, - TargetOffset, - TempWord : TffWord32; - MinSegSize : Integer; - BLOBBlock, - ContentSegBlk, - LookupSegBlk, - PrevContSegBlk : PffBlock; - BLOBBlockHdr : PffBlockHeaderBLOB absolute BLOBBlock; - BLOBHeader : PffBLOBHeader; - BLOBAsBytes : PffBLOBArray; - LookupEntry : PffBLOBLookupEntry; - ContentSegPtr, - LookupSegPtr, - PrevContentSegPtr, - TempSegPtr : PffBLOBSegmentHeader; - NewSegment : Boolean; -{$IFDEF BLOBTrace} - LookupSegCount : Integer; -{$ENDIF} - NextSeg : TffInt64; {!!.11} -begin -{$IFDEF BLOBTrace} - Logbt('Entering FFTblWriteBLOB', []); - Logbt(' aBLOBNr = %d:%d', [aBLOBNr.iLow, aBLOBNr.iHigh]); - Logbt(' aOffset = %d', [aOffset]); - Logbt(' aLen = %d', [aLen]); - try -{$ENDIF} - - BLOBAsBytes := @aBLOB; - ContentSegOfs.iLow := ffc_W32NoValue; - LookupSegBlk := nil; - - { We use the following list to track the RAM pages we've accessed and - the release method associated with each RAM page. At the end of this - routine, we will call the release method for each RAM page. } - aRelList := TffPointerList.Create; - - try - { Read and verify the BLOB header block for this BLOB number. } - BLOBBlock := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - aBLOBNr, - OffsetInBlock, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(BLOBBlock, TffInt64(aRelMethod))); - BLOBHeader := @BLOBBlock^[OffsetInBlock]; - - { Verify the new length (aLen + aOffset) doesn't exceed max. } - NewSize := FFMaxL(aOffset + aLen, BLOBHeader^.bbhBLOBLength); - if (NewSize > ffcl_MaxBLOBLength) then - FFRaiseException(EffServerException, - ffStrResServer, - fferrBLOBTooBig, - [NewSize]); - - { Verify the BLOB has not been deleted. } - if (BLOBHeader^.bbhSignature = ffc_SigBLOBSegDeleted) then - FFRaiseException(EffServerException, - ffStrResServer, - fferrBLOBDeleted, - [aFI^.fiName^, - aBLOBNr.iHigh, - aBLOBNr.iLow]); - - { For a file BLOB raise an error. } - if (BLOBHeader^.bbhSegCount = -1) then - FFRaiseException(EffServerException, - ffStrResServer, - fferrFileBLOBWrite, - [aFI^.fiName^, - aBLOBNr.iLow, - aBLOBNr.iHigh]); - - { Verify the offset is within, or at the end of, the BLOB. } - if (aOffset > BLOBHeader^.bbhBLOBLength) then - FFRaiseException(EffServerException, - ffStrResServer, - fferrOfsNotInBlob, - [aFI^.fiName^, - aBLOBNr.iLow, - aBLOBNr.iHigh, - aOffset, - BLOBHeader^.bbhBLOBLength]); - - { If there's not one, we'll need a lookup segment. } - if (BLOBHeader^.bbh1stLookupSeg.iLow = ffc_W32NoValue) then begin - NewSegment := True; - TempWord := EstimateSegmentCount(NewSize, aFI^.fiMaxSegSize); - TempWord := (TempWord * ffc_BLOBLookupEntrySize) + ffc_BLOBSegmentHeaderSize; - TempWord := FFMinDW(TempWord, aFI^.fiMaxSegSize); - BLOBHeader^.bbh1stLookupSeg := aFI^.fiBLOBrscMgr.NewSegment(aFI, - aTI, - TempWord, - (TempWord div 2)); - {$IFDEF BLOBTrace} - Logbt(' Built first lookup segment: %d:%d', - [BLOBHeader^.bbh1stLookupSeg.iLow, - BLOBHeader^.bbh1stLookupSeg.iHigh]); - {$ENDIF} - end else begin - NewSegment := False; - {$IFDEF BLOBTrace} - Logbt(' First lookup segment established: %d:%d', - [BLOBHeader^.bbh1stLookupSeg.iLow, - BLOBHeader^.bbh1stLookupSeg.iHigh]); - {$ENDIF} - end; - - { Get the first lookup segment. } - LookupSegBlk := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - BLOBHeader^.bbh1stLookupSeg, - LookupSegOfs, - aLkpRelMethod); - LookupSegPtr := @LookupSegBlk^[LookupSegOfs]; - if (NewSegment) then begin - LookupSegPtr^.bshParentBLOB := aBLOBNr; - LookupSegPtr^.bshSignature := ffc_SigBLOBSegLookup; - LookupSegPtr^.bshNextSegment.iLow := ffc_W32NoValue; - end; - MaxLookupEntries := FFCalcMaxLookupEntries(LookupSegPtr); - - LookupEntOfs := LookupSegOfs + SizeOf(TffBLOBSegmentHeader); - CurrLookupEntry := 1; - {$IFDEF BLOBTrace} - LookupSegCount := 1; - Logbt(' Lookup segment - Max entries: %d', [MaxLookupEntries]); - {$ENDIF} - - { Position to where we are to start writing. } - BLOBPos := 0; - LookupEntry := nil; - StartBytesUsed := 0; - while (BLOBPos < aOffset) do begin - LookupEntry := @LookupSegBlk^[LookupEntOfs]; - {$IFDEF BLOBTrace} - Logbt(' Lookup entry %d points to a segment with %d bytes', - [CurrLookupEntry, - LookupEntry^.bleContentLength]); - {$ENDIF} - { Does this entry point to the segment where we should start - copying data? } - if ((BLOBPos + LookupEntry^.bleContentLength) >= aOffset) then begin - { Yes. We found the starting point. } - ContentSegOfs := LookupEntry^.bleSegmentOffset; - StartBytesUsed := aOffset - BLOBPos; - { NOTE: We will be making updates to this segment, so we don't - want to move past it. } - Break; - end else begin - { Nope. Update and keep moving. } - BLOBPos := BLOBPos + LookupEntry^.bleContentLength; - LookupEntOfs := LookupEntOfs + ffc_BLOBLookupEntrySize; - CurrLookupEntry := CurrLookupEntry + 1; - end; - - { Have we reached the end of this lookup segment? } - if (CurrLookupEntry > MaxLookupEntries) then begin - { Get the lookup segment block and set up offset for 1st lookup entry. } - NextSeg := LookupSegPtr^.bshNextSegment; {!!.11} - aLkpRelMethod(LookupSegBlk); - LookupSegBlk := ReadVfyBlobBlock2(aFI, - aTI, - ffc_MarkDirty, - NextSeg, {!!.11} - LookupBlock, - LookupSegOfs, - aLkpRelMethod); - LookupSegPtr := @LookupSegBlk^[LookupSegOfs]; - LookupEntOfs := LookupSegOfs + SizeOf(TffBLOBSegmentHeader); - - { How many entries are in the current lookup segment? } - MaxLookupEntries := FFCalcMaxLookupEntries(LookupSegPtr); - CurrLookupEntry := 1; - {$IFDEF BLOBTrace} - LookupSegCount := LookupSegCount + 1; - Logbt(' Moving to lookup segment %d', - [LookupSegCount]); - Logbt(' Lookup segment - Max entries: %d', - [MaxLookupEntries]); - {$ENDIF} - end; - end; - - { We may need to initialize the previous content segment so that - we can maintain the chain. } - if ((BLOBPos = 0) and - (BLOBHeader^.bbhBLOBLength > 0)) then begin - LookupEntry := @LookupSegBlk^[LookupEntOfs]; - ContentSegOfs := LookupEntry^.bleSegmentOffset; - end; - - ContentSegPtr := nil; - if (ContentSegOfs.iLow <> ffc_W32NoValue) then begin - { Get the previous content segment. } - ContentSegOfs := LookupEntry^.bleSegmentOffset; - ContentSegBlk := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - ContentSegOfs, - OffsetInBlock, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(ContentSegBlk, - TffInt64(aRelMethod))); - ContentSegPtr := @ContentSegBlk^[OffsetInBlock]; - {$IFDEF BLOBTrace} - Logbt(' Initialized 1st content segment to write to: %d:%d', - [ContentSegOfs.iLow, ContentSegOfs.iHigh]); - Logbt(' Total segment length: %d', - [ContentSegPtr^.bshSegmentLen]); - Logbt(' Bytes to keep: %d', - [StartBytesUsed]); - {$ENDIF} - end; - - { I've been using BLOBPos to track where I was at in the existing - BLOB, if any. Now, I'm going to be using it to track where we - are in the source (data being added to the BLOB). } - BLOBPos := 0; - - { Now we're positioned and ready to start copying the source data - to the BLOB. } - BytesToGo := aLen; - while (BytesToGo > 0) do begin - { Are we overwriting an existing segment? } - if (ContentSegOfs.iLow <> ffc_W32NoValue) then begin - { Yes. Get the location of the existing segment so we can - update it. } - BytesToCopy := BytesToGo; - {$IFDEF BLOBTrace} - Logbt(' Updating existing segment: %d:%d.', - [ContentSegOfs.iLow, ContentSegOfs.iHigh]); - {$ENDIF} - end else begin - { Nope. We'll have to intialize a new lookup entry and get a - new content segment. } - NewSegment := True; - LookupEntry := @LookupSegBlk^[LookupEntOfs]; - - { Update the previous content segment so we can chain it to the - next one later. } - PrevContentSegPtr := ContentSegPtr; - - { Figure out how many bytes we "want" to copy. } - BytesToCopy := ffMinL(aFI^.fiMaxSegSize, BytesToGo); - - { Get a new content segment} - SegSize := BytesToCopy; - MinSegSize := ffc_BLOBSegmentIncrement; - ContentSegOfs := aFI^.fiBLOBrscMgr.NewSegment(aFI, - aTI, - SegSize, - MinSegSize); - LookupEntry^.bleSegmentOffset := ContentSegOfs; - LookupEntry^.bleContentLength := 0; - - { Increment the segment count. } - BLOBHeader^.bbhSegCount := BLOBHeader^.bbhSegCount + 1; - - if (PrevContentSegPtr <> nil) then begin - PrevContentSegPtr^.bshNextSegment := ContentSegOfs; - end; - {$IFDEF BLOBTrace} - Logbt(' Created new segment: %d:%d.', - [ContentSegOfs.iLow, ContentSegOfs.iHigh]); - {$ENDIF} - end; - - { Get the content segment. } - ContentSegBlk := ReadVfyBlobBlock(aFI, - aTI, - ffc_MarkDirty, - ContentSegOfs, - OffsetInBlock, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(ContentSegBlk, - TffInt64(aRelMethod))); - ContentSegPtr := @ContentSegBlk^[OffsetInBlock]; - if (NewSegment) then begin - ContentSegPtr^.bshSignature := ffc_SigBLOBSegContent; - ContentSegPtr^.bshParentBLOB := aBLOBNr; - ContentSegPtr^.bshNextSegment.iLow := ffc_W32NoValue; - NewSegment := False; - end; - - { We may not have gotten an optimal size segment, so we need - to update how many bytes we can copy based on the actual - segment size. } - StartBytesUsed := StartBytesUsed + ffc_BLOBSegmentHeaderSize; - TargetOffset := OffsetInBlock + StartBytesUsed; - SegBytesLeft := ContentSegPtr^.bshSegmentLen - StartBytesUsed; - BytesToCopy := FFMinL(BytesToCopy, SegBytesLeft); - - { Copy. } - Move(BLOBAsBytes^[BLOBPos], - ContentSegBlk^[TargetOffset], - BytesToCopy); - BytesToGo := BytesToGo - BytesToCopy; - BLOBPos := BLOBPos + BytesToCopy; - Assert(BytesToGo <= aLen, 'BLOB writing is out of whack'); - - {$IFDEF BLOBTrace} - Logbt(' Copied %d bytes to lookup segment %d, entry %d, content segment %d:%d', - [BytesToCopy, - LookupSegCount, - CurrLookupEntry, - ContentSegOfs.iLow, ContentSegOfs.iHigh]); - {$ENDIF} - - StartBytesUsed := StartBytesUsed - ffc_BLOBSegmentHeaderSize; - { Update the content length of the lookup entry. We have several - cases to account for: - 1. Write X bytes to empty segment. Length = X. - 2. Suffix X bytes to end of segment containing Y bytes. - Length = X + Y. - 3. Write X bytes to segment containing Y bytes where X <= Y and - (aOffset + X) <= Y. Length = Y. - 4. Write X bytes to segment containing Y bytes where X <= Y and - (aOffset + X) > Y. Length = # untouched bytes + Y. - These cases are all handled by the following IF statement. } - if (StartBytesUsed + BytesToCopy > - LookupEntry^.bleContentLength) then begin - LookupEntry^.bleContentLength := StartBytesUsed + BytesToCopy; - end; - {$IFDEF BLOBTrace} - Logbt(' Last lookup entry now points to segment with %d bytes', - [LookupEntry^.bleContentLength]); - {$ENDIF} - - CurrLookupEntry := CurrLookupEntry + 1; - StartBytesUsed := 0; - - { Have we reached the end of this lookup segment? } - if ((BytesToGo > 0) and - (CurrLookupEntry > MaxLookupEntries)) then begin - { Is there another lookup segment in this chain? } - if (LookupSegPtr^.bshNextSegment.iLow = ffc_W32NoValue) then begin - { No. We'll have to get a new one and add it to the chain. } - TempWord := EstimateSegmentCount(BytesToGo, aFI^.fiMaxSegSize); - TempWord := (TempWord * ffc_BLOBLookupEntrySize) + ffc_BLOBSegmentHeaderSize; - TempWord := FFMinDW(TempWord, aFI^.fiMaxSegSize); - - { Use ContentSegPtr to hold the new lookup segment's offset - temporarily. } - ContentSegOfs := aFI^.fiBLOBrscMgr.NewSegment(aFI, - aTI, - TempWord, - TempWord); - {$IFDEF BLOBTrace} - Logbt(' Creating new lookup segment: %d:%d.', - [ContentSegOfs.iLow, ContentSegOfs.iHigh]); - {$ENDIF} - end else begin - { Yes. Assign it to our temp variable. } - ContentSegOfs := LookupSegPtr^.bshNextSegment; - {$IFDEF BLOBTrace} - Logbt(' Moving to next lookup segment.', - [ContentSegOfs.iLow, ContentSegOfs.iHigh]); - {$ENDIF} - end; - - { Get the lookup segment block and set up offset for 1st - lookup entry. } - aLkpRelMethod(LookupSegBlk); - LookupSegBlk := ReadVfyBlobBlock2(aFI, - aTI, - ffc_MarkDirty, - ContentSegOfs, - LookupBlock, - LookupSegOfs, - aLkpRelMethod); - - { Intialize the segment on if it's new. } - if ((LookupSegPtr <> nil) and - (LookupSegPtr^.bshNextSegment.iLow <> ffc_W32NoValue)) then begin - LookupSegPtr := @LookupSegBlk^[LookupSegOfs]; - LookupEntOfs := LookupSegOfs + ffc_BLOBSegmentHeaderSize; - LookupEntry := @LookupSegBlk^[LookupEntOfs]; - ContentSegOfs := LookupEntry^.bleSegmentOffset; - end else begin - { Chain the last lookup segment to the new one. } - LookupSegPtr^.bshNextSegment := ContentSegOfs; - - LookupSegPtr := @LookupSegBlk^[LookupSegOfs]; - LookupSegPtr^.bshParentBLOB := aBLOBNr; - LookupSegPtr^.bshSignature := ffc_SigBLOBSegLookup; - LookupSegPtr^.bshNextSegment.iLow := ffc_W32NoValue; - - LookupEntOfs := LookupSegOfs + ffc_BLOBSegmentHeaderSize; - LookupEntry := @LookupSegBlk^[LookupEntOfs]; - ContentSegOfs.iLow := ffc_W32NoValue; - end; - - { How many entries are in the current lookup segment? } - MaxLookupEntries := FFCalcMaxLookupEntries(LookupSegPtr); - CurrLookupEntry := 1; - {$IFDEF BLOBTrace} - LookupSegCount := LookupSegCount + 1; - Logbt(' Moving to lookup segment %d', - [LookupSegCount]); - Logbt(' Lookup segment - Max entries: %d', - [MaxLookupEntries]); - {$ENDIF} - end else begin - LookupEntOfs := LookupEntOfs + ffc_BLOBLookupEntrySize; - LookupEntry := @LookupSegBlk^[LookupEntOfs]; - ContentSegOfs := ContentSegPtr^.bshNextSegment; - end; - end; - - { If the BLOB has grown, we need to update its length. - NOTE: BLOBs can't be truncated via a write operation. } - if (NewSize > BLOBHeader^.bbhBLOBLength) then - BLOBHeader^.bbhBLOBLength := NewSize; - finally - if (LookupSegBlk <> nil) then - aLkpRelMethod(LookupSegBlk); - for OffsetInBlock := 0 to (aRelList.Count - 1) do - FFDeallocReleaseInfo(aRelList[OffsetInBlock]); - aRelList.Free; - end; -{$IFDEF BLOBTrace} - except - on E:Exception do begin - Logbt('*** FFTblWriteBLOB Error: %s', [E.Message]); - raise; - end; - end; -{$ENDIF} -end; -{====================================================================} - -{===Tff210BLOBEngine=================================================} -procedure Tff210BLOBEngine.Read(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aOffset : TffWord32; - aLen : TffWord32; - aReadMethod : TffBLOBLinkRead; - var aBLOB; - var aBytesRead : TffWord32; - var aFBError : TffResult); -var - BLOBAsBytes : PffBLOBArray; - BLOBBlock : PffBlock; - BLOBBlockHdr : PffBlockHeaderBLOB absolute BLOBBlock; - BLOBBlockNum : TffWord32; - BLOBHeader : PffBLOBHeader; - BytesToCopy : Longint; - CmpRes : integer; - ContentBlock : TffWord32; - ContentSegBlk : PffBlock; - ContentSegOfs : TffWord32; - DestOffset : Longint; - EndBytesUsed : TffWord32; - EndSegInx : Integer; - EntryCount : Integer; - LookupBlock : TffWord32; - LookupEntry : PffBLOBLookupEntry; - LookupSegBlk : PffBlock; - LookupSegPtr : PffBLOBSegmentHeader; - NextSeg : TffInt64; - OffsetInBlock : TffWord32; - SegInx : Integer; - StartBytesUsed : TffWord32; - StartSegInx : Integer; - aCntRelMethod, - aLkpRelMethod, - aHdRelMethod : TffReleaseMethod; -begin - BLOBAsBytes := @aBLOB; - ContentSegBlk := nil; - LookupSegBlk := nil; - - aFBError := 0; - - {Exit if aLen = 0} - if aLen = 0 then - Exit; - - { Read and verify the BLOB header block for this BLOB number. } - BLOBBlock := ReadVfyBlobBlock2(aFI, aTI, ffc_ReadOnly, aBLOBNr, - BLOBBlockNum, OffsetInBlock, aHdRelMethod); - BLOBHeader := @BLOBBlock^[OffsetInBlock]; - - { Verify the BLOB has not been deleted. } - if (BLOBHeader^.bbhSignature = ffc_SigBLOBSegDeleted) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBLOBDeleted, - [aFI^.fiName^, aBLOBNr.iHigh, aBLOBNr.iLow]); - - try - { Are we dealing with a file BLOB or a BLOB link? } - case BLOBHeader^.bbhSegCount of - ffc_FileBLOB : { file BLOB } - begin - aFBError := FileBLOBRead(aFI, aTI, aBLOBNr, aOffset, aLen, aBLOB, - aBytesRead); - Exit; - end; - ffc_BLOBLink : { BLOB link } - begin - aFBError := BLOBLinkRead(aFI, aTI, aBLOBNr, aOffset, aLen, - aReadMethod, aBLOB, aBytesRead); - Exit; - end; - end; { case } - - { Make sure that the offset is within BLOB. } - CmpRes := FFCmpDW(aOffset, BLOBHeader^.bbhBLOBLength); - if (CmpRes >= 0) then begin - aBytesRead := 0; - Exit; - end; - { Get the lookup segment block and set up offset for 1st lookup entry. } - LookupSegBlk := ReadVfyBlobBlock2(aFI, aTI, ffc_ReadOnly, - BLOBHeader^.bbh1stLookupSeg, - LookupBlock, OffsetInBlock, - aLkpRelMethod); - LookupSegPtr := @LookupSegBlk^[OffsetInBlock]; - OffsetInBlock := OffsetInBlock + sizeof(TffBLOBSegmentHeader); - - { Calculate the number of bytes we can (= "are going to") read. } - aBytesRead := ffMinDW(aLen, BLOBHeader^.bbhBLOBLength - aOffset); - - { Calculate the starting & ending index of the segments to read. } - if aOffset = 0 then begin - StartSegInx := 0; - StartBytesUsed := 0; - end - else - StartSegInx := CalcBLOBSegNumber(aOffset, aFI^.fiBlockSize, StartBytesUsed); - EndSegInx := CalcBLOBSegNumber(aOffset + aBytesRead, - aFI^.fiBlockSize, - EndBytesUsed); - - { Walk through the BLOB segment linked list, reading segments as we - go, copying to the BLOB when required. } - SegInx := 1; - DestOffset := 0; - EntryCount := 0; - ContentBlock := 0; - while (SegInx <= EndSegInx) do begin - inc(EntryCount); - LookupEntry := @LookupSegBlk^[OffsetInBlock]; - - {if we should read from this block, do so} - if (SegInx >= StartSegInx) then begin - - { Read the BLOB content segment. } - if assigned(ContentSegBlk) then - aCntRelMethod(ContentSegBlk); - ContentSegBlk := ReadVfyBlobBlock2(aFI, aTI, ffc_ReadOnly, - LookupEntry^.bleSegmentOffset, - ContentBlock, ContentSegOfs, - aCntRelMethod); - ContentSegOfs := ContentSegOfs + sizeof(TffBLOBSegmentHeader); - - if SegInx = StartSegInx then begin - { move from starting offset to dest } - BytesToCopy := LookupEntry^.bleContentLength - StartBytesUsed; - ContentSegOfs := ContentSegOfs + StartBytesUsed; - end else if SegInx = EndSegInx then begin - { move up to ending offset to dest } - BytesToCopy := EndBytesUsed; - end else begin - { copying from middle segments } - BytesToCopy := LookupEntry^.bleContentLength; - end; - BytesToCopy := ffMinL(BytesToCopy, aBytesRead); - Move(ContentSegBlk^[ContentSegOfs], BLOBAsBytes^[DestOffset], BytesToCopy); - inc(DestOffset, BytesToCopy); - end; { if } - - {see if we're at the end of the lookup segment} - if ((SegInx <> EndSegInx) and - (LookupSegPtr^.bshSegmentLen < - (sizeof(TffBLOBSegmentHeader) + - (succ(EntryCount) * sizeof(TffBLOBLookupEntry))))) then begin - NextSeg := LookupSegPtr^.bshNextSegment; - aLkpRelMethod(LookupSegBlk); - LookupSegBlk := ReadVfyBlobBlock2(aFI, aTI, ffc_ReadOnly, - NextSeg, {!!.11} - LookupBlock, OffsetInBlock, - aLkpRelMethod); - LookupSegPtr := @LookupSegBlk^[OffsetInBlock]; - OffsetInBlock := OffsetInBlock + sizeof(TffBLOBSegmentHeader); - EntryCount := 0; - end else - OffsetInBlock := OffsetInBlock + sizeof(TffBLOBLookupEntry); - inc(SegInx); - end; {while} - finally - if assigned(ContentSegBlk) then - aCntRelMethod(ContentSegBlk); - if assigned(LookupSegBlk) then - aLkpRelMethod(LookupSegBlk); - aHdRelMethod(BLOBBlock); - end; -end; -{--------} -procedure Tff210BLOBEngine.Truncate(aFI : PffFileInfo; - aTI : PffTransInfo; - aBLOBNr : TffInt64; - aLen : TffWord32); -var - BLOBBlock : PffBlock; - BLOBBlockHdr : PffBlockHeaderBLOB absolute BLOBBlock; - BLOBHeader : PffBLOBHeader; - EntryCount : TffWord32; - OffsetInBlock : TffWord32; - NewSegCount : TffWord32; - OldSegCount : TffWord32; - i : Integer; - IsNewTailSeg : Boolean; - LookupBlock : TffWord32; - LookupSegBlk : PffBlock; - LookupSegOfs : TffInt64; - LookupSegPtr : PffBLOBSegmentHeader; - LookupEntOfs : TffWord32; - LookupEntPtr : PffBLOBLookupEntry; - OldUsedSpace : TffWord32; - NewUsedSpace : TffWord32; - OldContSegOfs : TffWord32; - OldContSegBlk : PffBlock; - OldContSegPtr : PffBLOBSegmentHeader; - NewContSegOfs : TffWord32; - NewContSegBlk : PffBlock; - NewContSegPtr : PffBLOBSegmentHeader; - NextLookupSeg : TffInt64; - UpdatedContSeg : TffInt64; - SegEntries : TffWord32; - TailEntry : TffWord32; - TotEntries : TffWord32; - aRelList : TffPointerList; - aRelMethod : TffReleaseMethod; - SegSize : TffWord32; -begin - - { We use the following list to track the RAM pages we've accessed and - the release method associated with each RAM page. At the end of this - routine, we will call the release method for each RAM page. } - aRelList := TffPointerList.Create; - - try - { Read and verify the BLOB header block for this BLOB number. } - BLOBBlock := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, aBLOBNr, - OffsetInBlock, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(BLOBBlock,TffInt64(aRelMethod))); - - BLOBHeader := @BLOBBlock^[OffsetInBlock]; - - { Check if we're trying to truncate a zero-length BLOB or to the - BLOB's current length. } - if ((BLOBHeader^.bbhBLOBLength = aLen) or - ((BLOBHeader^.bbhBLOBLength = 0) and - (aLen = 0))) then - Exit; - - { Verify the BLOB has not been deleted. } - if (BLOBHeader^.bbhSignature = ffc_SigBLOBSegDeleted) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBLOBDeleted, - [aFI^.fiName^, aBLOBNr.iHigh, aBLOBNr.iLow]); - { Verify this is a header segment. } - if (BLOBHeader^.bbhSignature <> ffc_SigBLOBSegHeader) then - FFRaiseException(EffServerException, ffStrResServer, fferrBadBLOBSeg, - [aFI^.fiName^, aBLOBNr.iLow, aBLOBNr.iHigh, - format(ffcBLOBSegExpected, - [ffcBLOBSegHeader, - char(BLOBHeader^.bbhSignature)])]); - - { We can't write to a file BLOB. } - if (BLOBHeader^.bbhSegCount = -1) then - FFRaiseException(EffServerException, ffStrResServer, - fferrFileBLOBWrite, [aFI^.fiName^, aBLOBNr.iLow, - aBLOBNr.iHigh]); - - { Make sure the truncated length <= current BLOB length. } - if (aLen > BLOBHeader^.bbhBLOBLength) then - FFRaiseException(EffServerException, ffStrResServer, fferrLenMismatch, - [aFI^.fiName^, aBLOBNr.iLow, aBLOBNr.iHigh, aLen, - BLOBHeader^.bbhBLOBLength]); - - { If the new length is greater than 0, we will lop off some content - segments. The content segment that becomes the last content segment - must be resized. } - if aLen > 0 then begin - - { Calculate the number of segments for the old and new lengths. } - OldSegCount := CalcBLOBSegNumber(BLOBHeader^.bbhBLOBLength, - aFI^.fiBlockSize, OldUsedSpace); - NewSegCount := CalcBLOBSegNumber(aLen, aFI^.fiBlockSize, NewUsedSpace); - - { Grab the first lookup segment. } - NextLookupSeg := BLOBHeader^.bbh1stLookupSeg; - LookupSegBlk := ReadVfyBlobBlock2(aFI, aTI, ffc_MarkDirty, {!!.12} - NextLookupSeg, LookupBlock, - OffsetInBlock, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(LookupSegBlk,TffInt64(aRelMethod))); - LookupSegPtr := PffBLOBSegmentHeader(@LookupSegBlk^[OffsetInBlock]); - - TotEntries := 0; - - { Calculate # of entries in this lookup segment. } - SegEntries := FFCalcMaxLookupEntries(LookupSegPtr); - - { Walk through the lookup segments until we find the lookup segment - containing the new tail lookup entry. } - while ((TotEntries + SegEntries) < NewSegCount) do begin - - Inc(TotEntries, SegEntries); - - { Grab the offset of the next lookup segment. } - NextLookupSeg := LookupSegPtr^.bshNextSegment; - - LookupSegBlk := ReadVfyBlobBlock2(aFI, aTI, ffc_MarkDirty, - NextLookupSeg, {!!.12} - LookupBlock, OffsetInBlock, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(LookupSegBlk,TffInt64(aRelMethod))); - LookupSegPtr := PffBLOBSegmentHeader(@LookupSegBlk^[OffsetInBlock]); - SegEntries := FFCalcMaxLookupEntries(LookupSegPtr); - end; - - { Find the lookup entry that will now point to the new tail content - segment. } - TailEntry := pred(NewSegCount - TotEntries); { base zero } - LookupEntOfs := (OffsetInBlock + sizeof(TffBLOBSegmentHeader) + - (TailEntry * sizeof(TffBLOBLookupEntry))); - LookupEntPtr := PffBLOBLookupEntry(@LookupSegBlk^[LookupEntOfs]); - - { Grab the content segment pointed to by this lookup entry. We will copy - over some of those bytes to the new tail content segment. } - UpdatedContSeg := LookupEntPtr^.bleSegmentOffset; - - { Obtain the new tail content segment. } - SegSize := NewUsedSpace + sizeof(TffBLOBSegmentHeader); - LookupEntPtr^.bleSegmentOffset := - aFI^.fiBLOBrscMgr.NewSegment(aFI, aTI, SegSize, SegSize); - LookupEntPtr^.bleContentLength := NewUsedSpace; - - { Initialize the new content segment header. } - NewContSegBlk := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - LookupEntPtr^.bleSegmentOffset, - NewContSegOfs, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(NewContSegBlk, TffInt64(aRelMethod))); - NewContSegPtr := PffBLOBSegmentHeader(@NewContSegBlk^[NewContSegOfs]); - NewContSegPtr^.bshSignature := ffc_SigBLOBSegContent; - NewContSegPtr^.bshParentBLOB := aBLOBNr; - NewContSegPtr^.bshNextSegment.iLow := ffc_W32NoValue; - - { If there is more than one content segment in the truncated BLOB, - make sure the next to last content segment points to the new tail - content segment. } - if NewSegCount > 1 then begin - LookupEntPtr := PffBLOBLookupEntry(@LookupSegBlk^[LookupEntOfs - - sizeof(TffBLOBLookupEntry)]); - OldContSegBlk := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - LookupEntPtr^.bleSegmentOffset, - OldContSegOfs, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(OldContSegBlk, TffInt64(aRelMethod))); - OldContSegPtr := PffBLOBSegmentHeader(@OldContSegBlk^[OldContSegOfs]); - - { Restore LookupEntPtr. } - LookupEntPtr := PffBLOBLookupEntry(@LookupSegBlk^[LookupEntOfs]); - OldContSegPtr^.bshNextSegment := LookupEntPtr^.bleSegmentOffset; - end; - - { Copy NewUsedSpace bytes from the old content segment to new tail content - segment. } - OldContSegBlk := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - UpdatedContSeg, OldContSegOfs, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(OldContSegBlk, TffInt64(aRelMethod))); - Move(OldContSegBlk^[OldContSegofs + sizeof(TffBLOBSegmentHeader)], - NewContSegBlk^[NewContSegOfs + sizeof(TffBLOBSegmentHeader)], - NewUsedSpace); - - { Get rid of the old content segment. } - aFI^.fiBLOBrscMgr.DeleteSegment(aFI, aTI, UpdatedContSeg); - - { Delete the content & lookup segments that are no longer needed. - First, obtain the number of extraneous lookup entries in the - current lookup segment. } - EntryCount := FFCalcMaxLookupEntries(LookupSegPtr) - succ(TailEntry); - - { Initialize the lookup entry offset & pointer. They must - point to the lookup entry after the new tail lookup entry. } - LookupEntOfs := (OffsetInBlock + sizeof(TffBLOBSegmentHeader) + - (succ(TailEntry) * sizeof(TffBLOBLookupEntry))); - LookupEntPtr := PffBLOBLookupEntry(@LookupSegBlk^[LookupEntOfs]); - - { Save the offset of the current lookup segment. } - LookupSegOfs := NextLookupSeg; - - IsNewTailSeg := True; - - { Free each content segment. } - for i := succ(NewSegCount) to OldSegCount do begin - - aFI^.fiBLOBrscMgr.DeleteSegment(aFI, aTI, LookupEntPtr^.bleSegmentOffset); - dec(EntryCount); - - { Need to move to another lookup segment? } - if ((EntryCount = 0) and (LookupSegPtr^.bshNextSegment.iLow <> ffc_W32NoValue)) then begin - {Yes. Get the location of the next lookup segment. } - NextLookupSeg := LookupSegPtr^.bshNextSegment; - - { If this is not the new tail lookup segment then delete the - lookup segment. } - if IsNewTailSeg then - IsNewTailSeg := False - else - aFI^.fiBLOBrscMgr.DeleteSegment(aFI, aTI, LookupSegOfs); - - { Grab the next lookup segment. } - LookupSegBlk := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - NextLookupSeg, OffsetInBlock, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(LookupSegBlk, TffInt64(aRelMethod))); - LookupSegPtr := @LookupSegBlk^[OffsetInBlock]; - LookupEntOfs := OffsetInBlock + sizeof(TffBLOBSegmentHeader); - LookupSegOfs := NextLookupSeg; - EntryCount := FFCalcMaxLookupEntries(LookupSegPtr); - end; - - { If this is the new tail lookup segment then zero out the lookup - entry. } - if IsNewTailSeg then - FillChar(LookupEntPtr^, sizeof(TffBLOBLookupEntry), 0); {!!.13} - - { Grab the next lookup entry. } - LookupEntOfs := LookupEntOfs + sizeof(TffBLOBLookupEntry); - LookupEntPtr := @LookupSegBlk^[LookupEntOfs]; - end; {for} - - { Delete the last lookup segment if it's not the new tail - segment.} - if not IsNewTailSeg then - aFI^.fiBLOBrscMgr.DeleteSegment(aFI, aTI, LookupSegOfs); - - { Set the new segment count in the BLOB header. } - BLOBHeader^.bbhSegCount := NewSegCount; - - end else begin {we are truncating to length of 0} - - FFTblDeleteBLOBPrim(aFI, aTI, BLOBHeader); - - { Reset the lookup segment field and the segment count. - FFTblFreeBLOB will get rid of the BLOB header if the BLOB is - still at length 0. } - BLOBHeader^.bbh1stLookupSeg.iLow := ffc_W32NoValue; - BLOBHeader^.bbhSegCount := 0; - BLOBHeader^.bbhBLOBLength := 0; - end; - {set the new BLOB length and segment count in the BLOB header} - BLOBHeader^.bbhBLOBLength := aLen; - finally - for OffsetInBlock := 0 to pred(aRelList.Count) do - FFDeallocReleaseInfo(aRelList[OffsetInBlock]); - aRelList.Free; - end; -end; -{--------} -procedure Tff210BLOBEngine.Write(aFI : PffFileInfo; - aTI : PffTransInfo; - const aBLOBNr : TffInt64; - aOffset : TffWord32; {offset in blob to start writing} - aLen : TffWord32; {bytes from aOffset to stop writing} - const aBLOB); -var - AvailSpace : TffWord32; - BLOBBlock : PffBlock; - BLOBBlockHdr : PffBlockHeaderBLOB absolute BLOBBlock; - BLOBHeader : PffBLOBHeader; - OffsetInBlock : TffWord32; - BLOBAsBytes : PffBLOBArray; - StartSegInx : Integer; - EndSegInx : Integer; - OldEndSeg : Integer; - SegInx : Integer; { index into the blob } - BytesToCopy : TffWord32; - BytesToGo : TffWord32; - SrcOffset : Longint; - LookupEntOfs : TffWord32; - LookupEntPtr : PffBLOBLookupEntry; - LookupSegOfs : TffWord32; - LookupSegPtr : PffBLOBSegmentHeader; - LookupSegBlk : PffBlock; - ContentSegOfs : TffInt64; - ContentSegBlk : PffBlock; - ContentSegPtr : PffBLOBSegmentHeader; - PrevContentSegPtr : PffBLOBSegmentHeader; - StartBytesUsed : TffWord32; - EndBytesUsed : TffWord32; - EntryCount : TffWord32; - SegBytesLeft : TffWord32; - SegEntNumber : TffWord32; { index into the lookup segment } - TargetOffset : TffWord32; - TempSegOfs : TffInt64; - TempSegBlk : PffBlock; - TempSegPtr : PffBLOBSegmentHeader; - TempOfsInBlk : TffWord32; - NewSize : TffWord32; - NewSizeW32 : TffWord32; - BytesCopied : Longint; - aRelMethod : TffReleaseMethod; - aRelList : TffPointerList; - SegSize : TffWord32; -begin - BLOBAsBytes := @aBLOB; - - NewSizeW32 := aOffset + aLen; - - { Verify the new length (aLen + aOffset) doesn't exceed max. } - if (NewSizeW32 > ffcl_MaxBLOBLength) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBLOBTooBig, [aOffset + aLen]); - - { We use the following list to track the RAM pages we've accessed and - the release method associated with each RAM page. At the end of this - routine, we will call the release method for each RAM page. } - aRelList := TffPointerList.Create; - - try - { Read and verify the BLOB header block for this BLOB number. } - BLOBBlock := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, aBLOBNr, - OffsetInBlock, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(BLOBBlock, TffInt64(aRelMethod))); - BLOBHeader := @BLOBBlock^[OffsetInBlock]; - - { Verify the BLOB has not been deleted. } - if (BLOBHeader^.bbhSignature = ffc_SigBLOBSegDeleted) then - FFRaiseException(EffServerException, ffStrResServer, - fferrBLOBDeleted, - [aFI^.fiName^, aBLOBNr.iHigh, aBLOBNr.iLow]); - - NewSize := FFMaxL(aOffset + aLen, BLOBHeader^.bbhBLOBLength); - - { For a file BLOB raise an error. } - if (BLOBHeader^.bbhSegCount = -1) then - FFRaiseException(EffServerException, ffStrResServer, - fferrFileBLOBWrite, [aFI^.fiName^, aBLOBNr.iLow, - aBLOBNr.iHigh]); - - { Verify the offset is within, or at the end of, the BLOB. } - if (aOffset > BLOBHeader^.bbhBLOBLength) then - FFRaiseException(EffServerException, ffStrResServer, - fferrOfsNotInBlob, [aFI^.fiName^, aBLOBNr.iLow, - aBLOBNr.iHigh, aOffset, - BLOBHeader^.bbhBLOBLength]); - - { If the BLOB is growing we need to rebuild the lookup segment(s). } - if (NewSize > BLOBHeader^.bbhBLOBLength) then - {the lookup segment(s) have to be rebuilt because the BLOB is growing} - BLOBHeader^.bbh1stLookupSeg := FFTblRebuildLookupSegments(aFI, aTI, - NewSize, - BLOBHeader^.bbhBLOBLength, - aBLOBNr); - - { Get the first lookup segment. } - LookupSegBlk := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - BLOBHeader^.bbh1stLookupSeg, - LookupSegOfs, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(LookupSegBlk, TffInt64(aRelMethod))); - LookupSegPtr := @LookupSegBlk^[LookupSegOfs]; - EntryCount := FFCalcMaxLookupEntries(LookupSegPtr); - { Calculate the last segment in which we will write data. } - EndSegInx := CalcBLOBSegNumber(aOffset + aLen, aFI^.fiBlockSize, - EndBytesUsed); - - if BLOBHeader^.bbhBLOBLength = 0 then begin - OldEndSeg := 0; - StartSegInx := 0; - end else begin - { Calculate the number of segments currently used. } - OldEndSeg := CalcBLOBSegNumber(BLOBHeader^.bbhBLOBLength, - aFI^.fiBlockSize, EndBytesUsed); - - { Calculate the segment in which we will start writing the data. } - if aOffset = 0 then begin - StartSegInx := 1; - StartBytesUsed := 0; - end - else - StartSegInx := CalcBLOBSegNumber(aOffset, aFI^.fiBlockSize, StartBytesUsed); - end; - - ContentSegPtr := nil; - PrevContentSegPtr := nil; - SrcOffset := 0; - BytesToGo := aLen; - SegInx := 0; - LookupEntOfs := LookupSegOfs + sizeof(TffBLOBSegmentHeader); - LookupEntPtr := PffBLOBLookupEntry(@LookupSegBlk^[LookupEntOfs]); - SegEntNumber := 0; - - { Walk through the lookup segments up to the current end segment. } - while (SegInx < OldEndSeg) and (SegInx < EndSegInx) do begin - - { Is the segment one in which we are to write data? } - if SegInx >= pred(StartSegInx) then begin - - { Get the content block. } - ContentSegBlk := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - LookupEntPtr^.bleSegmentOffset, - OffsetInBlock, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(ContentSegBlk, TffInt64(aRelMethod))); - ContentSegPtr := @ContentSegBlk^[OffsetInBlock]; - - SegBytesLeft := ContentSegPtr^.bshSegmentLen - ffc_BLOBSegmentHeaderSize; - TargetOffset := OffsetInBlock + ffc_BLOBSegmentHeaderSize; - - { If this is the first segment to which we are writing, adjust the - starting points. } - if SegInx = pred(StartSegInx) then begin - dec(SegBytesLeft, StartBytesUsed); - inc(TargetOffset, StartBytesUsed); - end - else - StartBytesUsed := 0; - - { If this old segment is not the largest it could be & is not big enough - to hold what is left then we need a new segment} - if StartBytesUsed = 0 then - AvailSpace := ContentSegPtr^.bshSegmentLen - - ffc_BLOBSegmentHeaderSize - else - AvailSpace := SegBytesLeft; - - if ((ContentSegPtr^.bshSegmentLen < aFI^.fiMaxSegSize) and - (AvailSpace < BytesToGo)) then begin - - { Calculate the size of the data in the new segment. } - BytesToCopy := ffMinL(aFI^.fiMaxSegSize - ffc_BLOBSegmentHeaderSize, - BytesToGo + LookupEntPtr^.bleContentLength); - - { Allocate & retrieve the new segment. } - SegSize := BytesToCopy + ffc_BLOBSegmentHeaderSize; - TempSegOfs := aFI^.fiBLOBrscMgr.NewSegment(aFI, aTI, SegSize, SegSize); - TempSegBlk := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - TempSegOfs, TempOfsInBlk, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(TempSegBlk, TffInt64(aRelMethod))); - TempSegPtr := @TempSegBlk^[TempOfsInBlk]; - TempSegPtr^.bshSignature := ffc_SigBLOBSegContent; - TempSegPtr^.bshParentBLOB := aBLOBNr; - - { Preserve the existing data in the old content segment. } - if LookupEntPtr^.bleContentLength > 0 then begin - assert(LookupEntPtr^.bleContentLength = EndBytesUsed); - Move(ContentSegBlk^[OffsetInBlock + ffc_BLOBSegmentHeaderSize], - TempSegBlk^[TempOfsInBlk + ffc_BLOBSegmentHeaderSize], - EndBytesUsed); - { Decrement EndBytesUsed. } - dec(EndBytesUsed, LookupEntPtr^.bleContentLength); - end; - SegBytesLeft := BytesToCopy - StartBytesUsed; - TargetOffset := TempOfsInBlk + ffc_BLOBSegmentHeaderSize + - StartBytesUsed; - { Change the previous content segment's NextSegment field. } - if Assigned(PrevContentSegPtr) then - PrevContentSegPtr^.bshNextSegment := TempSegOfs; - aFI^.fiBLOBrscMgr.DeleteSegment(aFI, aTI, - LookupEntPtr^.bleSegmentOffset); - LookupEntPtr^.bleSegmentOffset := TempSegOfs; - OffsetInBlock := TempOfsInBlk; - ContentSegBlk := TempSegBlk; - ContentSegPtr := TempSegPtr; - end; - - { Figure out how many bytes to copy. } - BytesToCopy := ffMinL(SegBytesLeft, BytesToGo); - - { Copy. } - Move(BLOBAsBytes^[SrcOffset], ContentSegBlk^[TargetOffset], BytesToCopy); - dec(BytesToGo, BytesToCopy); - inc(SrcOffset, BytesToCopy); - { Update the content length of the lookup entry. We have several cases - to account for: - 1. Write X bytes to empty segment. Length = X. - 2. Suffix X bytes to end of segment containing Y bytes. - Length = X + Y. - 3. Write X bytes to segment containing Y bytes where X <= Y and - (aOffset + X) <= Y. Length = Y. - 4. Write X bytes to segment containing Y bytes where X <= Y and - (aOffset + X) > Y. Length = # untouched bytes + Y. - - These cases are all handled by the following IF statement. - } - if StartBytesUsed + BytesToCopy > LookupEntPtr^.bleContentLength then - LookupEntPtr^.bleContentLength := StartBytesUsed + BytesToCopy - end; - - inc(SegEntNumber); - inc(SegInx); - PrevContentSegPtr := ContentSegPtr; - - { If we're not done, we may need to move to the next lookup header. } - if BytesToGo <> 0 then begin - if SegEntNumber = EntryCount then begin - { We filled all the segments in this segment, move to next one & - reset SegInx} - LookupSegBlk := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - LookupSegPtr^.bshNextSegment, - LookupSegOfs, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(LookupSegBlk, TffInt64(aRelMethod))); - LookupSegPtr := @LookupSegBlk^[LookupSegOfs]; - EntryCount := FFCalcMaxLookupEntries(LookupSegPtr); - LookupEntOfs := LookupSegOfs + sizeof(TffBLOBSegmentHeader); - LookupEntPtr := PffBLOBLookupEntry(@LookupSegBlk^[LookupEntOfs]); - SegEntNumber := 0; - end else begin - LookupEntOfs := LookupEntOfs + sizeof(TffBLOBLookupEntry); - LookupEntPtr := @LookupSegBlk^[LookupEntOfs]; - end; - end; - end; {while} - - if (EndSegInx >= OldEndSeg) then begin - { If newly-sized BLOB extends past old BLOB then add new segments. } - BLOBHeader^.bbhSegCount := OldEndSeg; - while BytesToGo > 0 do begin - - { Figure out how many bytes to copy. } - BytesToCopy := ffMinL(BytesToGo, aFI^.fiMaxSegSize - ffc_BLOBSegmentHeaderSize); - - { Get a new content segment} - SegSize := BytesToCopy + ffc_BLOBSegmentHeaderSize; - ContentSegOfs := aFI^.fiBLOBrscMgr.NewSegment(aFI, aTI, SegSize, SegSize); - - { If exist, update prev segment to point to this new segment. } - if Assigned(ContentSegPtr) then begin - PrevContentSegPtr := ContentSegPtr; - PrevContentSegPtr^.bshNextSegment := ContentSegOfs; - end; - - { Increment the segment count & read in the new content segment. } - inc(BLOBHeader^.bbhSegCount); - ContentSegBlk := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - ContentSegOfs, OffsetInBlock, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(ContentSegBlk, TffInt64(aRelMethod))); - ContentSegPtr := @ContentSegBlk^[OffsetInBlock]; - ContentSegPtr^.bshSignature := ffc_sigBLOBSegContent; - ContentSegPtr^.bshParentBLOB := aBLOBNr; - ContentSegPtr^.bshNextSegment.iLow := ffc_W32NoValue; - - { Get a new lookup entry. } - LookupEntOfs := LookupSegOfs + sizeof(TffBLOBSegmentHeader) + - (SegEntNumber * sizeof(TffBLOBLookupEntry)); - LookupEntPtr := PffBLOBLookupEntry(@LookupSegBlk^[LookupEntOfs]); - LookupEntPtr^.bleSegmentOffset := ContentSegOfs; - LookupEntPtr^.bleContentLength := BytesToCopy; - - { Fill the content segment. } - Move(BLOBAsBytes^[SrcOffset], - ContentSegBlk^[OffsetInBlock + sizeof(TffBLOBSegmentHeader)], - BytesToCopy); - inc(SrcOffset, BytesToCopy); - dec(BytesToGo, BytesToCopy); - inc(SegEntNumber); - - { If we're not done, we may need to move to the next lookup segment. } - if BytesToGo <> 0 then begin - if SegEntNumber = EntryCount then begin - { We filled all the segments in this segment, move to next one & reset - SegEntNumber. } - LookupSegBlk := ReadVfyBlobBlock(aFI, aTI, ffc_MarkDirty, - LookupSegPtr^.bshNextSegment, - LookupSegOfs, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(LookupSegBlk, TffInt64(aRelMethod))); - LookupSegPtr := @LookupSegBlk^[LookupSegOfs]; - EntryCount := FFCalcMaxLookupEntries(LookupSegPtr); - OffsetInBlock := LookupSegOfs + sizeof(TffBLOBSegmentHeader); - SegEntNumber := 0; - end; {if} - end; - end; {while} - end; {if} - - { If the BLOB has grown, we need to update its length. - NOTE: BLOBs can't be truncated via a write operation. } - if (NewSizeW32 > BLOBHeader^.bbhBLOBLength) then - BLOBHeader^.bbhBLOBLength := NewSizeW32; - finally - for OffsetInBlock := 0 to pred(aRelList.Count) do - FFDeallocReleaseInfo(aRelList[OffsetInBlock]); - aRelList.Free; - end; -end; -{====================================================================} -initialization - FFBLOBEngine := TffBLOBEngine.Create; - FF210BLOBEngine := Tff210BLOBEngine.Create; - - {$IFDEF BLOBTrace} - btLog := TffEventLog.Create(nil); - btLog.FileName := 'BLOBTrace.log'; - btLog.Enabled := True; - {$ENDIF} - -finalization - FFBLOBEngine.Free; - FF210BLOBEngine.Free; - - {$IFDEF BLOBTrace} - btLog.Flush; - btLog.Free; - {$ENDIF} - -{End !!.11} -end. diff --git a/components/flashfiler/sourcelaz/fftbcryp.pas b/components/flashfiler/sourcelaz/fftbcryp.pas deleted file mode 100644 index 8bbd3424a..000000000 --- a/components/flashfiler/sourcelaz/fftbcryp.pas +++ /dev/null @@ -1,287 +0,0 @@ -{*********************************************************} -{* FlashFiler: Random number encryption for 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} -{$Q-} -{$R-} - -unit fftbcryp; - -interface - -uses - SysUtils, - ffllbase; - -procedure FFCodeBlock(aBlock : PffByteArray; aBlockLen : TffWord32; aRandomizer : TffWord32); -procedure FFCodeBlockServer(aBlock : PffByteArray; aBlockLen : TffWord32; aRandomizer : TffWord32); -procedure FFDecodeBlock(aBlock : PffByteArray; aBlockLen : TffWord32; aRandomizer : TffWord32); -procedure FFDecodeBlockServer(aBlock : PffByteArray; aBlockLen : TffWord32; aRandomizer : TffWord32); - -implementation - -{Note: we use 4 linear-congruential random number generators. All are - of the form R(N+1) := ((R(N) * ia) + ic) mod im. All have been - chosen so that the intermediate multiplication does not exceed - 2^31, ie, so that it fits in a longint without overflow. These - 4 generators populate a shuffle table, and random numbers are - extracted out of this to supply bytes for an XOR table. It is - this table that is used to encrypt/decrypt a block. - - Random number references: Numerical Recipes in Pascal. - - The seeds for the 4 random number generators are built from - hashes of people's names; just for fun. -} - -const - ffc_CodeBlockLength = 4096; {DO NOT CHANGE: FFCodeBlock is optimised for this value} - ffc_RandTableCount = 55; - -const - im1 = 243000; ia1 = 4561; ic1 = 51349; - im2 = 134456; ia2 = 8121; ic2 = 28411; - im3 = 714025; ia3 = 1366; ic3 =150889; - im4 = 214326; ia4 = 3613; ic4 = 45289; - -const - ffc_Seed1 = 226797638 mod im1; {Elf hash of "gandalf"} - ffc_Seed2 = 127453534 mod im2; {Elf hash of "sauron"} - ffc_Seed3 = 214225708 mod im3; {Elf hash of "rivendell"} - ffc_Seed4 = 99118931 mod im4; {Elf hash of "frodo baggins"} - -type - PffCodeBlock = ^TffCodeBlock; - TffCodeBlock = array [0..pred(ffc_CodeBlockLength)] of byte; - PffRandomTable = ^TffRandomTable; - TffRandomTable = array [0..pred(ffc_RandTableCount)] of TffWord32; - -var - CB : PffCodeBlock; - CBServer : PffCodeBlock; - RT : PffRandomTable; - RTInx : integer; - RTInxStep : integer; - - -{===FFCodeBlock======================================================} -procedure CodeBlockPrim; -register; -asm - {eax => aBlock} - {edx = aBlockLen} - {ecx = aRandomizer value} - {esi => code block} - push ebx - add esi, ffc_CodeBlockLength - and edx, $FFFFFFF0 - add eax, edx - neg edx - mov ebx, ecx - shr ebx, 8 - and ebx, $FF0 - jz @@ResetCode - neg ebx - jmp @@NextLong -@@ResetCode: - mov ebx, ffc_CodeBlockLength - neg ebx -@@NextLong: - mov ecx, [eax+edx] - xor ecx, [esi+ebx] - mov [eax+edx], ecx - add edx, 4 - jz @@Exit - - mov ecx, [eax+edx] - xor ecx, [esi+ebx+4] - mov [eax+edx], ecx - add edx, 4 - jz @@Exit - - mov ecx, [eax+edx] - xor ecx, [esi+ebx+8] - mov [eax+edx], ecx - add edx, 4 - jz @@Exit - - mov ecx, [eax+edx] - xor ecx, [esi+ebx+12] - mov [eax+edx], ecx - add edx, 4 - jz @@Exit - - add ebx, 16 - jnz @@NextLong - jmp @@ResetCode -@@Exit: - pop ebx -end; -{--------} -procedure FFCodeBlock(aBlock : PffByteArray; aBlockLen : TffWord32; aRandomizer : TffWord32); -register; -asm - push esi - mov esi, CB - call CodeBlockPrim - pop esi -end; -{--------} -procedure FFCodeBlockServer(aBlock : PffByteArray; aBlockLen : TffWord32; aRandomizer : TffWord32); -register; -asm - push esi - mov esi, CBServer - call CodeBlockPrim - pop esi -end; -{--------} -procedure FFDecodeBlock(aBlock : PffByteArray; aBlockLen : TffWord32; aRandomizer : TffWord32); -register; -asm - push esi - mov esi, CB - call CodeBlockPrim - pop esi -end; -{--------} -procedure FFDecodeBlockServer(aBlock : PffByteArray; aBlockLen : TffWord32; aRandomizer : TffWord32); -register; -asm - push esi - mov esi, CBServer - call CodeBlockPrim - pop esi -end; -{====================================================================} - - -{===Helper routines==================================================} -function GetRandomByte : byte; -var - LI : LongInt; -begin - inc(RTinx); - if (RTinx = ffc_RandTableCount) then - RTInx := 0; - inc(RTinxStep); - if (RTinxStep = ffc_RandTableCount) then - RTinxStep := 0; - LI := RT^[RTInx] + RT^[RTInxStep]; - RT^[RTInx] := TffWord32(LI); - {use the third byte} - Result := (LI shr 16) and $FF; -end; -{--------} -procedure CalcRandTable; -type - LongAsBytes = array [0..3] of byte; -var - L : LongAsBytes; - LI : longint absolute L; - S1 : longint; - S2 : longint; - S3 : longint; - S4 : longint; - i : integer; -begin - {we use 4 linear-congruential random number generators, each - generates a byte of each longint of the table} - S1 := ffc_Seed1; - S2 := ffc_Seed2; - S3 := ffc_Seed3; - S4 := ffc_Seed4; - for i := 0 to pred(ffc_RandTableCount) do begin - S1 := ((S1 * ia1) + ic1) mod im1; - L[0] := (S1 * 256) div im1; - S2 := ((S2 * ia2) + ic2) mod im2; - L[1] := (S2 * 256) div im2; - S3 := ((S3 * ia3) + ic3) mod im3; - L[2] := (S3 * 256) div im3; - S4 := ((S4 * ia4) + ic4) mod im4; - L[3] := (S4 * 256) div im4; - RT^[i] := LI; - end; - RTInx := 0; - RTInxStep := 31; - {rev the engine a bit} - for i := 0 to pred(ffc_RandTableCount) do begin - GetRandomByte; - end; -end; -{--------} -procedure CalcRandomCodeBuffers; -var - i : integer; -begin - for i := 0 to pred(ffc_CodeBlockLength) do - CB^[i] := GetRandomByte; - for i := 0 to pred(ffc_CodeBlockLength) do - CBServer^[i] := GetRandomByte; -end; -{====================================================================} - - -{===Initialization and finalization==================================} -procedure FinalizeUnit; -begin - if (CB <> nil) then begin - FillChar(CB^, sizeof(CB^), 0); - Dispose(CB); - end; - if (CBServer <> nil) then begin - FillChar(CBServer^, sizeof(CBServer^), 0); - Dispose(CBServer); - end; - if (RT <> nil) then begin - FillChar(RT^, sizeof(RT^), 0); - Dispose(RT); - end; -end; -{--------} -procedure InitializeUnit; -begin - New(CB); - New(CBServer); - New(RT); - {first calculate the table of random longints} - CalcRandTable; - {next set each byte of the random code buffers} - CalcRandomCodeBuffers; -end; -{====================================================================} - - -initialization - InitializeUnit; - -finalization - FinalizeUnit; -end. - diff --git a/components/flashfiler/sourcelaz/fftbdata.pas b/components/flashfiler/sourcelaz/fftbdata.pas deleted file mode 100644 index 351484459..000000000 --- a/components/flashfiler/sourcelaz/fftbdata.pas +++ /dev/null @@ -1,718 +0,0 @@ -{*********************************************************} -{* FlashFiler: Table data access *} -{*********************************************************} - -(* ***** 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} - -{ Enabled the following DEFINE to instantiate an instance of TffEventLog - for debugging purposes. } -{.$DEFINE DebugLog} - -unit fftbdata; - -interface - -uses - Windows, - SysUtils, - ffconst, - ffllbase, - {$IFDEF DebugLog} - fflllog, - {$ENDIF} - ffsrmgr, - ffllexcp, - ffsrbase, - ffsrlock, - fffile, - fftbbase; - - -{$IFDEF DebugLog} -var - aLog : TffBaseLog; -{$ENDIF} - -{---Record maintenance and access---} -procedure FFTblAddRecord(aFI : PffFileInfo; - aTI : PffTransInfo; - var aRefNr : TffInt64; - aRecData : PffByteArray); - {-Add a record to the table} -procedure FFTblDeleteRecord(aFI : PffFileInfo; - aTI : PffTransInfo; - const aRefNr : TffInt64); - {-Delete a record from the table} -procedure FFTblReadNextRecord(aFI : PffFileInfo; - aTI : PffTransInfo; - const aFromRefNr : TffInt64; - var aRefNr : TffInt64; - aRecData : PffByteArray); - {-Read the next record from the table, given the record from which to read. - Note: to read the first record, pass 0 as FromRefNr; 0 is returned if - no further records} -procedure FFTblReadPrevRecord(aFI : PffFileInfo; - aTI : PffTransInfo; - const aFromRefNr : TffInt64; - var aRefNr : TffInt64; - aRecData : PffByteArray); - {-Read the previous record from the table, given the record from which to read. - Note: to read the last record, pass 0 as FromRefNr; 0 is returned if - no further records} -procedure FFTblReadRecord(aFI : PffFileInfo; - aTI : PffTransInfo; - const aRefNr : TffInt64; - aRecData : PffByteArray); - {-Read a record from the table} -procedure FFTblUpdateRecord(aFI : PffFileInfo; - aTI : PffTransInfo; - const aRefNr : TffInt64; - aRecData : PffByteArray); - {-Update a record in the table} - -{---Record information---} -procedure FFTblGetRecordInfo(aFI : PffFileInfo; - aTI : PffTransInfo; - var aInfo : TffRecordInfo); - {-Get information about the records in a table} - -function FFTblNextAutoIncValue(aFI : PffFileInfo; aTI : PffTransInfo) : TffWord32; - {-Return the next autoinc value} -function FFTblReadAutoIncValue(aFI : PffFileInfo; aTI : PffTransInfo) : TffWord32; - {-Return the current autoinc value; this is read-only, it does not modify - the autoinc value. } -procedure FFTblDelAutoIncValue(aFI : PffFileInfo; aTI : PffTransInfo; - aValue : TffWord32); - {-Deletes an autoinc value (if it was the last)} -procedure FFTblSetAutoIncValue(aFI : PffFileInfo; aTI : PffTransInfo; - aValue : TffWord32); - {-Set the starting value for autoinc fields} - - -implementation - -{$IFDEF DebugLog} -procedure Log(aMsg : string; args : array of const); -begin - if aLog <> nil then - aLog.WriteStringFmt(aMsg, args); -end; -{$ENDIF} - -{===Verification routines============================================} -function ReadVfyRefNrDataBlock(FI : PffFileInfo; - TI : PffTransInfo; - const aRefNr : TffInt64; - const aMarkDirty : boolean; - var aOffsetInBlock : Longint; - var aReleaseMethod : TffReleaseMethod) : PffBlock; -var - BlockNumber : TffWord32; - RecordBlock : PffBlock; - TempI64 : TffInt64; - RecBlockHdr : PffBlockHeaderData absolute RecordBlock; -begin - with FI^ do begin - {verify the reference number} - if not FFVerifyRefNr(aRefNr, fiLog2BlockSize, fiRecLenPlusTrailer) then - FFRaiseException(EffServerException, ffStrResServer, fferrBadRefNr, - [FI^.fiName^, aRefNr.iLow, aRefNr.iHigh]); - {now get the record block} - ffShiftI64R(aRefNr, fiLog2BlockSize, TempI64); - BlockNumber := TempI64.iLow; - if (BlockNumber <= 0) or (BlockNumber >= fiUsedBlocks) then - FFRaiseException(EffServerException, ffStrResServer, fferrBadBlockNr, - [FI^.fiName^, BlockNumber]); - ffI64MinusInt(aRefNr, (BlockNumber shl fiLog2BlockSize), TempI64); - aOffsetInBlock := TempI64.iLow; - RecordBlock := FFBMGetBlock(FI, TI, BlockNumber, aMarkDirty, aReleaseMethod); - - {verify that it's a data block} - if (RecBlockHdr^.bhdSignature <> ffc_SigDataBlock) or - (RecBlockHdr^.bhdThisBlock <> BlockNumber) then - FFRaiseException(EffServerException, ffStrResServer, fferrBadDataBlock, - [FI^.fiName^, BlockNumber]); - end; - Result := RecordBlock; -end; -{--------} -function ReadVfyDataBlock(FI : PffFileInfo; - TI : PffTransInfo; - aBlockNumber : TffWord32; - const aMarkDirty : boolean; - var aReleaseMethod : TffReleaseMethod) : PffBlock; -var - RecordBlock : PffBlock; - RecBlockHdr : PffBlockHeaderData absolute RecordBlock; -begin - with FI^ do begin - {verify the block number} - if (aBlockNumber <= 0) or (aBlockNumber >= fiUsedBlocks) then - FFRaiseException(EffServerException, ffStrResServer, fferrBadBlockNr, - [FI^.fiName^, aBlockNumber]); - {now get the record block} - RecordBlock := FFBMGetBlock(FI, TI, aBlockNumber, aMarkDirty, aReleaseMethod); - {verify that it's a data block} - if (RecBlockHdr^.bhdSignature <> ffc_SigDataBlock) or - (RecBlockHdr^.bhdThisBlock <> aBlockNumber) then - FFRaiseException(EffServerException, ffStrResServer, fferrBadDataBlock, - [FI^.fiName^, aBlockNumber]); - end; - Result := RecordBlock; -end; -{====================================================================} - - -{===Helper routines==================================================} -function AddNewDataBlock(FI : PffFileInfo; - TI : PffTransInfo; - FileHeader : PffBlockHeaderFile; - var aOffsetInBlock : Longint; - var aReleaseMethod : TffReleaseMethod) : PffBlock; -var - i : integer; - BlockOffset : TffInt64; - ThisBlock : TffWord32; - ThisLink : TffWord32; - NextLink : TffWord32; - RecordBlock : PffBlock; - RecBlockHdr : PffBlockHeaderData absolute RecordBlock; - PrevRecBlock : PffBlock; - PrevRecBlockHdr : PffBlockHeaderData absolute PrevRecBlock; - TempI64 : TffInt64; - aChainRelMethod : TffReleaseMethod; -begin - { Assumption: File header block obtained for write access. } - - { Note: this routine is only called if bhfDelRecCount = 0} - with FileHeader^ do begin - Assert(bhfDelRecCount = 0); - { Get a new block. } - RecordBlock := FFTblHlpGetNewBlock(FI, TI, aReleaseMethod); - - { Set up the data block header information. } - with RecBlockHdr^ do begin - ThisBlock := bhdThisBlock; - TempI64.iLow := ThisBlock; - TempI64.iHigh := 0; - ffShiftI64L(TempI64, FI^.fiLog2BlockSize, BlockOffset); - bhdSignature := ffc_SigDataBlock; - bhdNextBlock := $FFFFFFFF; - bhdLSN := 0; - bhdRecCount := bhfRecsPerBlock; - bhdRecLength := FI^.fiRecordLength; - bhdNextDataBlock := $FFFFFFFF; - bhdPrevDataBlock := bhfLastDataBlock; - end; - - { Create the deleted record chain in the block. } - aOffsetInBlock := ffc_BlockHeaderSizeData; - ThisLink := ffc_BlockHeaderSizeData; - NextLink := ffc_BlockHeaderSizeData + FI^.fiRecLenPlusTrailer; - for i := 1 to pred(bhfRecsPerBlock) do begin - ffI64AddInt(BlockOffset, NextLink, TempI64); - PByte(@RecordBlock^[ThisLink])^ := $FF; - PffInt64(@RecordBlock^[ThisLink + 1])^ := TempI64; - ThisLink := NextLink; - inc(NextLink, FI^.fiRecLenPlusTrailer); - end; - PByte(@RecordBlock^[ThisLink])^ := $FF; {!!.01} - PffWord32(@RecordBlock^[ThisLink + 1])^ := $FFFFFFFF; - PffWord32(@RecordBlock^[ThisLink + 5])^ := $FFFFFFFF; - - { Attach this chain of deleted records. } - ffI64AddInt(BlockOffset, ffc_BlockHeaderSizeData, bhf1stDelRec); - bhfDelRecCount := bhfRecsPerBlock; - assert(bhfDelRecCount > 0); - - { Attach this block to the chain of data blocks. } - if (bhfLastDataBlock = $FFFFFFFF) then - bhf1stDataBlock := ThisBlock - else begin - PrevRecBlock := ReadVfyDataBlock(FI, TI, bhfLastDataBlock, ffc_MarkDirty, - aChainRelMethod); - PrevRecBlockHdr^.bhdNextDataBlock := ThisBlock; - aChainRelMethod(PrevRecBlock); - end; - bhfLastDataBlock := ThisBlock; - end; - Result := RecordBlock; -end; -{====================================================================} - - -{===Record maintenance===============================================} -procedure FFTblAddRecord(aFI : PffFileInfo; - aTI : PffTransInfo; - var aRefNr : TffInt64; - aRecData : PffByteArray); -var - OffsetInBlock : Longint; - DelLink : PByte; - FileHeader : PffBlockHeaderFile; - RecordBlock : PffBlock; - RecBlockHdr : PffBlockHeaderData absolute RecordBlock; - aFHRelMethod, - aBlkRelMethod : TffReleaseMethod; -begin - { Get the file header block & mark it dirty. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_MarkDirty, - aFHRelMethod)); - with FileHeader^ do - try - { If no deleted records, add new block} - if (bhfDelRecCount = 0) then - RecordBlock := AddNewDataBlock(aFI, aTI, FileHeader, OffsetInBlock, - aBlkRelMethod) - {else read and verify the 1st deleted record's block} - else - RecordBlock := ReadVfyRefNrDataBlock(aFI, aTI, bhf1stDelRec, - ffc_MarkDirty, OffsetInBlock, - aBlkRelMethod); - {mark the first deleted record as active, update the 1st - deleted record reference} - aRefNr := bhf1stDelRec; - DelLink := @(RecordBlock^[OffsetInBlock]); - bhf1stDelRec := PffInt64(@(RecordBlock^[OffsetInBlock + 1]))^; - DelLink^ := 0; - {copy the data from the record into the block} - Move(aRecData^, RecordBlock^[OffsetInBlock + sizeof(byte)], bhfRecordLength); - {decrement the number of deleted records, - increment the number of active records} - inc(bhfRecordCount); - dec(bhfDelRecCount); - aBlkRelMethod(RecordBlock); - finally - aFHRelMethod(PffBlock(FileHeader)); - end; -end; -{--------} -procedure FFTblDeleteRecord(aFI : PffFileInfo; - aTI : PffTransInfo; - const aRefNr : TffInt64); -var - FileHeader : PffBlockHeaderFile; - OffsetInBlock : Longint; - RecordBlock : PffBlock; - RecBlockHdr : PffBlockHeaderData absolute RecordBlock; - DelLink : PByte; - DeletedRecOfs : PffInt64; - TempI64 : TffInt64; - aFHRelMethod, - aBlkRelMethod : TffReleaseMethod; -begin - TempI64.iLow := 0; - TempI64.iHigh := 0; - - { Get an exclusive lock on the file header. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_MarkDirty, - aFHRelMethod)); - with FileHeader^ do - try - {read and verify the record's block} - RecordBlock := ReadVfyRefNrDataBlock(aFI, aTI, aRefNr, true, - OffsetInBlock, aBLKRelMethod); - try - {verify that the record's not already deleted} - DelLink := @RecordBlock^[OffsetInBlock]; - if (DelLink^ = $FF) then - FFRaiseException(EffServerException, ffStrResServer, fferrRecDeleted, - [aFI^.fiName^, aRefNr.iLow, aRefNr.iHigh]); - - {mark this record as the start of the chain} - DelLink^ := $FF; - inc(DelLink, sizeOf(Byte)); - DeletedRecOfs := PffInt64(DelLink); - DeletedRecOfs^ := bhf1stDelRec; - - { Zero out the remainder of the record. } - Inc(DelLink, sizeOf(TffInt64)); - FillChar(DelLink^, aFI^.fiRecordLength - sizeOf(TffInt64), 0); - - {update the 1st deleted record reference} - bhf1stDelRec := aRefNr; - - {increment the number of deleted records, - decrement the number of active records} - inc(bhfDelRecCount); - assert(bhfDelRecCount > 0); - dec(bhfRecordCount); - finally - aBlkRelMethod(RecordBlock); - end; - finally - aFHRelMethod(PffBlock(FileHeader)); - end; -end; -{--------} -procedure FFTblReadNextRecord(aFI : PffFileInfo; - aTI : PffTransInfo; - const aFromRefNr : TffInt64; - var aRefNr : TffInt64; - aRecData : PffByteArray ); -var - FileHeader : PffBlockHeaderFile; - FinalOffset : Longint; - FoundIt : boolean; - NextBlock : TffWord32; - OffsetInBlock : Longint; - RecordBlock : PffBlock; - RecBlockHdr : PffBlockHeaderData absolute RecordBlock; - TempI64 : TffInt64; - ThisBlock : TffWord32; - aFHRelMethod, - aBlkRelMethod : TffReleaseMethod; -begin - {first get the file header, block 0} - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_ReadOnly, - aFHRelMethod)); - with FileHeader^ do - try - {cater for silly case} - if (bhfRecordCount = 0) then begin - ffInitI64(aRefNr); - Exit; - end; - {read and verify the record's block, if reference is not zero} - TempI64.iLow := 0; - TempI64.iHigh := 0; - if (ffCmpI64(aFromRefNr, TempI64) <> 0) then - RecordBlock := ReadVfyRefNrDataBlock(aFI, aTI, aFromRefNr, ffc_ReadOnly, - OffsetInBlock, aBlkRelMethod) - {otherwise, get the first data block} - else begin - ThisBlock := bhf1stDataBlock; - RecordBlock := ReadVfyDataBlock(aFI, aTI, ThisBlock, ffc_ReadOnly, - aBlkRelMethod); - {note: although this calculation of the offset is likely to result in - a negative number, it'll be incremented immediately again} - OffsetInBlock := ffc_BlockHeaderSizeData - aFI^.fiRecLenPlusTrailer; - end; - - try - { Keep reading records and blocks until we've found the next active - record. } - FinalOffset := ffc_BlockHeaderSizeData + - (bhfRecsPerBlock * aFI^.fiRecLenPlusTrailer); - FoundIt := false; - repeat - inc(OffsetInBlock, aFI^.fiRecLenPlusTrailer); - {have we reached the end of this block?} - if (OffsetInBlock >= FinalOffset) then begin - {if there is no next block, break out of loop} - NextBlock := RecBlockHdr^.bhdNextDataBlock; - - if (NextBlock = $FFFFFFFF) then - Break;{out of the repeat..until loop} - - ThisBlock := NextBlock; - { Otherwise read the next block. } - aBlkRelMethod(RecordBlock); - RecordBlock := ReadVfyDataBlock(aFI, aTI, ThisBlock, ffc_ReadOnly, - aBlkRelMethod); - OffsetInBlock := ffc_BlockHeaderSizeData; - end; - if (PShortInt(@RecordBlock^[OffsetInBlock])^ = 0) then - FoundIt := true; - until FoundIt; - if not FoundIt then begin - aRefNr.iLow := 0; - aRefNr.iHigh := 0; - end else begin - TempI64.iLow := RecBlockHdr^.bhdThisBlock; - TempI64.iHigh := 0; - ffShiftI64L(TempI64, aFI^.fiLog2BlockSize, TempI64); - ffI64AddInt(TempI64, OffsetInBlock, aRefNr); - if aRecData <> nil then {!!.01} - Move(RecordBlock^[OffsetInBlock+sizeof(byte)], aRecData^, {!!.01} - aFI^.fiRecordLength); {!!.01} - end; - finally - if RecordBlock <> nil then {!!.13} - aBlkRelMethod(RecordBlock); - end; - finally - aFHRelMethod(PffBlock(FileHeader)); - end; -end; -{--------} -procedure FFTblReadPrevRecord(aFI : PffFileInfo; - aTI : PffTransInfo; - const aFromRefNr : TffInt64; - var aRefNr : TffInt64; - aRecData : PffByteArray ); -var - FileHeader : PffBlockHeaderFile; - FoundIt : boolean; - OffsetInBlock : Longint; - PrevBlock : TffWord32; - RecordBlock : PffBlock; - RecBlockHdr : PffBlockHeaderData absolute RecordBlock; - TempI64 : TffInt64; - aBlkRelMethod, - aFHRelMethod : TffReleaseMethod; -begin - {first get the file header, block 0} - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_ReadOnly, - aFHRelMethod)); - with FileHeader^ do - try - {cater for silly case} - if (bhfRecordCount = 0) then begin - aRefNr.iLow := 0; - aRefNr.iHigh := 0; - Exit; - end; - {read and verify the record's block, if reference is not zero} - TempI64.iLow := 0; - TempI64.iHigh := 0; - if (ffCmpI64(aFromRefNr, TempI64) <> 0) then - RecordBlock := ReadVfyRefNrDataBlock(aFI, aTI, aFromRefNr, ffc_ReadOnly, - OffsetInBlock, aBlkRelMethod) - {otherwise, get the last data block} - else begin - RecordBlock := ReadVfyDataBlock(aFI, aTI, bhfLastDataBlock, - ffc_ReadOnly, aBlkRelMethod); - OffsetInBlock := ffc_BlockHeaderSizeData + - (bhfRecsPerBlock * aFI^.fiRecLenPlusTrailer); - end; - try - { Keep reading records and blocks until we've found the previous active - record. } - FoundIt := False; - repeat - dec(OffsetInBlock, aFI^.fiRecLenPlusTrailer); - {have we reached the end of this block?} - if (OffsetInBlock < ffc_BlockHeaderSizeData) then begin - - PrevBlock := RecBlockHdr^.bhdPrevDataBlock; - {if there is no previous block, break out of loop} - - if (PrevBlock = $FFFFFFFF) then - Break;{out of the repeat..until loop} - - {otherwise read the next block} - aBlkRelMethod(RecordBlock); - RecordBlock := ReadVfyDataBlock(aFI, aTI, PrevBlock, ffc_ReadOnly, - aBlkRelMethod); - OffsetInBlock := ffc_BlockHeaderSizeData + - ((bhfRecsPerBlock - 1) * aFI^.fiRecLenPlusTrailer); {!!.11} - end; - if (PShortInt(@RecordBlock^[OffsetInBlock])^ = 0) then - FoundIt := True; - until FoundIt; - if not FoundIt then begin - aRefNr.iLow := 0; - aRefNr.iHigh := 0 - end else begin - TempI64.iLow := OffsetInBlock; - TempI64.iHigh := 0; - aRefNr := TempI64; - ffI64AddInt(aRefNr, - (RecBlockHdr^.bhdThisBlock shl aFI^.fiLog2BlockSize), - aRefNr); - Move(RecordBlock^[OffsetInBlock+sizeof(byte)], aRecData^, - aFI^.fiRecordLength); - end; - finally - aBlkRelMethod(RecordBlock); - end; - finally - aFHRelMethod(PffBlock(FileHeader)); - end; -end; -{--------} -procedure FFTblReadRecord(aFI : PffFileInfo; - aTI : PffTransInfo; - const aRefNr : TffInt64; - aRecData : PffByteArray); -var - DelLink : PByte; - OffsetInBlock : Longint; - RecordBlock : PffBlock; - RecBlockHdr : PffBlockHeaderData absolute RecordBlock; - aRelMethod : TffReleaseMethod; -begin - with aFI^ do begin - {read and verify the record's block} - RecordBlock := ReadVfyRefNrDataBlock(aFI, aTI, aRefNr, ffc_ReadOnly, - OffsetInBlock, aRelMethod); - try - {verify that the record's not deleted} - DelLink := @RecordBlock^[OffsetInBlock]; - if (DelLink^ <> 0) then - FFRaiseException(EffServerException, ffStrResServer, fferrRecDeleted, - [aFI^.fiName^, aRefNr.iLow, aRefNr.iHigh]); - {copy the record from the block} - Move(RecordBlock^[OffsetInBlock+sizeof(byte)], aRecData^, fiRecordLength); - finally - aRelMethod(RecordBlock); - end; - end; -end; -{--------} -procedure FFTblUpdateRecord(aFI : PffFileInfo; - aTI : PffTransInfo; - const aRefNr : TffInt64; - aRecData : PffByteArray); -var - DelLink : PByte; - OffsetInBlock : Longint; - RecordBlock : PffBlock; - RecBlockHdr : PffBlockHeaderData absolute RecordBlock; - aRelMethod : TffReleaseMethod; -begin - {read and verify the record's block} - RecordBlock := ReadVfyRefNrDataBlock(aFI, aTI, aRefNr, ffc_MarkDirty, - OffsetInBlock, aRelMethod); - try - {verify that the record's not deleted} - DelLink := @RecordBlock^[OffsetInBlock]; - if (DelLink^ <> 0) then - FFRaiseException(EffServerException, ffStrResServer, fferrRecDeleted, - [aFI^.fiName^, aRefNr.iLow, aRefNr.iHigh]); - {copy the record into the block} - Move(aRecData^, RecordBlock^[OffsetInBlock+sizeof(Byte)], aFI^.fiRecordLength); - finally - aRelMethod(RecordBlock); - end; -end; -{====================================================================} - - -{===Record information===============================================} -procedure FFTblGetRecordInfo(aFI : PffFileInfo; - aTI : PffTransInfo; - var aInfo : TffRecordInfo); -var - FileHeader : PffBlockHeaderFile; - aRelMethod : TffReleaseMethod; -begin - { First get the file header, block 0. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_ReadOnly, - aRelMethod)); - { Return the information required. } - with FileHeader^, aInfo do begin - riRecLength := bhfRecordLength; - riRecCount := bhfRecordCount; - riDelRecCount := bhfDelRecCount; - riRecsPerBlock := bhfRecsPerBlock; - end; - - aRelMethod(PffBlock(FileHeader)); -end; -{--------} -function FFTblNextAutoIncValue(aFI : PffFileInfo; aTI : PffTransInfo) : TffWord32; -var - FileHeader : PffBlockHeaderFile; - aRelMethod : TffReleaseMethod; -begin - { Assumption: Transaction started. Transaction committed - or rolled back higher up in the call stack. } - - { First get the file header, block 0. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_MarkDirty, - aRelMethod)); - - { Return the information required. } - with FileHeader^ do begin - Result := succ(bhfAutoIncValue); - bhfAutoIncValue := Result; - end; - - aRelMethod(PffBlock(FileHeader)); -end; -{--------} -function FFTblReadAutoIncValue(aFI : PffFileInfo; aTI : PffTransInfo) : TffWord32; -var - FileHeader : PffBlockHeaderFile; - aRelMethod : TffReleaseMethod; -begin - { Assumption: Transaction started. Transaction committed - or rolled back higher up in the call stack. } - - { First get the file header, block 0. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_ReadOnly, - aRelMethod)); - - { Return the information required. } - Result := FileHeader^.bhfAutoIncValue; - - aRelMethod(PffBlock(FileHeader)); -end; -{--------} -procedure FFTblDelAutoIncValue(aFI : PffFileInfo; aTI : PffTransInfo; - aValue : TffWord32); -var - FileHeader : PffBlockHeaderFile; - aRelMethod : TffReleaseMethod; -begin - { Assumption: Transaction started. } - - { First get the file header, block 0. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_MarkDirty, - aRelMethod)); - - { Return the information required. } - with FileHeader^ do begin - if (aValue = bhfAutoIncValue) then - dec(bhfAutoIncValue); - end; - - aRelMethod(PffBlock(FileHeader)); -end; -{--------} -procedure FFTblSetAutoIncValue(aFI : PffFileInfo; aTI : PffTransInfo; - aValue : TffWord32); -var - FileHeader : PffBlockHeaderFile; - aRelMethod : TffReleaseMethod; -begin - { Assumption: Transaction started. } - - { First get the file header, block 0, mark dirty. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_MarkDirty, - aRelMethod)); - - { Set the new seed value } - FileHeader^.bhfAutoIncValue := aValue; - aRelMethod(PffBlock(FileHeader)); -end; -{====================================================================} - -{$IFDEF DebugLog} -initialization - aLog := TffEventLog.Create(nil); - aLog.FileName := '.\fftbData.log'; - aLog.Enabled := True; - -finalization - aLog.Free; -{$ENDIF} - -end. diff --git a/components/flashfiler/sourcelaz/fftbdict.pas b/components/flashfiler/sourcelaz/fftbdict.pas deleted file mode 100644 index cd6153735..000000000 --- a/components/flashfiler/sourcelaz/fftbdict.pas +++ /dev/null @@ -1,269 +0,0 @@ -{NOTES: - 1. Have verification as optional--IFDEF'd out} - -{*********************************************************} -{* FlashFiler: Table data dictionary access (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 fftbdict; - -interface - -uses - Windows, - SysUtils, - Classes, - ffconst, - ffllbase, - ffsrmgr, - ffllexcp, - fflldict, - ffsrintf, - ffsrbase, - fffile, - ffsrixhl, - fftbbase, - fftbstrm; - - -{---Data dictionary class---} -type - TffServerDataDict = class(TffDataDictionary) - protected {private} - protected - public - procedure ForceOffReadOnly; - {-Make dictionary writable} - procedure ReadFromFile(aFI : PffFileInfo; aTI : PffTransInfo); - {-Read the data dictionary from the file} - procedure WriteToFile(aFI : PffFileInfo; aTI : PffTransInfo); - {-Write the data dictionary to the file - Note: the data dictionary can only be written once} - end; - -{---Compare routine for composite keys---} -function FFKeyCompareComposite(const Key1, Key2; aData : PffCompareData) : integer - stdcall; - {-Treat Key1 and Key2 as composite keys, compare} - - -implementation - -uses - ffsrlock; - - -{===TffServerDataDict================================================} -procedure TffServerDataDict.ForceOffReadOnly; -begin - ddReadOnly := false; -end; -{--------} -procedure TffServerDataDict.ReadFromFile(aFI : PffFileInfo; aTI : PffTransInfo); -var - FileHeader : PffBlockHeaderFile; - S : TMemoryStream; - aRelMethod : TffReleaseMethod; -begin - - { Get the file header, block 0. Assume that we only need the lock for the - duration of this call. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_ReadOnly, - aRelMethod)); - try - { Is there a data dictionary?} - if (FileHeader^.bhfDataDict = 0) then - FFRaiseException(EffServerException, ffStrResServer, fferrDictMissing, - [aFI^.fiName^]); - - { Read the data dictionary from the file via a stream} - S := TMemoryStream.Create; - try - FFTblReadStream(aFI, aTI, FileHeader^.bhfDataDict, S); - S.Seek(0, soFromBeginning); - ReadFromStream(S); - finally - S.Free; - end;{try..finally} - finally - aRelMethod(PffBlock(FileHeader)); - end; - - { Because this method is only called for a pre-existing File group, - that means we cannot alter it any more. } - ddReadOnly := true; -end; -{--------} -procedure TffServerDataDict.WriteToFile(aFI : PffFileInfo; aTI : PffTransInfo); -var - FileHeader : PffBlockHeaderFile; - S : TMemoryStream; - aRelMethod : TffReleaseMethod; -begin - { Verify the data dictionary. } - CheckValid; - - { Get the file header, block 0. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_MarkDirty, - aRelMethod)); - try - { Write the data dictionary to the file via a stream. } - S := TMemoryStream.Create; - try - WriteToStream(S); - FFTblWriteStream(aFI, aTI, FileHeader^.bhfDataDict, S, - (FileHeader^.bhfDataDict = 0), - ffc_SigDictStream); - finally - S.Free; - end;{try..finally} - finally - aRelMethod(PffBlock(FileHeader)); - end; -end; -{====================================================================} - - -{===Composite Key Compare routine====================================} -function FFKeyCompareComposite(const Key1, Key2; aData : PffCompareData) : integer; -var - K1 : TffByteArray absolute Key1; - K2 : TffByteArray absolute Key2; - IndexDesc : PffIndexDescriptor; - FieldDesc : PffFieldDescriptor; - KeyOffset : integer; - FieldNumber : integer; - CurIndex : integer; - CurDict : TffServerDataDict; - CurFldCount : integer; - CurPartLen : integer; - CurKeyLen : integer; - FldCnt : integer; - LenToUse : integer; - CurAscend : boolean; - CurNoCase : boolean; - Fld1Null : boolean; - Fld2Null : boolean; -begin - with aData^ do begin - CurIndex := cdIndex; - CurKeyLen := cdKeyLen; - CurDict := TffServerDataDict(cdDict); - CurFldCount := cdFldCnt; - CurPartLen := cdPartLen; - CurAscend := cdAscend; - CurNoCase := cdNoCase; - end; - - Result := 0; - KeyOffset := 0; - {get the index descriptor} - IndexDesc := CurDict.IndexDescriptor^[CurIndex]; - with IndexDesc^ do begin - {calculate the number of complete fields we can compare} - if (CurFldCount = 0) then - if (CurPartLen = 0) then - FldCnt := idCount - else {partial key} - FldCnt := 0 - else - if (CurPartLen = 0) then - FldCnt := FFMinI(CurFldCount, idCount) - else {partial key} - FldCnt := FFMinI(CurFldCount, pred(idCount)); - - {compare each field in the key until we get a non-zero (ie not - equal) result} - if (FldCnt > 0) then - for FieldNumber := 0 to pred(FldCnt) do begin - Fld1Null := FFIsKeyFieldNull(@K1, CurKeyLen, idCount, FieldNumber); - Fld2Null := FFIsKeyFieldNull(@K2, CurKeyLen, idCount, FieldNumber); - FieldDesc := CurDict.FieldDescriptor^[idFields[FieldNumber]]; - with FieldDesc^ do begin - if Fld1Null then begin - if Fld2Null then - Result := 0 - else - Result := -1; - end - else {Fld1Null is false} begin - if Fld2Null then - Result := 1 - else - Result := FFCheckDescend - (CurAscend, - CurDict.IndexHelpers[CurIndex, FieldNumber].CompareKey(K1[KeyOffset], - K2[KeyOffset], FieldDesc, -1, CurNoCase)); - end; - if (Result = 0) then - inc(KeyOffset, fdLength) - else - Break;{out of for loop} - end; - end; - - {partially compare the last field if required} - if (CurPartLen > 0) then begin - FieldDesc := CurDict.FieldDescriptor^[idFields[FldCnt]]; - with FieldDesc^ do - if (fdType >= fftShortString) then begin - Fld1Null := FFIsKeyFieldNull(@K1, CurKeyLen, idCount, FldCnt); - Fld2Null := FFIsKeyFieldNull(@K2, CurKeyLen, idCount, FldCnt); - if Fld1Null then begin - if Fld2Null then - Result := 0 - else - Result := -1; - end - else {Fld1Null is false} begin - if Fld2Null then - Result := 1 - else begin - if (fdType = fftWideString) then - LenToUse := sizeof(WideChar) * CurPartLen - else if (fdType = fftShortString) or - (fdType = fftShortAnsiStr) then - LenToUse := CurPartLen + 1 - else - LenToUse := CurPartLen; - Result := FFCheckDescend - (CurAscend, - CurDict.IndexHelpers[CurIndex, FldCnt]. - CompareKey(K1[KeyOffset], K2[KeyOffset], FieldDesc, - LenToUse, CurNoCase)); - end; - end; - end; - end; - end; -end; -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/fftbindx.pas b/components/flashfiler/sourcelaz/fftbindx.pas deleted file mode 100644 index d367f6170..000000000 --- a/components/flashfiler/sourcelaz/fftbindx.pas +++ /dev/null @@ -1,3415 +0,0 @@ -{*********************************************************} -{* FlashFiler: Table b-tree index access *} -{*********************************************************} - -(* ***** 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 fftbindx; - -interface - -uses - SysUtils, - ffconst, - ffllbase, - ffsrmgr, - ffllexcp, - ffsrintf, - ffsrbase, - fffile, - ffsrlock, - fftbbase, - fftbdict; - -{$IFDEF FF_DEBUG} -var - FFDEBUG_IndexCounter : record - Splits, - RotateLeftNode, - RotateRightNode, - RotateLeftLeaf, - RotateRightLeaf, - Merge, - SwapNext, - SwapPrev : integer; - end; -{$ENDIF} - -type - PffKeyIndexData = ^TffKeyIndexData; - TffKeyIndexData = record {Data record for key routines} - {must be supplied} - kidFI : PffFileInfo; {..index file} - kidIndex : integer; {..index number} - kidCompare : TffKeyCompareFunc; {..compare routine} - kidCompareData: PffCompareData; {..compare data} - {calculated internally} - kidFileHeader : PffBlockHeaderFile; {..pointer to the index file header} - kidIndexHeader: PffIndexHeader; {..pointer to the index header} - {used elsewhere} - kidIndexType : TffIndexType; {..index type: composite or user-defined} - end; - -type - {Note: an key path is a structure which defines a particular - key in a B-Tree. The path defines the page numbers and the - element numbers into the key arrays in the pages to get to - a particular key. If the position is OnKey then the keypath - points exactly to that key. If the position is OnCrack then - the keypath points to the key that would be retrieved by a - NextKey or a PrevKey operation. - An invalid keypath has an path element count of zero and a - position of Unknown} - TffKeyPathPosition = ( {Possible positions of a keypath..} - kppUnknown, {..unknown} - kppBOF, {..before all keys} - kppOnCrackBefore, {..in between two keys} - kppOnCrackAfter, {..in between two keys} - kppOnKey, {..on a key} - kppEOF); {..after all keys} - TffKeyPathElement = record {An element of a key path} - kpePage : TffWord32; {..the page number} - kpeItem : integer; {..the element number of the key} - end; - PffKeyPath = ^TffKeyPath; - TffKeyPath = record {The key path type} - kpCount : integer; {..number of active elements in the path} - kpPath : array [0..31] of TffKeyPathElement; {..the path} - kpPos : TffKeyPathPosition; {..it's position} - kpLSN : TffWord32; {...LSN of the index map page at the time - we positioned to this record. If the LSN - has changed then our key path is no longer - valid. } - end; - {Note: 32 elements is *ample*, 32 levels in a sparsely populated order 3 - B-Tree would hold 4 billion keys: anyone who creates such a B-Tree - (ie 1Kb keys using a 4Kb block) deserve what they get if they even - could.} - -{---Key path related routines---} -procedure FFInitKeyPath(var aKeyPath : TffKeyPath); -procedure FFSetKeyPathToBOF(var aKeyPath : TffKeyPath); -procedure FFSetKeyPathToEOF(var aKeyPath : TffKeyPath); - - -{---Index related routines--- (NOT THREAD-SAFE)} -procedure FFTblAddIndex(aFI : PffFileInfo; - aTI : PffTransInfo; - aIndex : integer; - aMaxKeyLen : integer; - aAllowDups : boolean; - aKeysAreRefs : boolean); - {-Add an index to a file} -procedure FFTblDeleteIndex(aFI : PffFileInfo; - aTI : PffTransInfo; - aIndex : integer); - {-Delete an index from a file} -procedure FFTblPrepareIndexes(aFI : PffFileInfo; - aTI : PffTransInfo); - {-Prepare a file to contain indexes} - - -{---Key access related routines--- (NOT THREAD-SAFE)} -procedure FFTblDeleteAllKeys(aTI : PffTransInfo; var aIndex : TffKeyIndexData); - {-Delete all keys from an index. - Note: cannot be used inside a transaction--it implements a - low level file update} -function FFTblDeleteKey(const aTI : PffTransInfo; - const aKey : PffByteArray; - const aRefNr : TffInt64; - var aIndex : TffKeyIndexData; - var aBTreeChanged : Boolean) : Boolean; {!!.05} - {-Delete a key/ref from an index} -function FFTblFindKey(var aIndex : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aAction : TffSearchKeyAction) : boolean; - {-Find the given key/ref (or nearby one) in the index, set up the - keypath and the key/ref found, return true; if key/ref not found, - return false and an invalid keypath. Note that if the index allows - dups and the refnr is zero and the key matches, the first matching - key/ref is returned. Note also the keypath is positioned on the - crack for the key/ref in question.} -function FFTblGetApproxPos(var aIndex : TffKeyIndexData; - var aPos : integer; - aTI : PffTransInfo; - const aKeyPath : TffKeyPath) : boolean; - {-Given a valid keypath to key/ref, calculate the approx position of - that key/ref in the b-tree as percentage.} -function FFTblInsertKey(var aIndex : TffKeyIndexData; - const aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray) : boolean; - {-Insert a key/ref into an index} -function FFTblKeyExists(var aIndex : TffKeyIndexData; - const aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray) : boolean; - {-Return true if key/ref exists in index. If the lock duration is - ffldShort then index locks are released once this method has finished - using the index pages. } -function FFTblNextKey(var aIndex : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath) : boolean; - {-Given a keypath, find the next key/ref in the index, set up the - keypath and key/ref to it, return true; if no next key, return - false and set keypath to EOF} -function FFTblPrevKey(var aIndex : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath) : boolean; - {-Given a keypath, find the previous key/ref in the index, set up - the keypath and key/ref to it, return true; if no previous key, - return false and set keypath to BOF} -function FFTblSetApproxPos(var aIndex : TffKeyIndexData; - aPos : integer; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath) : boolean; - {-Set the keypath to the approximate position given by aPos (a percentage), - return true and the key/ref if able to, return false if not. The returned - keypath will have length 2, unless the b-tree only consists of the root - page, in which case it will be length 1. - - Note: All index pages accessed by this method are Share locked for duration - ffldCommit.} - -implementation - -{Notes: to optimize disk space, there are four types of btree pages: - A: standard keys, node page - B: standard keys, leaf page - C: record reference number keys, node page - D: record reference number keys, leaf page - They have a dynamic (ie not static) format that depends on the - block size of the file and the length of the keys. Ignoring - the block header, in hand-waving terms the format of each - block is as follows: - A: an array of page numbers (32 bits, 4 bytes each), - followed by an array of reference numbers (64 bits, 8 - bytes each), followed by an array of keys (variable - length). All arrays have the same number of elements. The - "page before all keys" number is stored in the block - header. - B: an array of reference numbers (64 bits, 8 bytes each), - followed by an array of keys (variable length). Both - arrays have the same number of elements. - C: an array of page numbers (32 bits, 4 bytes each), - followed by an array of reference numbers (64 bits, 8 - bytes each). Both arrays have the same number of - elements. The "page before all keys" number is stored in - the block header. The reference numbers are the keys. - D: an array of reference numbers (64 bits, 8 bytes each). - The reference numbers are the keys. - The number of elements in the arrays MUST be odd because of - the btree algorithm used. To calculate the number of elements - in each array (the example values shown refer to a 4KB block - with key length 20): - A: take the block size, subtract the size of the header, - divide by [sizeof(page number) + sizeof(ref number) + key - length]. If not odd, subtract 1. - Example: (4096 - 32) / (4 + 8 + 20) = 127 - B: take the block size, subtract the size of the header, - divide by [sizeof(ref number) + key length]. If not odd, - subtract 1. - Example: (4096 - 32) / (8 + 20) = 145 - C: take the block size, subtract the size of the header, - divide by [sizeof(page number) + sizeof(ref number)]. If - not odd, subtract 1. - Example: (4096 - 32) / (4 + 8) = 338; minus 1 = 337 - D: take the block size, subtract the size of the header, - divide by sizeof(ref number). If not odd, subtract 1. - Example: (4096 - 32) / 8 = 508; minus 1 = 507 - - References: - File Structures, Zoellick & Folk, Addison Wesley - Introduction to Algorithms, Cormen, etc., McGraw-Hill - Data Structures, Algorithms, and Performance, Wood, Addison Wesley - - Although the algorithm used here can be found in the above - references, the data structures used are original.} - -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; - -{===Helper routines==================================================} -function GetNewInxHeaderBlock(aFI : PffFileInfo; - aTI : PffTransInfo; - var aReleaseMethod : TffReleaseMethod ) : PffBlock; - {-Return a new index header block, pre-mark as dirty} -var - InxBlockHdr : PffBlockHeaderIndex absolute Result; - InxHeader : PffIndexHeader; -begin - Result := FFTblHlpGetNewBlock(aFI, aTI, aReleaseMethod); - with InxBlockHdr^ do begin - bhiSignature := ffc_SigIndexBlock; - bhiNextBlock := ffc_W32NoValue; - bhiLSN := 0; - bhiBlockType := ffc_InxBlockTypeHeader; - bhiIsLeafPage := false; {not used in header} - bhiNodeLevel := 0; {not used in header} - bhiKeysAreRefs := false; {not used in header} - bhiIndexNum := $FFFF; {not used in header} - bhiKeyLength := 0; {not used in header} - bhiKeyCount := 0; {not used in header} - bhiMaxKeyCount := 0; {not used in header} - bhiPrevPageRef := ffc_W32NoValue; {not used in header} - end; - InxHeader := PffIndexHeader(@Result^[ffc_BlockHeaderSizeIndex]); - FillChar(InxHeader^, sizeof(TffIndexHeader), 0); -end; -{--------} -function GetNewInxBtreeBlock(aFI : PffFileInfo; - aTI : PffTransInfo; - aIndexHeader : PffIndexHeader; - aIndex : integer; - aIsLeaf : boolean; - var aReleaseMethod : TffReleaseMethod) : PffBlock; - {-Return a new index btree node/leaf block, pre-mark as dirty} -var - InxBlockHdr : PffBlockHeaderIndex absolute Result; -begin - Result := FFTblHlpGetNewBlock(aFI, aTI, aReleaseMethod); - with InxBlockHdr^, aIndexHeader^ do begin - bhiSignature := ffc_SigIndexBlock; - bhiNextBlock := ffc_W32NoValue; - bhiBlockType := ffc_InxBlockTypeBtreePage; - bhiIsLeafPage := aIsLeaf; - if aIsLeaf then - bhiNodeLevel := 1 {leaves are at level 1} - else - bhiNodeLevel := 0; {ie haven't a clue at present} - bhiKeysAreRefs := (bihIndexFlags[aIndex] and ffc_InxFlagKeysAreRefs) <> 0; - bhiIndexNum := aIndex; - bhiKeyLength := bihIndexKeyLen[aIndex]; - bhiKeyCount := 0; - if aIsLeaf then - if bhiKeysAreRefs then - bhiMaxKeyCount := - (aFI^.fiBlockSize - ffc_BlockHeaderSizeIndex) - div (SizeOfRef) - else - bhiMaxKeyCount := - (aFI^.fiBlockSize - ffc_BlockHeaderSizeIndex) - div (bhiKeyLength + SizeOfRef) - else {it's a node} - if bhiKeysAreRefs then - bhiMaxKeyCount := - (aFI^.fiBlockSize - ffc_BlockHeaderSizeIndex) - div (SizeOfPageNum + SizeOfRef) - else - bhiMaxKeyCount := - (aFI^.fiBlockSize - ffc_BlockHeaderSizeIndex) - div (bhiKeyLength + SizeOfPageNum + SizeOfRef); - if not Odd(bhiMaxKeyCount) then - dec(bhiMaxKeyCount); - bhiPrevPageRef := ffc_W32NoValue; - inc(bihIndexPageCount[aIndex]); - end; -end; -{--------} -function ReadVfyInxBlock(aFI : PffFileInfo; - aTI : PffTransInfo; - aFileHeader : PffBlockHeaderFile; - const aMarkDirty : boolean; - const aBlockType : integer; - const aBlockNumber : TffWord32; - var aReleaseMethod : TffReleaseMethod) : PffBlock; -var - InxBlockHdr : PffBlockHeaderIndex absolute Result; -begin - with aFileHeader^ do begin - {verify the block number} - if (aBlockNumber <= 0) or (aBlockNumber >= bhfUsedBlocks) then - FFRaiseException(EffServerException, ffStrResServer, fferrBadBlockNr, - [aFI^.fiName^, aBlockNumber]); - {now get the record block; note: mark header block as fixed} - Result := FFBMGetBlock(aFI, aTI, aBlockNumber, aMarkDirty, aReleaseMethod); - {verify that it's an index block} - if (InxBlockHdr^.bhiSignature <> ffc_SigIndexBlock) or - (InxBlockHdr^.bhiThisBlock <> aBlockNumber) or - (InxBlockHdr^.bhiBlockType <> aBlockType) then - FFRaiseException(EffServerException, ffStrResServer, fferrBadInxBlock, - [aFI^.fiName^, aBlockNumber]); - end; -end; -{====================================================================} - - -{===Key rotation routines============================================} -procedure RotateLeftLeaf(aParentPage : PffBlock; - aSeparator : Longint; - aChildLeft : PffBlock; - aChildRight : PffBlock); - {-Rotate keys from right leaf child to left leaf child through key in - parent given by separator index. Equalise number of keys} -var - ParentPageHdr : PffBlockHeaderIndex absolute aParentPage; - ChildLeftHdr : PffBlockHeaderIndex absolute aChildLeft; - ChildRightHdr : PffBlockHeaderIndex absolute aChildRight; - KeysToMove : Longint; - OffsetL : Longint; - OffsetR : Longint; - OffsetP : Longint; - BytesToMove : Longint; -begin - {Assumptions: all relevant pages have been marked dirty} - {$IFDEF FF_DEBUG} - inc(FFDEBUG_IndexCounter.RotateLeftLeaf); - {$ENDIF} - {calculate the number of keys to move, this means that the right child - will *lose* this number of keys and the left child will *gain* this - number} - KeysToMove := (ChildRightHdr^.bhiKeyCount - ChildLeftHdr^.bhiKeyCount) div 2; - if (KeysToMove = 0) then - inc(KeysToMove); - {move the first pred(KeysToMove) keys from the right child to the last - pred(KeysToMove) places of the left child, the last key of all comes - from/goes to the parent} - with ChildLeftHdr^ do begin - {move the reference numbers} - OffsetL := ffc_BlockHeaderSizeIndex + - (bhiKeyCount * SizeOfRef); - OffsetR := ffc_BlockHeaderSizeIndex; - OffsetP := ffc_BlockHeaderSizeIndex + - (ParentPageHdr^.bhiMaxKeyCount * SizeOfPageNum) + - (aSeparator * SizeOfRef); - {..move parent ref} - PRef(@aChildLeft^[OffsetL])^ := PRef(@aParentPage^[OffsetP])^; - {..move first set of refs} - BytesToMove := pred(KeysToMove) * SizeOfRef; - Move(aChildRight^[OffsetR], - aChildLeft^[OffsetL + SizeOfRef], - BytesToMove); - {..set parent ref} - PRef(@aParentPage^[OffsetP])^ := - PRef(@aChildRight^[OffsetR + BytesToMove])^; - {..close up the gap} - BytesToMove := (ChildRightHdr^.bhiKeyCount - KeysToMove) * SizeOfRef; - Move(aChildRight^[OffsetR + (KeysToMove * SizeOfRef)], - aChildRight^[OffsetR], - BytesToMove); - {if keys are separate entities, move the keys} - if not bhiKeysAreRefs then begin - {move the keys} - OffsetL := ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfRef) + - (bhiKeyCount * bhiKeyLength); - OffsetR := ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfRef); - OffsetP := ffc_BlockHeaderSizeIndex + - (ParentPageHdr^.bhiMaxKeyCount * - (SizeOfPageNum + SizeOfRef)) + - (aSeparator * bhiKeyLength); - {..move parent key} - Move(aParentPage^[OffsetP], - aChildLeft^[OffsetL], - bhiKeyLength); - {..move first set of keys} - BytesToMove := pred(KeysToMove) * bhiKeyLength; - Move(aChildRight^[OffsetR], - aChildLeft^[OffsetL + bhiKeyLength], - BytesToMove); - {..set parent key} - Move(aChildRight^[OffsetR + BytesToMove], - aParentPage^[OffsetP], - bhiKeyLength); - {..close up the gap} - BytesToMove := (ChildRightHdr^.bhiKeyCount - KeysToMove) * bhiKeyLength; - Move(aChildRight^[OffsetR + (KeysToMove * bhiKeyLength)], - aChildRight^[OffsetR], - BytesToMove); - end; - end; - {Update the key counts} - inc(ChildLeftHdr^.bhiKeyCount, KeysToMove); - dec(ChildRightHdr^.bhiKeyCount, KeysToMove); -end; -{--------} -procedure RotateLeftNode(aParentPage : PffBlock; - aSeparator : Longint; - aChildLeft : PffBlock; - aChildRight : PffBlock); - {-Rotate keys from right node child to left node child through key in - parent given by separator index. Equalise number of keys} -var - ParentPageHdr : PffBlockHeaderIndex absolute aParentPage; - ChildLeftHdr : PffBlockHeaderIndex absolute aChildLeft; - ChildRightHdr : PffBlockHeaderIndex absolute aChildRight; - KeysToMove : Longint; - OffsetL : Longint; - OffsetR : Longint; - OffsetP : Longint; - BytesToMove : Longint; -begin - {Assumptions: all relevant pages have been marked dirty} - {$IFDEF FF_DEBUG} - inc(FFDEBUG_IndexCounter.RotateLeftNode); - {$ENDIF} - {calculate the number of keys to move, this means that the right child - will *lose* this number of keys and the left child will *gain* this - number} - KeysToMove := (ChildRightHdr^.bhiKeyCount - ChildLeftHdr^.bhiKeyCount) div 2; - if (KeysToMove = 0) then - inc(KeysToMove); - {move the first pred(KeysToMove) keys from the right child to the last - pred(KeysToMove) places of the left child, the last key of all comes - from/goes to the parent} - with ChildLeftHdr^ do begin - {move the page numbers} - OffsetL := ffc_BlockHeaderSizeIndex + - (bhiKeyCount * SizeOfPageNum); - OffsetR := ffc_BlockHeaderSizeIndex; - {..move set of page numbers} - BytesToMove := KeysToMove * SizeOfPageNum; - Move(aChildRight^[OffsetR - SizeOfPageNum], - aChildLeft^[OffsetL], - BytesToMove); - {..close up the gap} - BytesToMove := succ(ChildRightHdr^.bhiKeyCount - KeysToMove) * SizeOfPageNum; - Move(aChildRight^[OffsetR + (pred(KeysToMove) * SizeOfPageNum)], - aChildRight^[OffsetR - SizeOfPageNum], - BytesToMove); - {move the data reference numbers} - OffsetL := ffc_BlockHeaderSizeIndex + - ((bhiMaxKeyCount * SizeOfPageNum) + (bhiKeyCount * SizeOfRef)); - OffsetR := ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfPageNum); - OffsetP := ffc_BlockHeaderSizeIndex + - (ParentPageHdr^.bhiMaxKeyCount * SizeOfPageNum) + (aSeparator * SizeOfRef); - {..move parent ref} - PRef(@aChildLeft^[OffsetL])^ := PRef(@aParentPage^[OffsetP])^; - {..move first set of refs} - BytesToMove := pred(KeysToMove) * SizeOfRef; - Move(aChildRight^[OffsetR], - aChildLeft^[OffsetL + SizeOfRef], - BytesToMove); - {..set parent ref} - PRef(@aParentPage^[OffsetP])^ := - PRef(@aChildRight^[OffsetR + BytesToMove])^; - {..close up the gap} - BytesToMove := (ChildRightHdr^.bhiKeyCount - KeysToMove) * SizeOfRef; - Move(aChildRight^[OffsetR + (KeysToMove * SizeOfRef)], - aChildRight^[OffsetR], - BytesToMove); - {if keys are separate entities, move the keys} - if not bhiKeysAreRefs then begin - {move the keys} - OffsetL := ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef) + - (bhiKeyCount * bhiKeyLength)); - OffsetR := ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef)); - OffsetP := ffc_BlockHeaderSizeIndex + - (ParentPageHdr^.bhiMaxKeyCount * (SizeOfRef + SizeOfPageNum)) + - (aSeparator * bhiKeyLength); - {..move parent key} - Move(aParentPage^[OffsetP], - aChildLeft^[OffsetL], - bhiKeyLength); - {..move first set of keys} - BytesToMove := pred(KeysToMove) * bhiKeyLength; - Move(aChildRight^[OffsetR], - aChildLeft^[OffsetL + bhiKeyLength], - BytesToMove); - {..set parent key} - Move(aChildRight^[OffsetR + BytesToMove], - aParentPage^[OffsetP], - bhiKeyLength); - {..close up the gap} - BytesToMove := (ChildRightHdr^.bhiKeyCount - KeysToMove) * bhiKeyLength; - Move(aChildRight^[OffsetR + (KeysToMove * bhiKeyLength)], - aChildRight^[OffsetR], - BytesToMove); - end; - end; - {Update the key counts} - inc(ChildLeftHdr^.bhiKeyCount, KeysToMove); - dec(ChildRightHdr^.bhiKeyCount, KeysToMove); -end; -{--------} -procedure RotateRightLeaf(aParentPage : PffBlock; - aSeparator : Longint; - aChildLeft : PffBlock; - aChildRight : PffBlock); - {-Rotate keys from left leaf child to right leaf child through key in - parent given by separator index. Equalise number of keys} -var - ParentPageHdr : PffBlockHeaderIndex absolute aParentPage; - ChildLeftHdr : PffBlockHeaderIndex absolute aChildLeft; - ChildRightHdr : PffBlockHeaderIndex absolute aChildRight; - KeysToMove : Longint; - OffsetL : Longint; - OffsetR : Longint; - OffsetP : Longint; - BytesToMove : Longint; -begin - {Assumptions: all relevant pages have been marked dirty} - {$IFDEF FF_DEBUG} - inc(FFDEBUG_IndexCounter.RotateRightLeaf); - {$ENDIF} - {calculate the number of keys to move, this means that the left child - will *lose* this number of keys and the right child will *gain* this - number} - KeysToMove := (ChildLeftHdr^.bhiKeyCount - ChildRightHdr^.bhiKeyCount) div 2; - if (KeysToMove = 0) then - inc(KeysToMove); - {open up enough room in the right child for these keys, and move - the last pred(KeysToMove) keys from the left child to the first - pred(KeysToMove) places, the last key of all comes from/goes to - the parent} - with ChildRightHdr^ do begin - {move the reference numbers} - OffsetR := ffc_BlockHeaderSizeIndex; - OffsetL := ffc_BlockHeaderSizeIndex + - (ChildLeftHdr^.bhiKeyCount - KeysToMove) * SizeOfRef; - OffsetP := ffc_BlockHeaderSizeIndex + - (ParentPageHdr^.bhiMaxKeyCount * SizeOfPageNum) + - (aSeparator * SizeOfRef); - {..open up space} - BytesToMove := bhiKeyCount * SizeOfRef; - Move(aChildRight^[OffsetR], - aChildRight^[OffsetR + (KeysToMove * SizeOfRef)], - BytesToMove); - {..move last set of refs} - BytesToMove := pred(KeysToMove) * SizeOfRef; - Move(aChildLeft^[OffsetL + SizeOfRef], - aChildRight^[OffsetR], - BytesToMove); - {..move parent ref} - PRef(@aChildRight^[OffsetR + BytesToMove])^ := - PRef(@aParentPage^[OffsetP])^; - {..move to parent ref} - PRef(@aParentPage^[OffsetP])^ := PRef(@aChildLeft^[OffsetL])^; - {if keys are separate entities, move the keys} - if not bhiKeysAreRefs then begin - {move the keys} - OffsetR := ffc_BlockHeaderSizeIndex + (bhiMaxKeyCount * SizeOfRef); - OffsetL := ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfRef) + - (ChildLeftHdr^.bhiKeyCount - KeysToMove) * bhiKeyLength; - OffsetP := ffc_BlockHeaderSizeIndex + - (ParentPageHdr^.bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef)) + - (aSeparator * bhiKeyLength); - {..open up space} - BytesToMove := bhiKeyCount * bhiKeyLength; - Move(aChildRight^[OffsetR], - aChildRight^[OffsetR + (KeysToMove * bhiKeyLength)], - BytesToMove); - {..move last set of keys} - BytesToMove := pred(KeysToMove) * bhiKeyLength; -{Start !!.01} -// if BytesToMove > 0 then begin - Move(aChildLeft^[OffsetL + bhiKeyLength], - aChildRight^[OffsetR], - BytesToMove); - {..move parent key} - Move(aParentPage^[OffsetP], - aChildRight^[OffsetR + BytesToMove], - bhiKeyLength); -// end; -{End !!.01} - {..move to parent key} - Move(aChildLeft^[OffsetL], - aParentPage^[OffsetP], - bhiKeyLength); - end; - end; - {Update the key counts} - dec(ChildLeftHdr^.bhiKeyCount, KeysToMove); - inc(ChildRightHdr^.bhiKeyCount, KeysToMove); -end; -{--------} -procedure RotateRightNode(aParentPage : PffBlock; - aSeparator : Longint; - aChildLeft : PffBlock; - aChildRight : PffBlock); - {-Rotate keys from left node child to right node child through key in - parent given by separator index. Equalise number of keys} -var - ParentPageHdr : PffBlockHeaderIndex absolute aParentPage; - ChildLeftHdr : PffBlockHeaderIndex absolute aChildLeft; - ChildRightHdr : PffBlockHeaderIndex absolute aChildRight; - KeysToMove : Longint; - OffsetL : Longint; - OffsetR : Longint; - OffsetP : Longint; - BytesToMove : Longint; -begin - {Assumptions: all relevant pages have been marked dirty} - {$IFDEF FF_DEBUG} - inc(FFDEBUG_IndexCounter.RotateRightNode); - {$ENDIF} - {calculate the number of keys to move, this means that the left child - will *lose* this number of keys and the right child will *gain* this - number} - KeysToMove := (ChildLeftHdr^.bhiKeyCount - ChildRightHdr^.bhiKeyCount) div 2; - if (KeysToMove = 0) then - inc(KeysToMove); - {open up enough room in the right child for these keys, and move - the last pred(KeysToMove) keys from the left child to the first - pred(KeysToMove) places, the last key of all comes from/goes to - the parent} - with ChildRightHdr^ do begin - {move the page numbers} - OffsetR := ffc_BlockHeaderSizeIndex; - OffsetL := ffc_BlockHeaderSizeIndex + - (ChildLeftHdr^.bhiKeyCount - KeysToMove) * SizeOfPageNum; - {..open up space} - BytesToMove := succ(bhiKeyCount) * SizeOfPageNum; - Move(aChildRight^[OffsetR - SizeOfPageNum], - aChildRight^[OffsetR + (pred(KeysToMove) * SizeOfPageNum)], - BytesToMove); - {..move set of page numbers} - BytesToMove := KeysToMove * SizeOfPageNum; - Move(aChildLeft^[OffsetL], - aChildRight^[OffsetR - SizeOfPageNum], - BytesToMove); - - {move the data reference numbers} - OffsetR := ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfPageNum); - OffsetL := ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfPageNum) + - (ChildLeftHdr^.bhiKeyCount - KeysToMove) * SizeOfRef; - OffsetP := ffc_BlockHeaderSizeIndex + - (ParentPageHdr^.bhiMaxKeyCount * SizeOfPageNum) + - (aSeparator * SizeOfRef); - {..open up space} - BytesToMove := bhiKeyCount * SizeOfRef; - Move(aChildRight^[OffsetR], - aChildRight^[OffsetR + (KeysToMove * SizeOfRef)], - BytesToMove); - {..move last set of refs} - BytesToMove := pred(KeysToMove) * SizeOfRef; - Move(aChildLeft^[OffsetL + SizeOfRef], - aChildRight^[OffsetR], - BytesToMove); - {..move parent ref} - PRef(@aChildRight^[OffsetR + BytesToMove])^ := - PRef(@aParentPage^[OffsetP])^; - {..move to parent ref} - PRef(@aParentPage^[OffsetP])^ := PRef(@aChildLeft^[OffsetL])^; - {if keys are separate entities, move the keys} - if not bhiKeysAreRefs then begin - {move the keys} - OffsetR := ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef)); - OffsetL := ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef)) + - (ChildLeftHdr^.bhiKeyCount - KeysToMove) * bhiKeyLength; - OffsetP := ffc_BlockHeaderSizeIndex + - (ParentPageHdr^.bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef)) + - (aSeparator * bhiKeyLength); - {..open up space} - BytesToMove := bhiKeyCount * bhiKeyLength; - Move(aChildRight^[OffsetR], - aChildRight^[OffsetR + (KeysToMove * bhiKeyLength)], - BytesToMove); - {..move last set of keys} - BytesToMove := pred(KeysToMove) * bhiKeyLength; - Move(aChildLeft^[OffsetL + bhiKeyLength], - aChildRight^[OffsetR], - BytesToMove); - {..move parent key} - Move(aParentPage^[OffsetP], - aChildRight^[OffsetR + BytesToMove], - bhiKeyLength); - {..move to parent key} - Move(aChildLeft^[OffsetL], - aParentPage^[OffsetP], - bhiKeyLength); - end; - end; - {Update the key counts} - dec(ChildLeftHdr^.bhiKeyCount, KeysToMove); - inc(ChildRightHdr^.bhiKeyCount, KeysToMove); -end; -{====================================================================} - - -{===Key insertion into/deletion from/swapping pages==================} -procedure InsertKeyInLeafPage(aLeaf : PffBlock; - aElement : Longint; - aKey : PffByteArray; - const aRefNr : TffInt64); -var - LeafHeader: PffBlockHeaderIndex absolute aLeaf; - RefBlock : PRefBlock; - KeyBlock : PffByteArray; - Offset : integer; -begin - {Assumptions: aLeaf has been marked dirty} - with LeafHeader^ do begin - {get the address of the reference block} - RefBlock := PRefBlock(@aLeaf^[ffc_BlockHeaderSizeIndex]); - {open up room to insert the new reference} - Move(RefBlock^[aElement], RefBlock^[succ(aElement)], - SizeOfRef * (bhiKeyCount - aElement)); - {insert the new reference} - RefBlock^[aElement] := aRefNr; - {if keys are separate entities, insert into key block} - if not LeafHeader^.bhiKeysAreRefs then begin - {get the address of the keyblock} - KeyBlock := - PffByteArray(@aLeaf^[ffc_BlockHeaderSizeIndex + (bhiMaxKeyCount * SizeOfRef)]); - {open up room to insert the new key} - Offset := aElement * bhiKeyLength; - Move(KeyBlock^[Offset], KeyBlock^[Offset + bhiKeyLength], - bhiKeyLength * (bhiKeyCount - aElement)); - {insert the new key} - Move(aKey^, KeyBlock^[Offset], bhiKeyLength); - end; - {increment the number of keys} - inc(bhiKeyCount); - end; -end; -{--------} -procedure InsertKeyInNodePage(aNode : PffBlock; - aElement : Longint; - aKey : PffByteArray; - const aRefNr : TffInt64; - aChild : TffWord32); -var - NodeHeader: PffBlockHeaderIndex absolute aNode; - PageBlock : PPageNumBlock; - RefBlock : PRefBlock; - KeyBlock : PffByteArray; - Offset : integer; -begin - {Assumptions: aNode has been marked dirty} - with NodeHeader^ do begin - {get the address of the page number block} - PageBlock := PPageNumBlock(@aNode^[ffc_BlockHeaderSizeIndex]); - {open up room to insert the new reference} - Move(PageBlock^[aElement], PageBlock^[succ(aElement)], - SizeOfPageNum * (bhiKeyCount - aElement)); - {insert the new page number} - PageBlock^[aElement] := aChild; - {get the address of the data reference block} - RefBlock := - PRefBlock(@aNode^[ffc_BlockHeaderSizeIndex + (bhiMaxKeyCount * SizeOfPageNum)]); - {open up room to insert the new reference} - Move(RefBlock^[aElement], RefBlock^[succ(aElement)], - SizeOfRef * (bhiKeyCount - aElement)); - {insert the new reference} - RefBlock^[aElement] := aRefNr; - {if keys are separate entities, insert into key block} - if not bhiKeysAreRefs then begin - {get the address of the keyblock} - KeyBlock := - PffByteArray(@aNode^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef))]); - {open up room to insert the new key} - Offset := aElement * bhiKeyLength; - Move(KeyBlock^[Offset], KeyBlock^[Offset + bhiKeyLength], - bhiKeyLength * (bhiKeyCount - aElement)); - {insert the new key} - Move(aKey^, KeyBlock^[Offset], bhiKeyLength); - end; - {increment the number of keys} - inc(bhiKeyCount); - end; -end; -{--------} -procedure RemoveKeyFromLeafPage(aLeaf : PffBlock; - aElement : Longint); -var - LeafHeader: PffBlockHeaderIndex absolute aLeaf; - RefBlock : PRefBlock; - KeyBlock : PffByteArray; - Offset : integer; -begin - { Assumption: We have Exclusively locked aLeaf. } - with LeafHeader^ do begin - {decrement the key count} - dec(bhiKeyCount); - {get the address of the data reference block} - RefBlock := PRefBlock(@aLeaf^[ffc_BlockHeaderSizeIndex]); - {close up to delete the reference} - Move(RefBlock^[succ(aElement)], RefBlock^[aElement], - SizeOfRef * (bhiKeyCount - aElement)); - {if keys are separate entities, delete from key block} - if not LeafHeader^.bhiKeysAreRefs then begin - {get the address of the key block} - KeyBlock := - PffByteArray(@aLeaf^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfRef)]); - {close up to delete the key} - Offset := aElement * bhiKeyLength; - Move(KeyBlock^[Offset+bhiKeyLength], KeyBlock^[Offset], - bhiKeyLength * (bhiKeyCount - aElement)); - end; - end; -end; -{--------} -procedure RemoveKeyFromNodePage(aNode : PffBlock; - aElement : Longint); -var - NodeHeader: PffBlockHeaderIndex absolute aNode; - PageBlock : PPageNumBlock; - RefBlock : PRefBlock; - KeyBlock : PffByteArray; - Offset : integer; -begin - {Assumptions: aNode has been marked dirty} - with NodeHeader^ do begin - {decrement the key count} - dec(bhiKeyCount); - {get the address of the page number block} - PageBlock := PPageNumBlock(@aNode^[ffc_BlockHeaderSizeIndex]); - {close up to delete the page number} - Move(PageBlock^[succ(aElement)], PageBlock^[aElement], - SizeOfPageNum * (bhiKeyCount - aElement)); - {get the address of the data reference block} - RefBlock := - PRefBlock(@aNode^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfPageNum)]); - {close up to delete the reference} - Move(RefBlock^[succ(aElement)], RefBlock^[aElement], - SizeOfRef * (bhiKeyCount - aElement)); - {if keys are separate entities, delete from key block} - if not bhiKeysAreRefs then begin - {get the address of the key block} - KeyBlock := - PffByteArray(@aNode^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef))]); - {close up to delete the key} - Offset := aElement * bhiKeyLength; - Move(KeyBlock^[Offset+bhiKeyLength], KeyBlock^[Offset], - bhiKeyLength * (bhiKeyCount - aElement)); - end; - end; -end; -{--------} -procedure SwapKeys(aNode : PffBlock; - aNElement : Longint; - aLeaf : PffBlock; - aLElement : Longint; - aKey : PffByteArray); - {-Swap the key at aNElement in aNode with that at aLElement in aLeaf} -var - NodeHdr : PffBlockHeaderIndex absolute aNode; - LeafHdr : PffBlockHeaderIndex absolute aLeaf; - OffsetN : Longint; - OffsetL : Longint; - Temp : TffInt64; -begin - {Assumptions: aNode, aLeaf have been marked dirty; the key at - aNElement in aNode compares equal to aKey} - with NodeHdr^ do begin - {swap references} - OffsetN := ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfPageNum) + - (aNElement * SizeOfRef); - OffsetL := ffc_BlockHeaderSizeIndex + - (aLElement * SizeOfRef); - Temp := PRef(@aNode^[OffsetN])^; - PRef(@aNode^[OffsetN])^ := PRef(@aLeaf^[OffsetL])^; - PRef(@aLeaf^[OffsetL])^ := Temp; - {if keys are separate entities, swap keys} - if not bhiKeysAreRefs then begin - OffsetN := ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef)) + - (aNElement * NodeHdr^.bhiKeyLength); - OffsetL := ffc_BlockHeaderSizeIndex + - (LeafHdr^.bhiMaxKeyCount * SizeOfRef) + - (aLElement * LeafHdr^.bhiKeyLength); - Move(aLeaf^[OffsetL], aNode^[OffsetN], bhiKeyLength); - Move(aKey^, aLeaf^[OffsetL], bhiKeyLength); - end; - end; -end; -{====================================================================} - - -{===Page splitting/merging routines==================================} -procedure MergeChildren(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - aParentPage : PffBlock; - aSeparator : Longint; - aChildLeft : PffBlock; - aChildRight : PffBlock); - {-Merge the right child into the left child, separated by the given - key from the parent. The right child is deleted; the parent loses - one key.} -var - ParentPageHdr : PffBlockHeaderIndex absolute aParentPage; - ChildLeftHdr : PffBlockHeaderIndex absolute aChildLeft; - ChildRightHdr : PffBlockHeaderIndex absolute aChildRight; - OffsetL : Longint; - OffsetR : Longint; - OffsetP : Longint; -begin - {Assumptions: all relevant pages have been marked dirty} - {$IFDEF FF_DEBUG} - inc(FFDEBUG_IndexCounter.Merge); - {$ENDIF} - with ChildLeftHdr^ do begin - {Note: this routine is *only* called if both children have - (bhiMaxKeyCount div 2) keys--the absolute minimum} - if (bhiKeyCount <> (bhiMaxKeyCount div 2)) or - (bhiKeyCount <> ChildRightHdr^.bhiKeyCount) then - FFRaiseException(EffServerException, ffStrResServer, fferrBadMergeCall, - [aIndexData.kidFI^.fiName^, bhiThisBlock, ChildRightHdr^.bhiThisBlock]); - {the merge process is different for nodes and leaves} - if (not bhiIsLeafPage) then begin - {copy over the page numbers} - OffsetR := ffc_BlockHeaderSizeIndex; - OffsetL := ffc_BlockHeaderSizeIndex + (bhiKeyCount * SizeOfPageNum); - Move(aChildRight^[OffsetR - SizeOfPageNum], - aChildLeft^[OffsetL], - (succ(bhiKeyCount) * SizeOfPageNum)); - {set up offsets for data references} - OffsetL := ffc_BlockHeaderSizeIndex + - ((bhiMaxKeyCount * SizeOfPageNum) + (bhiKeyCount * SizeOfRef)); - OffsetR := ffc_BlockHeaderSizeIndex + (bhiMaxKeyCount * SizeOfPageNum); - end - else {it's a leaf} begin - {set up offsets for data references} - OffsetL := ffc_BlockHeaderSizeIndex + - (bhiKeyCount * SizeOfRef); - OffsetR := ffc_BlockHeaderSizeIndex; - end; - {copy over parent data reference} - OffsetP := ffc_BlockHeaderSizeIndex + - (ParentPageHdr^.bhiMaxKeyCount * SizeOfPageNum) + - (aSeparator * SizeOfRef); - PRef(@aChildLeft^[OffsetL])^ := PRef(@aParentPage^[OffsetP])^; - {copy over other data references} - Move(aChildRight^[OffsetR], - aChildLeft^[OffsetL + SizeOfRef], - (bhiKeyCount * SizeOfRef)); - {if keys are separate entities, move the keys} - if not bhiKeysAreRefs then begin - {set up offsets for keys} - inc(OffsetL, ((bhiMaxKeyCount-bhiKeyCount) * SizeOfRef) + - (bhiKeyCount * bhiKeyLength)); - inc(OffsetR, (bhiMaxKeyCount * SizeOfRef)); - OffsetP := ffc_BlockHeaderSizeIndex + - (ParentPageHdr^.bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef)) + - (aSeparator * bhiKeyLength); - {copy over the parent key} - Move(aParentPage^[OffsetP], aChildLeft^[OffsetL], bhiKeyLength); - {copy over all the other keys} - Move(aChildRight^[OffsetR], - aChildLeft^[OffsetL + bhiKeyLength], - (bhiKeyCount * bhiKeyLength)); - end; - {delete the parent key since it now points to an invalid page} - RemoveKeyFromNodePage(aParentPage, aSeparator); - - {patch up the left child's key count} - bhiKeyCount := bhiMaxKeyCount; - end; - {delete the right child, it is no longer referenced} - with aIndexData do begin - FFTblHlpDeleteBlock(kidFI, kidFileHeader, aChildRight); - dec(kidIndexHeader^.bihIndexPageCount[kidIndex]); - end; -end; -{--------} -procedure BtreeSplitChild(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - aParentPage : PffBlock; - aChildIndex : integer; - aChildPage : PffBlock); - {-Split the given child into two children. If the number of keys in - the child is 2N+1, each child will end up with N keys, the parent - gains one key at aChildIndex.} -var - aParentPageHdr : PffBlockHeaderIndex absolute aParentPage; - aChildPageHdr : PffBlockHeaderIndex absolute aChildPage; - NewChildPage : PffBlock; - NewChildPageHdr : PffBlockHeaderIndex absolute NewChildPage; - NewChild : Longint; - NewOffset : integer; - OldOffset : integer; - MedianRef : TRef; - aRelMethod : TffReleaseMethod; -begin - { Assumptions: aParentPage and aChildPage have been marked dirty. } - {$IFDEF FF_DEBUG} - inc(FFDEBUG_IndexCounter.Splits); - {$ENDIF} - aRelMethod := nil; - with aChildPageHdr^ do begin - {create a new child page} - with aIndexData do - NewChildPage := - GetNewInxBtreeBlock(kidFI, aTI, kidIndexHeader, kidIndex, - bhiIsLeafPage, aRelMethod); - try - NewChild := NewChildPageHdr^.bhiThisBlock; - NewChildPageHdr^.bhiNodeLevel := bhiNodeLevel; - {transfer the second half of the old child to the first half of the new one} - {note this depends on whether the page is an internal node or a leaf} - if (not bhiIsLeafPage) then begin - {move the page numbers} - {note: we must transfer into the prev page number field of the header} - NewOffset := ffc_BlockHeaderSizeIndex - SizeOfPageNum; - OldOffset := NewOffset + (succ(bhiMaxKeyCount div 2) * SizeOfPageNum); - Move(aChildPage^[OldOffset], NewChildPage^[NewOffset], - succ(bhiMaxKeyCount div 2) * SizeOfPageNum); - {move the data references} - NewOffset := ffc_BlockHeaderSizeIndex + (bhiMaxKeyCount * SizeOfPageNum) ; - OldOffset := NewOffset + (succ(bhiMaxKeyCount div 2) * SizeOfRef); - Move(aChildPage^[OldOffset], NewChildPage^[NewOffset], - (bhiMaxKeyCount div 2) * SizeOfRef); - MedianRef := PRef(@aChildPage^[OldOffset-SizeOfRef])^; - {if keys are separate entities, move the keys} - if not bhiKeysAreRefs then begin - NewOffset := ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef)); - OldOffset := NewOffset + (succ(bhiMaxKeyCount div 2) * bhiKeyLength); - Move(aChildPage^[OldOffset], NewChildPage^[NewOffset], - (bhiMaxKeyCount div 2) * bhiKeyLength); - end; - end - else {it's a leaf} begin - {move the data references} - NewOffset := ffc_BlockHeaderSizeIndex; - OldOffset := NewOffset + (succ(bhiMaxKeyCount div 2) * SizeOfRef); - Move(aChildPage^[OldOffset], NewChildPage^[NewOffset], - (bhiMaxKeyCount div 2) * SizeOfRef); - MedianRef := PRef(@aChildPage^[OldOffset-SizeOfRef])^; - {if keys are separate entities, move the keys} - if not bhiKeysAreRefs then begin - NewOffset := ffc_BlockHeaderSizeIndex + (bhiMaxKeyCount * SizeOfRef); - OldOffset := NewOffset + (succ(bhiMaxKeyCount div 2) * bhiKeyLength); - Move(aChildPage^[OldOffset], NewChildPage^[NewOffset], - (bhiMaxKeyCount div 2) * bhiKeyLength); - end; - end; - {insert the median key into the parent} - InsertKeyInNodePage(aParentPage, aChildIndex, - PffByteArray(@aChildPage^[OldOffset-bhiKeyLength]), - MedianRef, NewChild); - {set the number of keys in each child} - bhiKeyCount := bhiMaxKeyCount div 2; - NewChildPageHdr^.bhiKeyCount := bhiMaxKeyCount div 2; - finally - aRelMethod(NewChildPage); - end; - end; -end; -{====================================================================} - - -{===Key insertion helper routines====================================} -function BtreeInsertRedistribute(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - aParentPage : PffBlock; - aChildIndex : integer; - aChildPage : PffBlock) : boolean; -var - aParentPageHdr : PffBlockHeaderIndex absolute aParentPage; - SiblingPage : PffBlock; - SiblingPageHdr : PffBlockHeaderIndex absolute SiblingPage; - Sibling : Longint; - PageBlock : PPageNumBlock; - aRelMethod : TffReleaseMethod; -begin - { Assumption: aParentPage and aChildPage have been marked dirty. } - Result := false; - - { Try the child's successor sibling page. } - if (aChildIndex < aParentPageHdr^.bhiKeyCount) then begin - PageBlock := PPageNumBlock(@aParentPage^[ffc_BlockHeaderSizeIndex]); - Sibling := PageBlock^[aChildIndex]; - with aIndexData do - SiblingPage := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_MarkDirty, - ffc_InxBlockTypeBtreePage, Sibling, - aRelMethod); - - try - { Are there at least two spare key slots? } - if (SiblingPageHdr^.bhiKeyCount < pred(SiblingPageHdr^.bhiMaxKeyCount)) then begin - { Yes. Redistribute the keys. } - if (not SiblingPageHdr^.bhiIsLeafPage) then - RotateRightNode(aParentPage, aChildIndex, aChildPage, SiblingPage) - else RotateRightLeaf(aParentPage, aChildIndex, aChildPage, SiblingPage); - Result := true; - end; - finally - aRelMethod(SiblingPage); - end; - end; - - { If not done it yet, try the child's predecessor sibling page. } - if (not Result) and (aChildIndex > 0) then begin - if (aChildIndex = 1) then - Sibling := aParentPageHdr^.bhiPrevPageRef - else begin - PageBlock := PPageNumBlock(@aParentPage^[ffc_BlockHeaderSizeIndex]); - Sibling := PageBlock^[aChildIndex - 2]; - end; - with aIndexData do - SiblingPage := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_MarkDirty, - ffc_InxBlockTypeBtreePage, Sibling, - aRelMethod); - try - { Are there at least two spare key slots? } - if (SiblingPageHdr^.bhiKeyCount < pred(SiblingPageHdr^.bhiMaxKeyCount)) then begin - { Yes. Redistribute the keys. } - if (not SiblingPageHdr^.bhiIsLeafPage) then - RotateLeftNode(aParentPage, aChildIndex-1, SiblingPage, aChildPage) - else RotateLeftLeaf(aParentPage, aChildIndex-1, SiblingPage, aChildPage); - Result := true; - end; - finally - aRelMethod(SiblingPage); - end; - end; -end; -{--------} -function BtreeInsertNonFull(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - var aPage : PffBlock; - var aRelMethod : TffReleaseMethod; - aKey : PffByteArray; - const aRefNr : TffInt64) : boolean; -var - PageHdr : PffBlockHeaderIndex absolute aPage; - PageNumBlock : PPageNumBlock; - DataRefBlock : PRefBlock; - KeyBlock : PffByteArray; - L, R, M : integer; - CompResult : integer; - Child : Longint; - ChildPage : PffBlock; - ChildPageHdr : PffBlockHeaderIndex absolute ChildPage; - Compare : TffKeyCompareFunc; - AllowDups : boolean; - DoneRecursing: boolean; - aChildRelMethod : TffReleaseMethod; -begin - { Assumptions: aPage could be dirty or clean. Caller has incremented - aPage's ref count. } - Result := false; - { Learn whether dup keys are allowed, get compare function. } - with aIndexData do begin - AllowDups := (kidIndexHeader^.bihIndexFlags[kidIndex] and - ffc_InxFlagAllowDups) <> 0; - Compare := kidCompare; - end; - {simulate recursion (ie unwind it} - DoneRecursing := false; - repeat - with PageHdr^ do begin - {get the addresses of the reference block and key string block, - this is different for leaf and node pages} - if bhiIsLeafPage then begin - PageNumBlock := nil; - DataRefBlock := PRefBlock(@aPage^[ffc_BlockHeaderSizeIndex]); - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := - PffByteArray(@aPage^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfRef)]); - end - else {its a node page} begin - PageNumBlock := PPageNumBlock(@aPage^[ffc_BlockHeaderSizeIndex]); - DataRefBlock := - PRefBlock(@aPage^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount*SizeOfPageNum)]); - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := - PffByteArray(@aPage^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef))]); - end; - {binary search to find insertion point} - L := 0; - R := pred(bhiKeyCount); - repeat - M := (L + R) div 2; - CompResult := Compare(aKey^, KeyBlock^[M * bhiKeyLength], - aIndexData.kidCompareData); - if (CompResult < 0) then - R := pred(M) - else if (CompResult > 0) then - L := succ(M) - else {CompResult = 0} - if AllowDups then begin - CompResult := FFCmpI64(aRefNr, DataRefBlock^[M]); - if (CompResult < 0) then - R := pred(M) - else if (CompResult > 0) then - L := succ(M) - else {it's a duplicate key+refnr combo} - Exit; - end - else {it's a duplicate key} - Exit; - until (L > R); - if bhiIsLeafPage then begin - { It's a leaf page. Mark it as dirty since we are about to modify it. } - FFBMDirtyBlock(aIndexData.kidFI, bhiThisBlock, aTI, aPage); - - { The key+refnr combo doesn't exist, insert at L. } - InsertKeyInLeafPage(aPage, L, aKey, aRefNr); - Result := true; - DoneRecursing := true; - end - else {it's a node page} begin - { The child we need to traverse to is given by (L - 1). } - if (L = 0) then Child := bhiPrevPageRef - else Child := PageNumBlock^[pred(L)]; - { Read the page. For now, we need a Share lock. } - with aIndexData do - ChildPage := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, Child, - aChildRelMethod); - { If this child is full, split it or redistribute now. } - with ChildPageHdr^ do - if (bhiKeyCount = bhiMaxKeyCount) then begin - { Splitting a child/redistribution will update the parent - page as well, so mark both pages as dirty. } - FFBMDirtyBlock(aIndexData.kidFI, PageHdr^.bhiThisBlock, aTI, aPage); - FFBMDirtyBlock(aIndexData.kidFI, Child, aTI, ChildPage); - - { Try redistribution else split the child. } - if not BtreeInsertRedistribute(aIndexData, aTI, aPage, L, ChildPage) then - BtreeSplitChild(aIndexData, aTI, aPage, L, ChildPage); - aChildRelMethod(ChildPage); - { We've just rearranged the keys in this page, recurse this page. } - end - else begin - { Insert the key into the child's subtree, ie recurse with child. } - aRelMethod(aPage); - aRelMethod := aChildRelMethod; - aPage := ChildPage; - end; - end; - end; - until DoneRecursing; -end; -{--------} -function BtreeInsert(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - aRoot : TffWord32; - aKey : PffByteArray; - const aRefNr : TffInt64) : boolean; -var - RootPage : PffBlock; - RootPageHdr : PffBlockHeaderIndex absolute RootPage; - NewRootPage : PffBlock; - NewRootPageHdr : PffBlockHeaderIndex absolute NewRootPage; - aNewRelMethod, - aRelMethod : TffReleaseMethod; -begin - { Get the root page. } - with aIndexData do - RootPage := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_MarkDirty, - ffc_InxBlockTypeBtreePage, aRoot, - aRelMethod); - { If the root is full, we split it now. } - with RootPageHdr^ do - try - if (bhiKeyCount = bhiMaxKeyCount) then begin - { Since we're about to update it, mark the block as dirty. } - FFBMDirtyBlock(aIndexData.kidFI, aRoot, aTI, RootPage); - - { Create a new root. } - with aIndexData do - NewRootPage := - GetNewInxBtreeBlock(kidFI, aTI, kidIndexHeader, kidIndex, false, - aNewRelMethod); - try - NewRootPageHdr^.bhiNodeLevel := succ(bhiNodeLevel); - - { Patch it so that the previous page is the old root. } - NewRootPageHdr^.bhiPrevPageRef := aRoot; - - { Split the old root. } - BtreeSplitChild(aIndexData, aTI, NewRootPage, 0, RootPage); - - { Update the index header to point to the new root. } - with aIndexData do - kidIndexHeader^.bihIndexRoot[kidIndex] := NewRootPageHdr^.bhiThisBlock; - {now insert the key into the tree starting at the new root} - Result := - BtreeInsertNonFull(aIndexData, aTI, NewRootPage, aNewRelMethod, - aKey, aRefNr); - finally - aNewRelMethod(NewRootPage); - end; - - end - else {insert the key into the tree starting at the root} - Result := - BtreeInsertNonFull(aIndexData, aTI, RootPage, aRelMethod, aKey, - aRefNr); - finally - aRelMethod(RootPage); - end; -end; -{====================================================================} - - -{===Key deletion helper routines=====================================} -procedure BtreeDeleteIndexPage(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - aParent : TffWord32); -var - ParentPage : PffBlock; - ParentPageHdr : PffBlockHeaderIndex absolute ParentPage; - PageBlock : PPageNumBlock; - Child : integer; - aRelMethod : TffReleaseMethod; -begin - {WARNING: this is a recursive routine with an absolute maximum of 32 - levels of recursion} - {read the parent index page, mark dirty} - with aIndexData do - ParentPage := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_MarkDirty, - ffc_InxBlockTypeBtreePage, aParent, - aRelMethod); - try - {get the page number block} - PageBlock := PPageNumBlock(@ParentPage^[ffc_BlockHeaderSizeIndex]); - with ParentPageHdr^ do - {if there are children recurse through them all} - if (bhiNodeLevel > 1) then begin - BtreeDeleteIndexPage(aIndexData, aTI, bhiPrevPageRef); - for Child := 0 to pred(bhiKeyCount) do - BtreeDeleteIndexPage(aIndexData, aTI, PageBlock^[Child]); - end; - {delete this page} - with aIndexData do begin - FFTblHlpDeleteBlock(kidFI, kidFileHeader, ParentPage); - end; - finally - aRelMethod(ParentPage); - end; -end; -{--------} -function BtreeDeleteSwapKey(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - aParentPage : PffBlock; - aKeyIndex : integer; - aKey : PffByteArray; - var aRelMethod : TffReleaseMethod) : PffBlock; -var - ParentPageHdr : PffBlockHeaderIndex absolute aParentPage; - ChildPage : PffBlock; - ChildPageHdr : PffBlockHeaderIndex absolute ChildPage; - Child : TffWord32; - LChildPage : PffBlock; - LChildPageHdr : PffBlockHeaderIndex absolute LChildPage; - LChild : TffWord32; - RChildPage : PffBlock; - RChildPageHdr : PffBlockHeaderIndex absolute RChildPage; - RChild : TffWord32; - ResultPageNum : TffWord32; - MergeThem : boolean; - aChildRelMeth, - aLCRelMethod, - aRCRelMethod : TffReleaseMethod; -begin - {Assumptions: aParentPage has already been marked dirty. - The key at aKeyIndex in the parent equals aKey} - { Assume that we shall have to do a merge. } - LChild := 0; - Result := nil; - MergeThem := true; - with ParentPageHdr^ do begin - {we shall first search for the successor key} - RChild := - PPageNum(@aParentPage^[ffc_BlockHeaderSizeIndex + (aKeyIndex * SizeOfPageNum)])^; - with aIndexData do - RChildPage := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, RChild, - aRCRelMethod); - { Does this child page have enough keys?. } - if (RChildPageHdr^.bhiKeyCount > (RChildPageHdr^.bhiMaxKeyCount div 2)) then begin - {$IFDEF FF_DEBUG} - inc(FFDEBUG_IndexCounter.SwapNext); - {$ENDIF} - {save the right child page as Result} - aRelMethod := aRCRelMethod; - Result := RChildPage; - ResultPageNum := RChild; - {prepare to walk down the btree} - Child := RChild; - ChildPage := RChildPage; - aChildRelMeth := aRCRelMethod; - {continue walking down the btree going left all the time until - we hit a leaf, locking pages as we go} - while (not ChildPageHdr^.bhiIsLeafPage) do begin - Child := ChildPageHdr^.bhiPrevPageRef; - if ChildPage <> Result then {!!.01} - aChildRelMeth(ChildPage); {!!.01} - with aIndexData do - ChildPage := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, Child, - aChildRelMeth); - end; - { Mark the final leaf child since we shall be updating it. - Note: If we walked down only 1 level then we need to make sure Result - contains a pointer to the modified block put into ChildPage. } - FFBMDirtyBlock(aIndexData.kidFI, Child, aTI, ChildPage); -// if ResultPageNum = Child then begin {Deleted !!.01} -// aRelMethod := aChildRelMeth; {Deleted !!.01} -// Result := ChildPage; {Deleted !!.01} -// end; {Deleted !!.01} - - { Swap the child's smallest key & ref with this key in the parent. } - SwapKeys(aParentPage, aKeyIndex, ChildPage, 0, aKey); -{Begin !!.01} - { Did we modify the right child? } - if Child = ResultPageNum then - { Yes. Make sure we return the child page's modified block to the - calling method. } - Result := ChildPage - else - { No. Release the child page that we modified. } - aChildRelMeth(ChildPage); -{End !!.01} - MergeThem := false; - end; - - { If we couldn't use the successor, try the predecessor. } - if MergeThem then begin - {find the left child} - if (aKeyIndex = 0) then - LChild := bhiPrevPageRef - else - LChild := PPageNum(@aParentPage^[ffc_BlockHeaderSizeIndex + - ((aKeyIndex-1) * SizeOfPageNum)])^; - with aIndexData do - LChildPage := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, LChild, - aLCRelMethod); - { Does this child page have enough keys? } - if (LChildPageHdr^.bhiKeyCount > (LChildPageHdr^.bhiMaxKeyCount div 2)) then begin - {$IFDEF FF_DEBUG} - inc(FFDEBUG_IndexCounter.SwapPrev); - {$ENDIF} - {save the left child page as result} - aRelMethod := aLCRelMethod; - Result := LChildPage; - ResultPageNum := LChild; - {prepare to walk down the btree} - Child := LChild; - ChildPage := LChildPage; - aChildRelMeth := aLCRelMethod; - {continue walking down the btree going right all the time until - we hit a leaf, locking as we go} - while (not ChildPageHdr^.bhiIsLeafPage) do begin - Child := - PPageNum(@ChildPage^[ffc_BlockHeaderSizeIndex + - ((ChildPageHdr^.bhiKeyCount-1) * SizeOfPageNum)])^; - if ChildPage <> LChildPage then {!!.01} - aChildRelMeth(ChildPage); {!!.01} - with aIndexData do - ChildPage := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, Child, - aChildRelMeth); - end; - { Mark the leaf child dirty because we shall be updating it. } - FFBMDirtyBlock(aIndexData.kidFI, Child, aTI, ChildPage); -// if ResultPageNum = Child then begin {Deleted !!.01} -// aRelMethod := aChildRelMeth; {Deleted !!.01} -// Result := ChildPage; {Deleted !!.01} -// end; {Deleted !!.01} - - { Swap the child's largest key & ref with this key in the parent. } - SwapKeys(aParentPage, aKeyIndex, - ChildPage, pred(ChildPageHdr^.bhiKeyCount), - aKey); -{Begin !!.01} - { Did we modify the left child? } - if Child = ResultPageNum then - { Yes. Make sure we return the child page's modified block to the - calling method. } - Result := ChildPage - else - { No. Release the child page that we modified. } - aChildRelMeth(ChildPage); -{End !!.01} - MergeThem := false; - end; - end; - - {if we've failed to find the predecessor/successor, merge the two children} - if MergeThem then - begin - { Obtain an Exclusive lock on the children. } - {***Delphi32***: the compiler tags LChild as possibly being - "used before definition". Not true.} - FFBMDirtyBlock(aIndexData.kidFI, LChild, aTI, LChildPage); - FFBMDirtyBlock(aIndexData.kidFI, RChild, aTI, RChildPage); - - { Merge them. } - MergeChildren(aIndexData, aTI, aParentPage, aKeyIndex, LChildPage, - RChildPage); - aRelMethod := aLCRelMethod; - Result := LChildPage; - aRCRelMethod(RChildPage); - end; - end; - {***Delphi32***: the compiler tags the return value of this function - as being "possibly undefined". Not true.} -end; -{--------} -procedure BtreeDeleteRedistributeOrMerge(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - aParentPage : PffBlock; - aChildIndex : integer; - aChildPage : PffBlock); -var - aParentPageHdr : PffBlockHeaderIndex absolute aParentPage; - SiblingPage : PffBlock; - SiblingPageHdr : PffBlockHeaderIndex absolute SiblingPage; - Sibling : Longint; - PageBlock : PPageNumBlock; - DoneIt : boolean; - IsRightSibling : boolean; - aRelList : TffPointerList; - aRelMethod : TffReleaseMethod; -begin - {Assumptions: aParentPage and aChildPage have both been marked dirty. - aChildPage has the minimum number of keys. } - aRelList := TffPointerList.Create; - Sibling := 0; - IsRightSibling := false; - SiblingPage := nil; - try - {assume we shall fail all the way} - DoneIt := false; - {read the child's successor sibling page} - if (aChildIndex < aParentPageHdr^.bhiKeyCount) then begin - PageBlock := PPageNumBlock(@aParentPage^[ffc_BlockHeaderSizeIndex]); - Sibling := PageBlock^[aChildIndex]; - IsRightSibling := true; - with aIndexData do - SiblingPage := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, Sibling, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(SiblingPage, TffInt64(aRelMethod))); - {check for at least one spare key} - if (SiblingPageHdr^.bhiKeyCount > (SiblingPageHdr^.bhiMaxKeyCount div 2)) then begin - { Mark the sibling as dirty. } - FFBMDirtyBlock(aIndexData.kidFI, Sibling, aTI, SiblingPage); - - { Redistribute the keys. } - if (not SiblingPageHdr^.bhiIsLeafPage) then - RotateLeftNode(aParentPage, aChildIndex, aChildPage, SiblingPage) - else RotateLeftLeaf(aParentPage, aChildIndex, aChildPage, SiblingPage); - DoneIt := true; - end; - end; - - { Read the child's predecessor sibling page. } - if (not DoneIt) and (aChildIndex > 0) then begin - if (aChildIndex = 1) then - Sibling := aParentPageHdr^.bhiPrevPageRef - else begin - PageBlock := PPageNumBlock(@aParentPage^[ffc_BlockHeaderSizeIndex]); - Sibling := PageBlock^[aChildIndex-2]; - end; - IsRightSibling := false; - with aIndexData do - SiblingPage := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, Sibling, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(SiblingPage, TffInt64(aRelMethod))); - { Check for at least one spare key. } - if (SiblingPageHdr^.bhiKeyCount > (SiblingPageHdr^.bhiMaxKeyCount div 2)) then begin - { Obtain an Exclusive lock on the sibling. } - FFBMDirtyBlock(aIndexData.kidFI, Sibling, aTI, SiblingPage); - - { Redistribute the keys. } - if (not SiblingPageHdr^.bhiIsLeafPage) then - RotateRightNode(aParentPage, aChildIndex-1, SiblingPage, aChildPage) - else RotateRightLeaf(aParentPage, aChildIndex-1, SiblingPage, aChildPage); - DoneIt := true; - end; - end; - - {***Delphi32***: The compiler tags both Sibling and IsRightSibling as - possibly being "used before definition". A corollary - of the definition of a B-Tree insists that every child - page has at least one sibling and so in practice both - variables will be set by this point.} - if (not DoneIt) then begin - { Mark the sibling as dirty. } - FFBMDirtyBlock(aIndexData.kidFI, Sibling, aTI, SiblingPage); - { Merge with our sibling. } - if IsRightSibling then - MergeChildren(aIndexData, aTI, aParentPage, aChildIndex, aChildPage, - SiblingPage) - else MergeChildren(aIndexData, aTI, aParentPage, aChildIndex-1, - SiblingPage, aChildPage) - end; - finally - for Sibling := 0 to pred(aRelList.Count) do - FFDeallocReleaseInfo(aRelList[Sibling]); - aRelList.Free; - end; -end; -{--------} -function BtreeDeleteAmplePage(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - aPage : PffBlock; - aKey : PffByteArray; - const aRefNr : TffInt64; - var aBTreeChanged : Boolean) {!!.05} - : Boolean; - {-Routine to delete a key from a page; only called for - pages that have succ(minimum keys) present, or for the root} -var - Page : PffBlock; - PageHdr : PffBlockHeaderIndex absolute Page; - PageNumBlock : PPageNumBlock; - DataRefBlock : PRefBlock; - KeyBlock : PffByteArray; - L, R, M : integer; - CompResult : integer; - Child : Longint; - ChildPage : PffBlock; - ChildPageHdr : PffBlockHeaderIndex absolute ChildPage; - Compare : TffKeyCompareFunc; - AllowDups : boolean; - KeyFound : boolean; - DoneRecursing: boolean; - aRelMethod : TffReleaseMethod; - aRelList : TffPointerList; -begin - {$IFDEF DefeatWarnings} - M := 0; - Result := false; - {$ENDIF} - - Page := aPage; - aRelMethod := nil; - - { We use the following list to track the RAM pages we've accessed and - the release method associated with each RAM page. At the end of this - routine, we will call the release method for each RAM page. } - aRelList := TffPointerList.Create; - - try - { Assumption: Page has not been marked dirty. } - { Learn whether dup keys are allowed, get compare function. } - with aIndexData do begin - AllowDups := (kidIndexHeader^.bihIndexFlags[kidIndex] and - ffc_InxFlagAllowDups) <> 0; - Compare := kidCompare; - end; - {simulate recursion (ie unwind it)} - DoneRecursing := false; - repeat - with PageHdr^ do begin - {get the addresses of the reference block and key string block} - if bhiIsLeafPage then begin - PageNumBlock := nil; - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex]); - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := - PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfRef)]); - end - else begin - PageNumBlock := - PPageNumBlock(@Page^[ffc_BlockHeaderSizeIndex]); - DataRefBlock := - PRefBlock(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfPageNum)]); - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := - PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef))]); - end; - {binary search to find out if key is present} - L := 0; - R := pred(bhiKeyCount); - KeyFound := false; - {note: it is possible for this routine to be called for an empty root} - if (R >= 0) then - repeat - M := (L + R) div 2; - CompResult := Compare(aKey^, KeyBlock^[M * bhiKeyLength], - aIndexData.kidCompareData); - if (CompResult < 0) then - R := pred(M) - else if (CompResult > 0) then - L := succ(M) - else {CompResult = 0} - if AllowDups then begin - CompResult := FFCmpI64(aRefNr, DataRefBlock^[M]); - if (CompResult < 0) then - R := pred(M) - else if (CompResult > 0) then - L := succ(M) - else {key+refnr have been found} - begin - KeyFound := true; - Break;{out of the repeat..until loop} - end - end - else {key has been found} begin - KeyFound := true; - Break;{out of the repeat..until loop} - end - until (L > R); - {if the page is a leaf...} - if bhiIsLeafPage then begin - {if the key was found delete it from the page, return true} - if KeyFound then begin - { Mark the block as dirty. } - FFBMDirtyBlock(aIndexData.kidFI, bhiThisBlock, aTI, Page); - {***Delphi32***: the compiler flags M as "possibly used - before definition". Not true.} - RemoveKeyFromLeafPage(Page, M); - Result := true; - end - {otherwise return false} - else - Result := false; - DoneRecursing := true; - end - { Otherwise the page is an internal node... } - else - { If the key was found in the node... } - if KeyFound then begin - {we need to swap this key with its predecessor/successor - (this is guaranteed to be on a leaf) then delete the key - in the leaf} - { Mark the block as dirty. } - FFBMDirtyBlock(aIndexData.kidFI, bhiThisBlock, aTI, Page); - { Swap the key with a key on a leaf, or merge children, - then recursively delete from returned child. } - Page := BtreeDeleteSwapKey(aIndexData, aTI, Page, M, aKey, aRelMethod); - aBtreeChanged := True; {!!.05} - aRelList.Append(FFAllocReleaseInfo(Page, TffInt64(aRelMethod))); - end - {otherwise the key was not found...} - else begin - {the key, if anywhere, is in the child subtree at L-1} - if (L = 0) then - Child := bhiPrevPageRef - else Child := PageNumBlock^[pred(L)]; - {read the child's page} - with aIndexData do - ChildPage := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, Child, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(ChildPage, TffInt64(aRelMethod))); - {check whether the child has enough keys, if so recurse} - if (ChildPageHdr^.bhiKeyCount > (ChildPageHdr^.bhiMaxKeyCount div 2)) then - Page := ChildPage - {otherwise try and make it full enough} - else {not enough keys in child} begin - { Mark this page and the child as dirty. } - FFBMDirtyBlock(aIndexData.kidFI, bhiThisBlock, aTI, Page); - FFBMDirtyBlock(aIndexData.kidFI, Child, aTI, ChildPage); - - { Redistribute the keys among siblings, or merge. } - BtreeDeleteRedistributeOrMerge(aIndexData, aTI, - Page, L, ChildPage); - aBTreeChanged := True; {!!.05} - {recurse ourselves} - {Note: it could be that we now have only the minimum number - of keys, but it doesn't matter since we'll immediately - recurse into one of our children} - end; - end; - end; - until DoneRecursing; - {***Delphi32***: the compiler tags the return value of this function - as being "possibly undefined". Not true, DoneRecursing - is only set true once Result has been set true/false} - finally - for Child := 0 to pred(aRelList.Count) do - FFDeallocReleaseInfo(aRelList[Child]); - aRelList.Free; - end; -end; -{--------} -function BtreeDelete(const aRoot : Longint; - const aKey : PffByteArray; - const aTI : PffTransInfo; - const aIndexData : TffKeyIndexData; - const aRefNr : TffInt64; - var aBTreeChanged : Boolean) {!!.05} - : Boolean; -var - RootPage, RootPageClone : PffBlock; - RootPageHdr : PffBlockHeaderIndex absolute RootPage; - RootPageCloneHdr : PffBlockHeaderIndex absolute RootPageClone; - aCloneRelMethod, - aRelMethod : TffReleaseMethod; -begin - { Obtain the root page. } - with aIndexData do - RootPage := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, aRoot, - aRelMethod); - try - { Delete the key from this page. } - Result := BtreeDeleteAmplePage(aIndexData, aTI, RootPage, aKey, - aRefNr, aBTreeChanged); {!!.05} - - { If the root page is empty then replace it with its first child & - delete the root page. } - if Result then begin - { Get the root page as it may have been modified. We may be looking at - the read-only block right now and we need the modified block. } - RootPageClone := FFBMGetBlock(aIndexData.kidFI, aTI, aRoot, ffc_ReadOnly, - aCloneRelMethod); - if (RootPageCloneHdr^.bhiKeyCount = 0) then - { Assumption: The root page has been exclusively locked somewhere - in the delete process. } - with aIndexData do begin - kidIndexHeader^.bihIndexRoot[kidIndex] := RootPageCloneHdr^.bhiPrevPageRef; - FFTblHlpDeleteBlock(kidFI, kidFileHeader, RootPageClone); - dec(kidIndexHeader^.bihIndexPageCount[kidIndex]); - end; - aCloneRelMethod(RootPageClone); - end; - finally - aRelMethod(RootPage); - end; -end; -{====================================================================} - - -{===Key reading helper routines======================================} -function BtreeExistsKey(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - aRoot : TffWord32; - aKey : PffByteArray; - aRefNr : TffInt64) : boolean; -var - Page : PffBlock; - PageHdr : PffBlockHeaderIndex absolute Page; - PageNumBlock : PPageNumBlock; - DataRefBlock : PRefBlock; - KeyBlock : PffByteArray; - L, R, M : integer; - CompResult : integer; - Child : TffWord32; - Compare : TffKeyCompareFunc; - CheckDups : boolean; - KeyFound : boolean; - DoneRecursing: boolean; - aRelMethod : TffReleaseMethod; -begin - {$IFDEF DefeatWarnings} - Result := false; - {$ENDIF} - {get the root page} - with aIndexData do - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, aRoot, aRelMethod); - try - {set up the invariants} - with aIndexData do begin - CheckDups := ((kidIndexHeader^.bihIndexFlags[kidIndex] and - ffc_InxFlagAllowDups) <> 0) and (aRefNr.iLow <> 0) and - (aRefNr.iHigh <> 0); - Compare := kidCompare; - end; - {simulate recursion (ie unwind it)} - DoneRecursing := false; - repeat - with PageHdr^ do begin - {get the addresses of the reference block and key string block} - if bhiIsLeafPage then begin - PageNumBlock := nil; - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex]); - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := - PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfRef)]); - end - else begin - PageNumBlock := - PPageNumBlock(@Page^[ffc_BlockHeaderSizeIndex]); - DataRefBlock := - PRefBlock(@Page^[ffc_BlockHeaderSizeIndex + (bhiMaxKeyCount*SizeOfPageNum)]); - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := - PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef))]); - end; - {binary search to find out if key is present} - L := 0; - R := pred(bhiKeyCount); - KeyFound := false; - repeat - M := (L + R) div 2; - CompResult := Compare(aKey^, KeyBlock^[M * bhiKeyLength], aIndexData.kidCompareData); - if (CompResult < 0) then - R := pred(M) - else if (CompResult > 0) then - L := succ(M) - else {CompResult = 0} - if CheckDups then begin - CompResult := FFCmpI64(aRefNr, DataRefBlock^[M]); - if (CompResult < 0) then - R := pred(M) - else if (CompResult > 0) then - L := succ(M) - else {key+refnr have been found} - begin - KeyFound := true; - Break;{out of the repeat..until loop} - end - end - else {key has been found} begin - KeyFound := true; - Break;{out of the repeat..until loop} - end; - until (L > R); - if KeyFound then begin - Result := true; - DoneRecursing := true; - end - else - {if the page is a leaf...} - if bhiIsLeafPage then begin - {the key was not found at all} - Result := false; - DoneRecursing := true; - end - {otherwise the page is an internal node...} - else begin - {the key, if anywhere, is in the child subtree at L-1} - if (L = 0) then - Child := bhiPrevPageRef - else Child := PageNumBlock^[pred(L)]; - {read the child's page} - aRelMethod(Page); - with aIndexData do begin - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, Child, - aRelMethod); - end; - - {and recurse it} - end; - end; - until DoneRecursing; - - {***Delphi32***: the compiler tags the return value of this function - as being "possibly undefined". Not true, DoneRecursing - is only set true once Result has been set true/false} - finally - aRelMethod(Page); - end; -end; -{--------} -function BtreeNextKey(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - aKey : PffByteArray; - var aRefNr : TffInt64; - var aKeyPath : TffKeyPath) : boolean; -var - aInx : Longint; - Page : PffBlock; - PageHdr : PffBlockHeaderIndex absolute Page; - PageNumBlock : PPageNumBlock; - DataRefBlock : PRefBlock; - KeyBlock : PffByteArray; - PageNum : TffWord32; - aRelList : TffPointerList; - aRelMethod : TffReleaseMethod; -begin - { Assumption: the btree has at least one key. } - aRelList := TffPointerList.Create; - try - with aKeyPath do begin - {patch the path for BOF} - if (kpPos = kppBOF) then begin - kpPath[0].kpePage := aIndexData.kidIndexHeader^.bihIndexRoot[aIndexData.kidIndex]; - kpPath[0].kpeItem := -1; - kpCount := 1; - end; - {get the last page on the key path} - with aIndexData do - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, - kpPath[pred(kpCount)].kpePage, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(Page, TffInt64(aRelMethod))); - {if we're on a crack, just return the key pointed to by the path} - if (kpPos = kppOnCrackBefore) and {!!.03 - Start} - (kpPath[pred(kpCount)].kpeItem <= pred(PageHdr^.bhiKeyCount)) then {!!.03 - End} - with kpPath[pred(kpCount)], PageHdr^ do begin - if bhiIsLeafPage then - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex]) - else - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfPageNum)]); - aRefNr := DataRefBlock^[kpeItem]; - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - if bhiIsLeafPage then - KeyBlock := PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount*SizeOfRef)]) - else - KeyBlock := PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef))]); - Move(KeyBlock^[kpeItem * bhiKeyLength], aKey^, bhiKeyLength); - Result := true; - Exit; - end; - {if the current page is a node, we need to travel down the btree, - going left all the time, until we hit a leaf} - if not PageHdr^.bhiIsLeafPage then begin - {read the first child} - PageNumBlock := PPageNumBlock(@Page^[ffc_BlockHeaderSizeIndex]); - if (kpPath[pred(kpCount)].kpeItem = -1) then - PageNum := PageHdr^.bhiPrevPageRef - else PageNum := PageNumBlock^[kpPath[pred(kpCount)].kpeItem]; - with aIndexData do begin - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, PageNum, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(Page, TffInt64(aRelMethod))); - end; - while not PageHdr^.bhiIsLeafPage do begin - with kpPath[kpCount] do begin - kpePage := PageHdr^.bhiThisBlock; - kpeItem := -1; - end; - inc(kpCount); - with aIndexData do begin - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, - PageHdr^.bhiPrevPageRef, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(Page, TffInt64(aRelMethod))); - end; - end; - with kpPath[kpCount], PageHdr^ do begin - kpePage := PageHdr^.bhiThisBlock; - kpeItem := 0; - inc(kpCount); - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex]); - aRefNr := DataRefBlock^[0]; - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfRef)]); - Move(KeyBlock^[0], aKey^, bhiKeyLength); - end; - Result := true; - end - {otherwise the current page is a leaf} - {if the current item is not the final key, just return the next} - else if (kpPath[pred(kpCount)].kpeItem < pred(PageHdr^.bhiKeyCount)) then begin - with kpPath[pred(kpCount)], PageHdr^ do begin - inc(kpeItem); - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex]); - aRefNr := DataRefBlock^[kpeItem]; - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfRef)]); - Move(KeyBlock^[kpeItem * bhiKeyLength], aKey^, bhiKeyLength); - Result := true; - end; - end - {otherwise the current item is the last key on the page, we need to - travel up the btree returning along the path, until we get to a node - where the current item is less than the number of keys; if we can't - find one, return false--there is no next key} - else begin - {read the first parent, assume we won't find a next key} - dec(kpCount); - Result := false; - {while there are still items in the key path} - while (kpCount > 0) do begin - {read the current page} - with aIndexData do - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, - kpPath[pred(kpCount)].kpePage, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(Page, TffInt64(aRelMethod))); - {if the current item is not the final key, just return the next} - if (kpPath[pred(kpCount)].kpeItem < pred(PageHdr^.bhiKeyCount)) then begin - with kpPath[pred(kpCount)], PageHdr^ do begin - inc(kpeItem); - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfPageNum)]); - aRefNr := DataRefBlock^[kpeItem]; - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef))]); - Move(KeyBlock^[kpeItem * bhiKeyLength], aKey^, bhiKeyLength); - end; - Result := true; - Break;{out of dowhile loop} - end; - {otherwise go back one step} - dec(kpCount); - end; - end; { if } - end; { with } - finally - for aInx := 0 to pred(aRelList.Count) do - FFDeallocReleaseInfo(aRelList[aInx]); - aRelList.Free; - end; -end; -{--------} -function BtreePrevKey(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - aKey : PffByteArray; - var aRefNr : TffInt64; - var aKeyPath : TffKeyPath) : boolean; -var - aInx : Longint; - Page : PffBlock; - PageHdr : PffBlockHeaderIndex absolute Page; - PageNumBlock : PPageNumBlock; - DataRefBlock : PRefBlock; - KeyBlock : PffByteArray; - PageNum : TffWord32; - aRelList : TffPointerList; - aRelMethod : TffReleaseMethod; -begin - {Assumption: the btree has at least one key - if the path is pointing to EOF the root page can be - found at aKeyPath.kpPath[0].kpePage} - aRelList := TffPointerList.Create; - try - with aKeyPath do begin - {if the keypath points to EOF, then read the root page and set - the item number of the first path element to the count of keys - ready for the walk down the btree} - if (kpPos = kppEOF) then begin - with kpPath[0], aIndexData do begin - kpePage := kidIndexHeader^.bihIndexRoot[kidIndex]; - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, kpePage, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(Page, TffInt64(aRelMethod))); - kpeItem := PageHdr^.bhiKeyCount; - end; - kpCount := 1; - end - else begin - {get the last page on the key path} - with aIndexData do - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, - kpPath[pred(kpCount)].kpePage, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(Page, TffInt64(aRelMethod))); - {if we're on a crack, just return the key pointed to by the path} - if (kpPos = kppOnCrackAfter) then - with kpPath[pred(kpCount)], PageHdr^ do begin - if bhiIsLeafPage then - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex]) - else - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfPageNum)]); - aRefNr := DataRefBlock^[kpeItem]; - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - if bhiIsLeafPage then - KeyBlock := PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfRef)]) - else - KeyBlock := PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef))]); - Move(KeyBlock^[kpeItem * bhiKeyLength], aKey^, bhiKeyLength); - Result := true; - Exit; - end; { with } - end; { if } - - {if the current page is a node, we need to travel down the btree, - going right all the time after the first child, until we hit a leaf} - if not PageHdr^.bhiIsLeafPage then begin - {read the first (ie previous) child} - dec(kpPath[pred(kpCount)].kpeItem); - PageNumBlock := PPageNumBlock(@Page^[ffc_BlockHeaderSizeIndex]); - if (kpPath[pred(kpCount)].kpeItem < 0) then - PageNum := PageHdr^.bhiPrevPageRef - else PageNum := PageNumBlock^[kpPath[pred(kpCount)].kpeItem]; - with aIndexData do - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, PageNum, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(Page, TffInt64(aRelMethod))); - while not PageHdr^.bhiIsLeafPage do begin - with kpPath[kpCount], PageHdr^ do begin - kpePage := bhiThisBlock; - kpeItem := pred(bhiKeyCount); - end; - inc(kpCount); - PageNumBlock := PPageNumBlock(@Page^[ffc_BlockHeaderSizeIndex]); - with aIndexData do begin - PageNum := PageNumBlock^[pred(PageHdr^.bhiKeyCount)]; - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, - PageNum, aRelMethod); - aRelList.Append(FFAllocReleaseInfo(Page, TffInt64(aRelMethod))); - end; - end; - with kpPath[kpCount], PageHdr^ do begin - kpePage := bhiThisBlock; - kpeItem := pred(bhiKeyCount); - inc(kpCount); - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex]); - aRefNr := DataRefBlock^[kpeItem]; - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfRef)]); - Move(KeyBlock^[kpeItem * bhiKeyLength], aKey^, bhiKeyLength); - end; - Result := true; - end - {otherwise the current page is a leaf} - {if the current item is not the first key, just return the previous} - else if (kpPath[pred(kpCount)].kpeItem > 0) then begin - with kpPath[pred(kpCount)], PageHdr^ do begin - dec(kpeItem); - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex]); - aRefNr := DataRefBlock^[kpeItem]; - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfRef)]); - Move(KeyBlock^[kpeItem * bhiKeyLength], aKey^, bhiKeyLength); - Result := true; - end; - end - {otherwise the current item is the first key on the page, we need to - travel up the btree returning along the path, until we get to a node - where the current item is not the first key on the page; if we can't - find one, return false--there is no previous key} - else begin - {read the first parent, assume we won't find a previous key} - dec(kpCount); - Result := false; - {while there are still items in the key path} - while (kpCount > 0) do begin - {read the current page} - with aIndexData do begin - PageNum := kpPath[pred(kpCount)].kpePage; - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, PageNum, - aRelMethod); - aRelList.Append(FFAllocReleaseInfo(Page, TffInt64(aRelMethod))); - end; - {if the current item is not -1, just return it} - if (kpPath[pred(kpCount)].kpeItem >= 0) then begin - with kpPath[pred(kpCount)], PageHdr^ do begin - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfPageNum)]); - aRefNr := DataRefBlock^[kpeItem]; - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef))]); - Move(KeyBlock^[kpeItem * bhiKeyLength], aKey^, bhiKeyLength); - end; - Result := true; - Break;{out of dowhile loop} - end; - {otherwise go back one step} - dec(kpCount); - end; - end; - end; { with } - finally - for aInx := 0 to pred(aRelList.Count) do - FFDeallocReleaseInfo(aRelList[aInx]); - aRelList.Free; - end; -end; -{--------} -function BtreeFindKey(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - aRoot : TffWord32; - aKey : PffByteArray; - var aRefNr : TffInt64; - var aKeyPath : TffKeyPath; - aAction : TffSearchKeyAction) : boolean; -var - Page : PffBlock; - PageHdr : PffBlockHeaderIndex absolute Page; - PageNumBlock : PPageNumBlock; - DataRefBlock : PRefBlock; - KeyBlock : PffByteArray; - OurKey : PffByteArray; - KeyLen : integer; - L, R, M : integer; - KeyCompResult: integer; - RefCompResult: integer; - Child : TffWord32; - Compare : TffKeyCompareFunc; - CheckDups : boolean; - KeyFound : boolean; - DoneRecursing: boolean; - HasDups : boolean; - aRelMethod : TffReleaseMethod; -begin - { Get the root page. } - with aIndexData do - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, aRoot, aRelMethod); - - try - { Set up the invariants. } - with aIndexData do begin - {HasDups means that there might be duplicate keys here} - HasDups := (kidIndexHeader^.bihIndexFlags[kidIndex] and - ffc_InxFlagAllowDups) <> 0; - {CheckDups means that we're trying to find an exact key/refnr - combination} - CheckDups := HasDups and ((aRefNr.iLow <> 0) or (aRefNr.iHigh <> 0)); - Compare := kidCompare; - end; - - { Prepare the key path. } - FFInitKeyPath(aKeyPath); - {simulate recursion (ie unwind it)} - DoneRecursing := false; - repeat - with PageHdr^, aKeyPath do begin - {get the addresses of the reference block and key string block} - if bhiIsLeafPage then begin - PageNumBlock := nil; - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex]); - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := - PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfRef)]); - end - else begin - PageNumBlock := - PPageNumBlock(@Page^[ffc_BlockHeaderSizeIndex]); - DataRefBlock := - PRefBlock(@Page^[ffc_BlockHeaderSizeIndex + (bhiMaxKeyCount * SizeOfPageNum)]); - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := - PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef))]); - end; - {binary search to find out if key is present} - L := 0; - R := pred(bhiKeyCount); - KeyFound := false; - repeat - M := (L + R) div 2; - KeyCompResult := Compare(aKey^, KeyBlock^[M * bhiKeyLength], aIndexData.kidCompareData); - if (KeyCompResult < 0) then - R := pred(M) - else if (KeyCompResult > 0) then - L := succ(M) - else {KeyCompResult = 0} - if CheckDups then begin - RefCompResult := FFCmpI64(aRefNr, DataRefBlock^[M]); - if (RefCompResult < 0) then - R := pred(M) - else if (RefCompResult > 0) then - L := succ(M) - else {key+refnr have been found} begin - KeyFound := true; - Break;{out of the repeat..until loop} - end - end - else {key has been found} begin - KeyFound := true; - Break;{out of the repeat..until loop} - end; - until (L > R); - {if the key/ref was found then save the final keypath element} - if KeyFound then begin - DoneRecursing := true; - with kpPath[kpCount] do begin - kpePage := bhiThisBlock; - kpeItem := M; - end; - inc(kpCount); - aRefNr := DataRefBlock^[M]; - Move(KeyBlock^[M * bhiKeyLength], aKey^, bhiKeyLength); - kpPos := kppOnKey; - end - else - {if the page is a leaf...} - if bhiIsLeafPage then begin - {if the index allows dups, the key has been matched and the - passed refnr is zero, return the first refnr in the index - for the key} - if CheckDups and (KeyCompResult = 0) and - (aRefNr.iLow = 0) and (aRefNr.iHigh = 0) then begin - KeyFound := true; - DoneRecursing := true; - with kpPath[kpCount] do begin - kpePage := bhiThisBlock; - kpeItem := L; - end; - inc(kpCount); - aRefNr := DataRefBlock^[L]; - kpPos := kppOnCrackBefore; - end - else begin - {the key/ref was not present at all, patch the final - keypath node according to the aAction parameter} - DoneRecursing := true; - with kpPath[kpCount] do begin - kpePage := bhiThisBlock; - case aAction of - skaEqual : FFInitKeyPath(aKeyPath); - skaEqualCrack, - skaGreater, - skaGreaterEqual : begin - if (L < bhiKeyCount) then begin - kpeItem := L; - kpPos := kppOnCrackBefore; - end - else begin - kpeItem := pred(L); - kpPos := kppOnCrackAfter; - end; - end; - end;{case} - end; - inc(kpCount); - end; - end - {otherwise the page is an internal node...} - else begin - {the key, if anywhere, is in the child subtree at L-1} - with kpPath[kpCount] do begin - kpePage := bhiThisBlock; - kpeItem := pred(L); - end; - inc(kpCount); - if (L = 0) then - Child := bhiPrevPageRef - else Child := PageNumBlock^[pred(L)]; - {read the child's page} - aRelMethod(Page); - with aIndexData do begin - { Crab down to child block and unlock parent block. } - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, Child, - aRelMethod); - end; - {and recurse it} - end; - end; - until DoneRecursing; - - {if the key wasn't found...} - if (not KeyFound) then begin - { If we don't mind the missing key and can accept being positioned on - a crack before the next key, our search is over. } - if (aAction = skaEqualCrack) then - KeyFound := true - {if we can return the next greater key, do so; always return true - (the caller will be patching the keypath)} - else if (aAction <> skaEqual) then begin - if BtreeNextKey(aIndexData, aTI, aKey, aRefNr, aKeyPath) then - aKeyPath.kpPos := kppOnKey - else - {we hit the end of the index; this is OK, just set the keypath - to EOF} - FFSetKeyPathToEOF(aKeyPath); - KeyFound := true; - end; - end - {otherwise the key was found...} - else {KeyFound is true} begin - {if we actually wanted the next greater key, continue doing next - key operations until the key returned compares unequal to the one - we have, or we hit EOF; always return true} - if (aAction = skaGreater) then begin - KeyLen := aIndexData.kidCompareData^.cdKeyLen; - FFGetMem(OurKey, KeyLen); - try - Move(aKey^, OurKey^, KeyLen); - repeat - KeyFound := BtreeNextKey(aIndexData, aTI, aKey, aRefNr, aKeyPath); - if KeyFound then begin - aKeyPath.kpPos := kppOnKey; - KeyFound := Compare(aKey^, OurKey^, aIndexData.kidCompareData) = 0 - end - else - FFSetKeyPathToEOF(aKeyPath); - until (not KeyFound); - finally - FFFreeMem(OurKey, KeyLen); - end; - end - {otherwise we wanted an equal key} - else {aAction <> skaGreater} begin - {if we were making an exact full key match on an index with - unique keys, we're done now; otherwise we have to position the - keypath at the first of possibly many equal partial keys, or - equal duplicate keys. Note that if the index has dup keys, but - we've matched exactly on the refnr as well, then we've found - the exact key} - if (HasDups and not CheckDups) or - (aIndexData.kidCompareData^.cdFldCnt <> 0) or - (aIndexData.kidCompareData^.cdPartLen <> 0) then begin - KeyLen := aIndexData.kidCompareData^.cdKeyLen; - FFGetMem(OurKey, KeyLen); - try - Move(aKey^, OurKey^, KeyLen); - repeat - KeyFound := BtreePrevKey(aIndexData, aTI, aKey, aRefNr, aKeyPath); - if KeyFound then - KeyFound := Compare(aKey^, OurKey^, aIndexData.kidCompareData) = 0 - else - FFSetKeyPathToBOF(aKeyPath); - until (not KeyFound); - BtreeNextKey(aIndexData, aTI, aKey, aRefNr, aKeyPath); - aKeyPath.kpPos := kppOnKey; - finally - FFFreeMem(OurKey, KeyLen); - end; - end; - end; - {make sure that KeyFound is still true, we may have altered it} - KeyFound := true; - end; - Result := KeyFound; - finally - aRelMethod(Page); - end; -end; -{--------} -procedure BtreeFindApprox(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - aRoot : TffWord32; - aKey : PffByteArray; - var aRefNr : TffInt64; - var aKeyPath : TffKeyPath; - aPos : integer); -var - Page : PffBlock; - PageHdr : PffBlockHeaderIndex absolute Page; - PageNumBlock : PPageNumBlock; - DataRefBlock : PRefBlock; - KeyBlock : PffByteArray; - Child : TffWord32; - ChildPos : integer; - aRelMethod : TffReleaseMethod; -begin - {get the root page} - with aIndexData do - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, aRoot, aRelMethod); - - try - {if the root is a leaf, just do a simple calculation to find - the key at the approx position} - if PageHdr^.bhiIsLeafPage then - with aKeyPath, PageHdr^ do begin - kpCount := 1; - with kpPath[0] do begin - kpePage := bhiThisBlock; - kpeItem := (aPos * bhiKeyCount) div 101; - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex]); - aRefNr := DataRefBlock^[kpeItem]; - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * SizeOfRef)]); - Move(KeyBlock^[kpeItem * bhiKeyLength], aKey^, bhiKeyLength); - end; - end - {otherwise the root is a node, ie has children} - else with aKeyPath do begin - {there will be two levels in the keypath} - kpCount := 2; - {set up the first entry in the keypath, calc values for the child} - with PageHdr^, kpPath[0] do - begin - kpePage := bhiThisBlock; - kpeItem := ((aPos * succ(bhiKeyCount)) div 101) - 1; - PageNumBlock := PPageNumBlock(@Page^[ffc_BlockHeaderSizeIndex]); - if (kpeItem = -1) then - Child := bhiPrevPageRef - else - Child := PageNumBlock^[kpeItem]; - ChildPos := ((aPos * 100) div (101 div succ(bhiKeyCount))) - - (succ(kpeItem) * 100); - end; - {get the child page} - aRelMethod(Page); - with aIndexData do - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, Child, aRelMethod); - {set up the second entry in the keypath} - with PageHdr^, kpPath[1] do begin - kpePage := bhiThisBlock; - kpeItem := ((ChildPos * bhiKeyCount) div 101); - if bhiIsLeafPage then begin - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex]); - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount*SizeOfRef)]); - end - else begin - DataRefBlock := PRefBlock(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount*SizeOfPageNum)]); - if bhiKeysAreRefs then - KeyBlock := PffByteArray(DataRefBlock) - else - KeyBlock := PffByteArray(@Page^[ffc_BlockHeaderSizeIndex + - (bhiMaxKeyCount * (SizeOfPageNum + SizeOfRef))]); - end; - aRefNr := DataRefBlock^[kpeItem]; - Move(KeyBlock^[kpeItem * bhiKeyLength], aKey^, bhiKeyLength); - end; - end; - finally - aRelMethod(Page); - end; -end; -{--------} -procedure BtreeCalcApprox(const aIndexData : TffKeyIndexData; - aTI : PffTransInfo; - aRoot : Longint; - const aKeyPath : TffKeyPath; - var aPos : integer); -var - Page : PffBlock; - PageHdr : PffBlockHeaderIndex absolute Page; - RootKeyCount : integer; - aRelMethod : TffReleaseMethod; -begin - {get the root page} - with aIndexData do - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, aRoot, aRelMethod); - - try - {if the root is a leaf, just do a simple calculation to find - approx position of the key} - if PageHdr^.bhiIsLeafPage then - with aKeyPath.kpPath[0], PageHdr^ do - aPos := (kpeItem * 100) div bhiKeyCount - {otherwise the root is a node, ie has children} - else with aKeyPath do begin - {there will be two levels to check in the keypath} - RootKeyCount := PageHdr^.bhiKeyCount; - {get the relevant child page} - aRelMethod(Page); - with aIndexData do - Page := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeBtreePage, kpPath[1].kpePage, - aRelMethod); - - {calculate the position} - if PageHdr^.bhiIsLeafPage then - aPos := ((100 + (kpPath[1].kpeItem * 100) div PageHdr^.bhiKeyCount) * - succ(kpPath[0].kpeItem)) div - succ(RootKeyCount) - else - aPos := ((100 + (succ(kpPath[1].kpeItem) * 100) div succ(PageHdr^.bhiKeyCount)) * - succ(kpPath[0].kpeItem)) div - succ(RootKeyCount); - end; - finally - aRelMethod(Page); - end; -end; -{====================================================================} - - -{===Key access related routines======================================} -procedure FFTblDeleteAllKeys(aTI : PffTransInfo; var aIndex : TffKeyIndexData); -var - InxBlock : PffBlock; - InxBlockHdr: PffBlockHeaderIndex absolute InxBlock; - Root : TffWord32; - aInxRelMeth, - aRelMethod : TffReleaseMethod; -begin - {Note: this routine can only be run in a 'subset' transaction. - Essentially all the index pages are going to be changed: if - they were all in a normal transaction, we could quite easily - run out of memory trying to hold all the dirty pages in - memory. A corollary is that FFTblDeleteAllKeys cannot be - rolled back. Another is that if this crashes, the index file - is pretty well hosed and should be rebuilt.} - with aIndex do begin - { Obtain a Share lock on the file header. We need the file header - but we don't need to modify it. } - kidFileHeader := PffBlockHeaderFile(FFBMGetBlock(kidFI, aTI, 0, - ffc_ReadOnly, aRelMethod)); - - try - { Get an Exclusive lock on the index header. } - InxBlock := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_MarkDirty, - ffc_InxBlockTypeHeader, - kidFileHeader^.bhfIndexHeader, - aInxRelMeth); - try - kidIndexHeader := PffIndexHeader(@InxBlock^[ffc_BlockHeaderSizeIndex]); - {get the root page} - Root := kidIndexHeader^.bihIndexRoot[kidIndex]; - {patch the index header} - with kidIndexHeader^ do begin - bihIndexRoot[kidIndex] := ffc_W32NoValue; - bihIndexPageCount[kidIndex] := 0; - end; - {special case: if the root page does not exist, just return - (ie there are no keys)} - if (Root = ffc_W32NoValue) then - Exit; - { Otherwise go delete all the index pages. } - BtreeDeleteIndexPage(aIndex, aTI, Root); - { Allow the caller to do the final commit. } - finally - aInxRelMeth(InxBlock); - end; - finally - aRelMethod(PffBlock(kidFileHeader)); - end; - end; { with } -end; -{--------} -function FFTblDeleteKey(const aTI : PffTransInfo; - const aKey : PffByteArray; - const aRefNr : TffInt64; - var aIndex : TffKeyIndexData; - var aBTreeChanged : Boolean) : Boolean; {!!.05} -var - InxBlock : PffBlock; - InxBlockHdr: PffBlockHeaderIndex absolute InxBlock; - aInxRelMeth, - aRelMethod : TffReleaseMethod; -begin - with aIndex do begin - { Mark the file header as dirty. } - kidFileHeader := PffBlockHeaderFile(FFBMGetBlock(kidFI, aTI, 0, - ffc_MarkDirty, aRelMethod)); - try - { Obtain an Exclusive lock on the index header. } - InxBlock := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_MarkDirty, - ffc_InxBlockTypeHeader, - kidFileHeader^.bhfIndexHeader, - aInxRelMeth); - try - kidIndexHeader := PffIndexHeader(@InxBlock^[ffc_BlockHeaderSizeIndex]); - {special case: if the root page does not exist, return false} - if (kidIndexHeader^.bihIndexRoot[kidIndex] = ffc_W32NoValue) then - Result := false - {otherwise go delete from the b-tree} - else - Result := BtreeDelete(kidIndexHeader^.bihIndexRoot[kidIndex], - aKey, aTI, aIndex, aRefNr, - aBTreeChanged); {!!.05} - {decrement the number of keys} - if Result then - dec(kidIndexHeader^.bihIndexKeyCount[kidIndex]); - finally - aInxRelMeth(InxBlock); - end; - finally - aRelMethod(PffBlock(kidFileHeader)); - end; - end; -end; -{--------} -function FFTblFindKey(var aIndex : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath; - aAction : TffSearchKeyAction) : boolean; -var - InxBlock : PffBlock; - aInxRelMeth, - aRelMethod : TffReleaseMethod; -begin - with aIndex do begin - {get the file header, block 0} - kidFileHeader := PffBlockHeaderFile(FFBMGetBlock(kidFI, aTI, 0, - ffc_ReadOnly, aRelMethod)); - try - {get the index header} - InxBlock := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeHeader, - kidFileHeader^.bhfIndexHeader, aInxRelMeth); - try - kidIndexHeader := PffIndexHeader(@InxBlock^[ffc_BlockHeaderSizeIndex]); - {special case: if the root page does not exist} - if (kidIndexHeader^.bihIndexRoot[kidIndex] = ffc_W32NoValue) then begin - if (aAction = skaEqual) then - Result := false - else begin - Result:= true; - FFSetKeyPathToEOF(aKeyPath); - end; - end - {otherwise go read the b-tree} - else - Result := BtreeFindKey(aIndex, aTI, - kidIndexHeader^.bihIndexRoot[kidIndex], - aKey, aRefNr, - aKeyPath, - aAction); - aKeyPath.kpLSN := kidFI^.fiBufMgr.GetRAMPageLSN2 {!!.06} - (kidFI, kidFileHeader^.bhfIndexHeader); {!!.06} - finally - aInxRelMeth(InxBlock); - end; - finally - aRelMethod(PffBlock(kidFileHeader)); - end; - end; { with } - - {if the key was not found, ensure the path is invalidated} - if (not Result) and (aAction = skaEqual) then - FFInitKeyPath(aKeyPath); -end; -{--------} -function FFTblGetApproxPos(var aIndex : TffKeyIndexData; - var aPos : integer; - aTI : PffTransInfo; - const aKeyPath : TffKeyPath) : boolean; -var - InxBlock : PffBlock; - aInxRelMeth, - aRelMethod : TffReleaseMethod; -begin - with aIndex do begin - {get the file header, block 0} - kidFileHeader := PffBlockHeaderFile(FFBMGetBlock(kidFI, aTI, 0, - ffc_ReadOnly, - aRelMethod)); - try - {get the index header} - InxBlock := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeHeader, - kidFileHeader^.bhfIndexHeader, aInxRelMeth); - try - kidIndexHeader := PffIndexHeader(@InxBlock^[ffc_BlockHeaderSizeIndex]); - {special case: if the root page does not exist, return false} - if (kidIndexHeader^.bihIndexRoot[kidIndex] = ffc_W32NoValue) then - Result := false - {otherwise go read the b-tree} - else begin - Result := true; - BtreeCalcApprox(aIndex, aTI, kidIndexHeader^.bihIndexRoot[kidIndex], - aKeyPath, aPos); - end; - finally - aInxRelMeth(InxBlock); - end; - finally - aRelMethod(PffBlock(kidFileHeader)); - end; - end; { with } -end; -{--------} -function FFTblInsertKey(var aIndex : TffKeyIndexData; - const aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray) : boolean; -var - InxBlock, {!!.11} - InxNewBlock : PffBlock; {!!.11} - InxBlockHdr: PffBlockHeaderIndex; {!!.11} - aInxRelMeth, - aInxRelMethNewBlock, {!!.11} - aRelMethod : TffReleaseMethod; -begin - with aIndex do begin - { Obtain an Exclusive lock on the file header. } - kidFileHeader := PffBlockHeaderFile(FFBMGetBlock(kidFI, aTI, 0, - ffc_MarkDirty, aRelMethod)); - try - { Dirty the index header. } - InxBlock := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_MarkDirty, - ffc_InxBlockTypeHeader, - kidFileHeader^.bhfIndexHeader, aInxRelMeth); - try - kidIndexHeader := PffIndexHeader(@InxBlock^[ffc_BlockHeaderSizeIndex]); - { Special case: if the root page does not yet exist, create a new one - and add the key to it. } - if (kidIndexHeader^.bihIndexRoot[kidIndex] = ffc_W32NoValue) then begin -{Begin !!.11} -// aInxRelMeth(InxBlock); - InxNewBlock := GetNewInxBtreeBlock(kidFI, aTI, kidIndexHeader, - kidIndex, True, - aInxRelMethNewBlock); - try - InxBlockHdr := PffBlockHeaderIndex(InxNewBlock); - kidIndexHeader^.bihIndexRoot[kidIndex] := InxBlockHdr^.bhiThisBlock; - InsertKeyInLeafPage(InxNewBlock, 0, aKey, aRefNr); - Result := true; - finally - aInxRelMethNewBlock(InxNewBlock); - end; -{End !!.11} - end - {otherwise insert the key in the relevant leaf page} - else - Result := BtreeInsert(aIndex, aTI, - kidIndexHeader^.bihIndexRoot[kidIndex], - aKey, aRefNr); - {increment the number of keys if key was added} - if Result then - inc(kidIndexHeader^.bihIndexKeyCount[kidIndex]); - finally - aInxRelMeth(InxBlock); - end; - finally - aRelMethod(Pffblock(kidFileHeader)); - end; - end; { with } -end; -{--------} -function FFTblKeyExists(var aIndex : TffKeyIndexData; - const aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray ) : boolean; -var - InxBlock : PffBlock; - aInxRelMeth, - aRelMethod : TffReleaseMethod; -begin - { If the lock duration is ffldShort then this method will free the locks - after it has finished searching for the key. } - with aIndex do begin - {get the file header, block 0} - kidFileHeader := PffBlockHeaderFile(FFBMGetBlock(kidFI, aTI, 0, - ffc_ReadOnly, aRelMethod)); - try - {get the index header} - InxBlock := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeHeader, - kidFileHeader^.bhfIndexHeader, aInxRelMeth); - try - kidIndexHeader := PffIndexHeader(@InxBlock^[ffc_BlockHeaderSizeIndex]); - {special case: if the root page does not exist, return false} - if (kidIndexHeader^.bihIndexRoot[kidIndex] = ffc_W32NoValue) then - Result := false - {otherwise go read the b-tree} - else - Result := BtreeExistsKey(aIndex, aTI, - kidIndexHeader^.bihIndexRoot[kidIndex], - aKey, aRefNr); - finally - aInxRelMeth(InxBlock); - end; - finally - aRelMethod(PffBlock(kidFileHeader)); - end; - end; { with } -end; -{--------} -function FFTblNextKey(var aIndex : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath) : boolean; -var -// IndexMap : TffbmRAMPage; {Deleted !!.06} - IndexMapLSN : TffWord32; {!!.06} - InxBlock : PffBlock; - aInxRelMeth, - aRelMethod : TffReleaseMethod; -begin - {if the keypath is valid and it's at EOF, there is no next key} - if (aKeyPath.kpPos = kppEOF) then begin - Result := false; - Exit; - end; - {otherwise do some work} - with aIndex do begin - {get the file header, block 0} - kidFileHeader := PffBlockHeaderFile(FFBMGetBlock(kidFI, aTI, 0, - ffc_ReadOnly, aRelMethod)); - try - {get the index header} - InxBlock := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeHeader, - kidFileHeader^.bhfIndexHeader, aInxRelMeth); - try - kidIndexHeader := PffIndexHeader(@InxBlock^[ffc_BlockHeaderSizeIndex]); - {special case: if the root page does not exist, return false} - if (kidIndexHeader^.bihIndexRoot[kidIndex] = ffc_W32NoValue) then - Result := false - {otherwise go read the b-tree} - else begin - IndexMapLSN := kidFI^.fiBufMgr.GetRAMPageLSN2 {!!.06} - (kidFI, kidFileHeader^.bhfIndexHeader); - if (aKeyPath.kpPos = kppUnknown) then - FFSetKeyPathToBOF(aKeyPath) -{Begin !!.06} - else begin - { Has the index map changed since our last visit? } - if (((aKeyPath.kpLSN > 0) and - (IndexMapLSN > aKeyPath.kpLSN)) or {!!.06} - (aKeyPath.kpPos = kppUnknown)) then begin {!!.05} - { Yes. Reposition. } - Result := BtreeFindKey(aIndex, aTI, - KidIndexHeader^.bihIndexRoot[kidIndex], - aKey, aRefNr, aKeyPath, skaEqualCrack); - if not Result then - Exit; - end; - end; - Result := BtreeNextKey(aIndex, aTI, aKey, aRefNr, aKeyPath); - aKeyPath.kpLSN := IndexMapLSN; {!!.06} - end; - finally - aInxRelMeth(InxBlock); - end; - finally - aRelMethod(PffBlock(kidFileHeader)); - end; - end; { with } - {if a key was found, ensure the path points to a key} - if Result then - aKeyPath.kpPos := kppOnKey - {if no next key found, ensure the path points to EOF} - else - FFSetKeyPathToEOF(aKeyPath); -end; -{--------} -function FFTblPrevKey(var aIndex : TffKeyIndexData; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath) : boolean; -var -// IndexMap : TffbmRAMPage; {Deleted !!.06} - IndexMapLSN : TffWord32; {!!.06} - InxBlock : PffBlock; - aInxRelMeth, - aRelMethod : TffReleaseMethod; -begin - {if the keypath is valid and it's at BOF, there is no prev key} - if (aKeyPath.kpPos = kppBOF) then begin - Result := false; - Exit; - end; - {otherwise do some work} - with aIndex do begin - {get the file header, block 0} - kidFileHeader := PffBlockHeaderFile(FFBMGetBlock(kidFI, aTI, 0, - ffc_ReadOnly, aRelMethod)); - try - {get the index header} - InxBlock := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeHeader, - kidFileHeader^.bhfIndexHeader, aInxRelMeth); - try - kidIndexHeader := PffIndexHeader(@InxBlock^[ffc_BlockHeaderSizeIndex]); - {special case: if the root page does not exist, return false} - if (kidIndexHeader^.bihIndexRoot[kidIndex] = ffc_W32NoValue) then - Result := false - {otherwise go read the b-tree} - else begin - IndexMapLSN := kidFI^.fiBufMgr.GetRAMPageLSN2 {!!.06} - (kidFI, kidFileHeader^.bhfIndexHeader); {!!.06} - if (aKeyPath.kpPos = kppUnknown) then - FFSetKeyPathToEOF(aKeyPath); - { Has the index map changed since our last visit? } - if (((aKeyPath.kpLSN > 0) and - (IndexMapLSN > aKeyPath.kpLSN)) or {!!.06} - (aKeyPath.kpPos = kppUnknown)) then begin {!!.05} - { Yes. Reposition. } - Result := BtreeFindKey(aIndex, aTI, - KidIndexHeader^.bihIndexRoot[kidIndex], - aKey, aRefNr, aKeyPath, skaEqualCrack); - if not Result then - Exit; - end; - Result := BtreePrevKey(aIndex, aTI, aKey, aRefNr, aKeyPath); - aKeyPath.kpLSN := IndexMapLSN; {!!.06} - end; - finally - aInxRelMeth(InxBlock); - end; - finally - aRelMethod(PffBlock(kidFileHeader)); - end; - end; { with } - - {if a key was found, ensure the path points to a key} - if Result then - aKeyPath.kpPos := kppOnKey - {if no previous key found, ensure the path points to BOF} - else - FFSetKeyPathToBOF(aKeyPath); -end; -{--------} -function FFTblSetApproxPos(var aIndex : TffKeyIndexData; - aPos : integer; - var aRefNr : TffInt64; - aTI : PffTransInfo; - aKey : PffByteArray; - var aKeyPath : TffKeyPath) : boolean; -var - InxBlock : PffBlock; - aInxRelMeth, - aRelMethod : TffReleaseMethod; -begin - {validate the position to be 0..100} - if (aPos < 0) or (aPos > 100) then - with aIndex do - FFRaiseException(EffServerException, ffStrResServer, fferrBadApproxPos, - [kidFI^.fiName^, kidIndex, aPos]); - - with aIndex do begin - {get the file header, block 0} - kidFileHeader := PffBlockHeaderFile(FFBMGetBlock(kidFI, aTI, 0, - ffc_ReadOnly, aRelMethod)); - try - {get the index header} - InxBlock := ReadVfyInxBlock(kidFI, aTI, kidFileHeader, ffc_ReadOnly, - ffc_InxBlockTypeHeader, - kidFileHeader^.bhfIndexHeader, aInxRelMeth); - try - kidIndexHeader := PffIndexHeader(@InxBlock^[ffc_BlockHeaderSizeIndex]); - {special case: if the root page does not exist, return false - and an invalid keypath} - if (kidIndexHeader^.bihIndexRoot[kidIndex] = ffc_W32NoValue) then begin - Result := false; - FFInitKeyPath(aKeyPath); - end - {otherwise go read the b-tree} - else begin - Result := true; - BtreeFindApprox(aIndex, aTI, - kidIndexHeader^.bihIndexRoot[kidIndex], - aKey, aRefNr, aKeyPath, aPos); - end; - aKeyPath.kpLSN := kidFI^.fiBufMgr.GetRAMPageLSN2 {!!.06} - (kidFI, kidFileHeader^.bhfIndexHeader); {!!.06} - finally - aInxRelMeth(InxBlock); - end; - finally - aRelMethod(PffBlock(kidFileHeader)); - end; - end; { with } -end; -{====================================================================} - - -{===Index related routines===========================================} -procedure FFTblAddIndex(aFI : PffFileInfo; - aTI : PffTransInfo; - aIndex : integer; - aMaxKeyLen : integer; - aAllowDups : boolean; - aKeysAreRefs : boolean); -var - FileHeader : PffBlockHeaderFile; - InxBlock : PffBlock; - InxHeader : PffIndexHeader; - aInxRelMeth, - aRelMethod : TffReleaseMethod; -begin - { First get an Exclusive lock on the file header, block 0. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_MarkDirty, - aRelMethod)); - try - { Second get an Exclusive lock on the index header. } - InxBlock := ReadVfyInxBlock(aFI, aTI, FileHeader, ffc_MarkDirty, - ffc_InxBlockTypeHeader, - FileHeader^.bhfIndexHeader, aInxRelMeth); - InxHeader := PffIndexHeader(@InxBlock^[ffc_BlockHeaderSizeIndex]); - - { Set up the index data. } - with InxHeader^, FileHeader^ do begin - {note that there is only *one* index that uses references as - keys: index 0} - if aKeysAreRefs then begin - bihIndexFlags[aIndex] := ffc_InxFlagKeysAreRefs; {ie no dups!} - bihIndexKeyLen[aIndex] := SizeOfRef; - bhfHasSeqIndex := 1; - end - else begin - bihIndexKeyLen[aIndex] := aMaxKeyLen; - if aAllowDups then - bihIndexFlags[aIndex] := ffc_InxFlagAllowDups - else - bihIndexFlags[aIndex] := 0; - end; - bihIndexRoot[aIndex] := ffc_W32NoValue; - end; - aInxRelMeth(InxBlock); - finally - aRelMethod(PffBlock(FileHeader)); - end; -end; -{--------} -procedure FFTblDeleteIndex(aFI : PffFileInfo; - aTI : PffTransInfo; - aIndex : integer); -var - FileHeader : PffBlockHeaderFile; - InxBlock : PffBlock; - InxHeader : PffIndexHeader; - Elements : integer; - aInxRelMeth, - aRelMethod : TffReleaseMethod; -begin - { First get an Exclusive lock on the file header, block 0.} - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_MarkDirty, - aRelMethod)); - try - { Second get an Exclusive lock on the index header. } - InxBlock := ReadVfyInxBlock(aFI, aTI, FileHeader, ffc_MarkDirty, - ffc_InxBlockTypeHeader, - FileHeader^.bhfIndexHeader, aInxRelMeth); - InxHeader := PffIndexHeader(@InxBlock^[ffc_BlockHeaderSizeIndex]); - - { Remove the index data. } - with InxHeader^ do begin - if (aIndex < pred(ffcl_MaxIndexes)) then begin - Elements := pred(ffcl_MaxIndexes - aIndex); - Move(bihIndexKeyLen[succ(aIndex)], bihIndexKeyLen[aIndex], Elements * sizeof(word)); - Move(bihIndexFlags[succ(aIndex)], bihIndexFlags[aIndex], Elements * sizeof(byte)); - Move(bihIndexRoot[succ(aIndex)], bihIndexRoot[aIndex], Elements * sizeof(Longint)); - Move(bihIndexPageCount[succ(aIndex)], bihIndexPageCount[aIndex], Elements * sizeof(Longint)); - end; - bihIndexKeyLen[pred(ffcl_MaxIndexes)] := 0; - bihIndexFlags[pred(ffcl_MaxIndexes)] := 0; - bihIndexRoot[pred(ffcl_MaxIndexes)] := ffc_W32NoValue; - bihIndexPageCount[pred(ffcl_MaxIndexes)] := 0; - end; - aInxRelMeth(InxBlock); - finally - aRelMethod(PffBlock(FileHeader)); - end; -end; -{--------} -procedure FFTblPrepareIndexes(aFI : PffFileInfo; - aTI : PffTransInfo); -var - FileHeader : PffBlockHeaderFile; - InxBlock : PffBlock; - InxBlockHdr : PffBlockHeaderIndex absolute InxBlock; - InxHeader : PffIndexHeader; - aInxRelMeth, - aRelMethod : TffReleaseMethod; -begin - { First get the file header, block 0. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, ffc_MarkDirty, - aRelMethod)); - try - {create the index header block} - InxBlock := GetNewInxHeaderBlock(aFI, aTI, aInxRelMeth); - with FileHeader^ do begin - bhfIndexHeader := InxBlockHdr^.bhiThisBlock; - InxHeader := PffIndexHeader(@InxBlock^[ffc_BlockHeaderSizeIndex]); - with InxHeader^ do begin - {set up the internal fields} - FillChar(bihIndexKeyLen, sizeof(bihIndexKeyLen), 0); - FillChar(bihIndexFlags, sizeof(bihIndexFlags), 0); - FillChar(bihIndexRoot, sizeof(bihIndexRoot), ffc_W32NoValue); - FillChar(bihIndexPageCount, sizeof(bihIndexPageCount), 0); - end; - end; - aInxRelMeth(InxBlock); - finally - aRelMethod(PffBlock(FileHeader)); - end; -end; -{====================================================================} - - -{===Keypath routines=================================================} -procedure FFInitKeyPath(var aKeyPath : TffKeyPath); -begin - FillChar(aKeyPath, sizeof(aKeyPath), 0); -end; -{--------} -procedure FFSetKeyPathToBOF(var aKeyPath : TffKeyPath); -begin - FillChar(aKeyPath, sizeof(aKeyPath), 0); - aKeyPath.kpPos := kppBOF; -end; -{--------} -procedure FFSetKeyPathToEOF(var aKeyPath : TffKeyPath); -begin - FillChar(aKeyPath, sizeof(aKeyPath), 0); - aKeyPath.kpPos := kppEOF; -end; -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/fftbstrm.pas b/components/flashfiler/sourcelaz/fftbstrm.pas deleted file mode 100644 index f7e89000f..000000000 --- a/components/flashfiler/sourcelaz/fftbstrm.pas +++ /dev/null @@ -1,320 +0,0 @@ -{*********************************************************} -{* FlashFiler: Table access to streams *} -{*********************************************************} - -(* ***** 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 fftbstrm; - -interface - -uses - Windows, - SysUtils, - Classes, - ffconst, - ffllbase, - ffsrmgr, - ffllexcp, - ffsrbase, - ffsrlock, - fffile, - fftbbase; - -procedure FFTblDeleteStream(aFI : PffFileInfo; - aTI : PffTransInfo; - aStreamNr : TffWord32); - {-Deletes a stream from the file} - -procedure FFTblReadStream(aFI : PffFileInfo; - aTI : PffTransInfo; - aStreamNr : TffWord32; - aStream : TStream); - {-Reads a stream from the file} - { NOTE: the data is read to the current position of the stream} - -procedure FFTblWriteStream(aFI : PffFileInfo; - aTI : PffTransInfo; - var aStreamNr : TffWord32; - aStream : TStream; - aCreateNew: boolean; - aStreamID : Longint); - {-Writes a stream to the file; optionally creates it as a new one} - -implementation - -{===Helper routines==================================================} -function AddNewStreamBlock(FI : PffFileInfo; - TI : PffTransInfo; - FileHeader : PffBlockHeaderFile; - PrevStreamBlock: PffBlock; - var aReleaseMethod : TffReleaseMethod) : PffBlock; -var - StreamBlock : PffBlock; - StrmBlockHdr : PffBlockHeaderStream absolute StreamBlock; - PrevStrmBlockHdr : PffBlockHeaderStream absolute PrevStreamBlock; -begin - {Note: assumes that PrevStreamBlock has been marked dirty} - with FileHeader^ do begin - {get a new block} - StreamBlock := FFTblHlpGetNewBlock(FI, TI, aReleaseMethod); - FillChar(StreamBlock^[ffc_BlockHeaderSizeStream], - (bhfBlockSize - ffc_BlockHeaderSizeStream), 0); - {set up the stream block header information} - with StrmBlockHdr^ do begin - bhsSignature := ffc_SigStreamBlock; - bhsNextBlock := $FFFFFFFF; - bhsLSN := 0; - bhsNextStrmBlock := $FFFFFFFF; - bhsStreamType := 0; - bhsStreamLength := 0; - bhsOwningStream := 0; - end; - {chain this block to the previous stream block} - if Assigned(PrevStreamBlock) then begin - PrevStrmBlockHdr^.bhsNextStrmBlock := StrmBlockHdr^.bhsThisBlock; - end; - end; - Result := StreamBlock; -end; -{--------} -function ReadVfyStreamBlock(FI : PffFileInfo; - TI : PffTransInfo; - const aBlockNumber : TffWord32; - const aMarkDirty : boolean; - var aReleaseMethod : TffReleaseMethod) : PffBlock; -var - StreamBlock : PffBlock; - StrmBlockHdr: PffBlockHeaderStream absolute StreamBlock; -begin - with FI^ do begin - {verify the block number} - if (aBlockNumber <= 0) or (aBlockNumber >= fiUsedBlocks) then - FFRaiseException(EffServerException, ffStrResServer, fferrBadBlockNr, - [FI^.fiName^, aBlockNumber]); - {now get the stream block} - StreamBlock := FFBMGetBlock(FI, TI, aBlockNumber, aMarkDirty, - aReleaseMethod); - {verify that it's a stream block} - if (StrmBlockHdr^.bhsSignature <> ffc_SigStreamBlock) or - (StrmBlockHdr^.bhsThisBlock <> aBlockNumber) then - FFRaiseException(EffServerException, ffStrResServer, fferrBadStreamBlock, - [FI^.fiName^, aBlockNumber]); - end; - Result := StreamBlock; -end; -{--------} -procedure DeleteStreamPrim(FI : PffFileInfo; - TI : PffTransInfo; - FileHeader : PffBlockHeaderFile; - aStreamNr : Longint; - aKeep1stBlock: boolean); -var - StreamBlock : PffBlock; - StrmBlockHdr: PffBlockHeaderStream absolute StreamBlock; - NextBlock : TffWord32; - aReleaseMethod : TffReleaseMethod; -begin - - { Assumption: File header block is exclusively locked. } - - { Read & verify the 1st block for the stream. } - StreamBlock := ReadVfyStreamBlock(FI, TI, aStreamNr, true, aReleaseMethod); - - try - { Get the next block. } - NextBlock := StrmBlockHdr^.bhsNextStrmBlock; - - { If required, delete this block. } - if not aKeep1stBlock then - FFTblHlpDeleteBlock(FI, FileHeader, StreamBlock); - finally - aReleaseMethod(StreamBlock); - end; - - { Delete the succeeding blocks. } - while NextBlock <> ffc_W32NoValue do begin - { Read & verify the next stream block. } - StreamBlock := ReadVfyStreamBlock(FI, TI, NextBlock, true, aReleaseMethod); - try - { Get the next stream block. } - NextBlock := StrmBlockHdr^.bhsNextStrmBlock; - - { Add this block to the free blocks list. } - FFTblHlpDeleteBlock(FI, FileHeader, StreamBlock); - finally - aReleaseMethod(StreamBlock); - end; - end; -end; -{====================================================================} - - - -{===Stream routines==================================================} -procedure FFTblDeleteStream(aFI : PffFileInfo; - aTI : PffTransInfo; - aStreamNr : TffWord32); -var - FileHeader : PffBlockHeaderFile; - aReleaseMethod : TffReleaseMethod; -begin - {first get the file header, block 0} - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, true, - aReleaseMethod)); - try - {now delete the entire chain of blocks in the stream} - DeleteStreamPrim(aFi, aTI, FileHeader, aStreamNr, false); - finally - aReleaseMethod(PffBlock(FileHeader)); - end; -end; -{--------} -procedure FFTblReadStream(aFI : PffFileInfo; - aTI : PffTransInfo; - aStreamNr : TffWord32; - aStream : TStream); -var - StreamBlock : PffBlock; - StrmBlockHdr : PffBlockHeaderStream absolute StreamBlock; - NextBlock : TffWord32; - BytesToGo : Longint; - BytesToCopy : Longint; - MaxDataInBlock: integer; - ThisBlock : TffWord32; - aStrmRelMethod : TffReleaseMethod; -begin - { Calculate the maximum size of each stream block. } - MaxDataInBlock := aFI^.fiBlockSize - ffc_BlockHeaderSizeStream; - - { Read & verify the first block for the stream. } - ThisBlock := aStreamNr; - StreamBlock := ReadVfyStreamBlock(aFI, aTI, ThisBlock, false, - aStrmRelMethod); - try - BytesToGo := StrmBlockHdr^.bhsStreamLength; - while (BytesToGo > 0) do begin - { Copy the data from the block to the stream. } - BytesToCopy := FFMinL(MaxDataInBlock, BytesToGo); - aStream.Write(StreamBlock^[ffc_BlockHeaderSizeStream], BytesToCopy); - dec(BytesToGo, BytesToCopy); - - { Calc the next stream block. } - NextBlock := StrmBlockHdr^.bhsNextStrmBlock; - - if (BytesToGo <> 0) then begin - ThisBlock := NextBlock; - aStrmRelMethod(StreamBlock); - { Read & verify the next block for the stream. } - StreamBlock := ReadVfyStreamBlock(aFI, aTI, ThisBlock, false, - aStrmRelMethod); - end; - end; - finally - aStrmRelMethod(StreamBlock); - end; -end; -{--------} -procedure FFTblWriteStream(aFI : PffFileInfo; - aTI : PffTransInfo; - var aStreamNr : TffWord32; - aStream : TStream; - aCreateNew: boolean; - aStreamID : Longint); -var - FileHeader : PffBlockHeaderFile; - StreamBlock : PffBlock; - StrmBlockHdr : PffBlockHeaderStream absolute StreamBlock; - BytesToGo : Longint; - BytesToCopy : Longint; - MaxDataInBlock : Integer; - aFHRelMethod, - aStrmRelMethod : TffReleaseMethod; - PrevStreamBlock : PffBlock; {!!.01} - PrevStrmBlockHdr : PffBlockHeaderStream; {!!.01} - PrevStrmRelMethod : TffReleaseMethod; {!!.01} -begin - - { Get the file header block. } - FileHeader := PffBlockHeaderFile(FFBMGetBlock(aFI, aTI, 0, true, - aFHRelMethod)); - try - { If we are rewriting the stream, delete all but the first block, - then read that first block} - if not aCreateNew then begin - DeleteStreamPrim(aFI, aTI, FileHeader, aStreamNr, true); - StreamBlock := ReadVfyStreamBlock(aFI, aTI, aStreamNr, true, - aStrmRelMethod); - end - { Otherwise we are creating a new stream, so get a new block. } - else begin - StreamBlock := AddNewStreamBlock(aFI, aTI, FileHeader, nil, - aStrmRelMethod); - with StrmBlockHdr^ do begin - aStreamNr := bhsThisBlock; - bhsOwningStream := aStreamNr; - end; - end; - StrmBlockHdr^.bhsStreamType := aStreamID; - { Set the stream length and therefore the number of bytes to copy. } - BytesToGo := aStream.Size; - StrmBlockHdr^.bhsStreamLength := BytesToGo; - MaxDataInBlock := FileHeader^.bhfBlockSize - ffc_BlockHeaderSizeStream; - - { Prepare the stream (position at start). } - aStream.Seek(0, soFromBeginning); - - { Copy the stream data to this block and other blocks, as required. } - BytesToCopy := FFMinL(MaxDataInBlock, BytesToGo); - aStream.Read(StreamBlock^[ffc_BlockHeaderSizeStream], BytesToCopy); - dec(BytesToGo, BytesToCopy); - while (BytesToGo > 0) do begin - PrevStreamBlock := StreamBlock; {!!.01} - PrevStrmBlockHdr := StrmBlockHdr; {!!.01} - PrevStrmRelMethod := aStrmRelMethod; {!!.01} - {aStrmRelMethod(StreamBlock);} {!!.01 deleted} - StreamBlock := AddNewStreamBlock(aFI, aTI, FileHeader, StreamBlock, - aStrmRelMethod); - PrevStrmBlockHdr^.bhsNextBlock := StrmBlockHdr^.bhsThisBlock; {!!.01} - PrevStrmRelMethod(PrevStreamBlock); {!!.01} - with StrmBlockHdr^ do begin - bhsOwningStream := aStreamNr; - bhsStreamType := aStreamID; - end; - BytesToCopy := FFMinL(MaxDataInBlock, BytesToGo); - aStream.Read(StreamBlock^[ffc_BlockHeaderSizeStream], BytesToCopy); - dec(BytesToGo, BytesToCopy); - end; - finally - aStrmRelMethod(StreamBlock); - aFHRelMethod(PffBlock(FileHeader)); - end; -end; -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/ffutil.pas b/components/flashfiler/sourcelaz/ffutil.pas deleted file mode 100644 index 943a09b5f..000000000 --- a/components/flashfiler/sourcelaz/ffutil.pas +++ /dev/null @@ -1,590 +0,0 @@ -{*********************************************************} -{* FlashFiler: Client utility 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 ffutil; - -interface -uses - DB, - ffdb, - Windows, - Messages, - Classes, - SysUtils, - ffllprot, - fflldict, - ffllbase, - ffstdate; - -type - TffCopyTableProgressEvent = procedure (Index : Integer); - - -procedure KillExternalServer(const aBlocking : Boolean); - { - Kill the server process running locally } - -function FFGetMaxAutoInc(aTable : TffTable) : Longint; - { - Retrieve the MaxAutoInc value used in a table. This routine does - not get the last one used, instead it queries each record and - returns the highest key currently in the table. } - -function FFGetProtocolString (Protocol : TffProtocolType) : string; - { - Converts a TffProtocolType value to a string value } - -function FFGetProtocolType (ProtocolStr : string) : TffProtocolType; - { - Converts the specified string to a valid TffProtocolType } - -procedure FFRetrieveLiveServers(const Protocol: TffProtocolType; ServerNames : TStringList); - { - Fills ServerName with a list of servers for the specified protocol. - Care is taken to remove the local server if it cannot be found. } - -procedure FFSeparateAddress(const Original : string; - var Name : string; - var Address : string); - { - Breaks the specifid address into Name & address parts } - -function FFTransferRecord(Source, Dest : TDataSet) : Boolean; - { - Transfers the current record from Source to Dest, matching fields by - name. The result will be true if the routine was successful. } - -procedure FFCopyTableData(SourceTable, DestTable : TDataset); - { - Transfers the records from SourceTable to DestTable. SourceTable's - cursor will be First and finish at EOF. Ranges and Filters will not - be disturbed by this routine } - -procedure FFCopyTableDataEx(SourceTable, DestTable : TDataset; ProgressEvent: TffCopyTableProgressEvent); - { - Transfers the records from SourceTable to DestTable. SourceTable's - cursor will be First and finish at EOF. Ranges and Filters will not - be disturbed by this routine. This routine has the ability to - call a progress event } - -procedure FFStringToVCheckVal(const aStr : string; - const aType : TffFieldType; - var aVal : TffVCheckValue); -{ Converts a string to a TffVCheckValue. Used to set the default - for a field in the data dictionary } - -function FFVCheckValToString(const aVal : TffVCheckValue; - const aType : TffFieldType) : String; -{ Converts a TffVCheckValue to a string. Used to retrieve a string - representation of the default value for a field in a data - dictionary } - -implementation - -uses - FFClCfg, - FFCLconv; - -procedure KillExternalServer(const aBlocking : Boolean); -var - Handle : THandle; -begin - Handle := FindWindowEx(0, 0, 'TfrmFFServer', nil); - if Handle > 0 then - if aBlocking then - SendMessage(Handle, WM_Close, 0, 0) - else - PostMessage(Handle, WM_Close, 0, 0); -end; -{--------} -function FFGetMaxAutoInc(aTable : TffTable) : Longint; -var - MaxSeed : Longint; - AField : TAutoIncField; -begin - AField := nil; - for MaxSeed := 0 to Pred(aTable.FieldCount) do - if aTable.Fields[MaxSeed] is TAutoIncField then begin - AField := TAutoIncField(aTable.Fields[MaxSeed]); - Break; - end; - if not Assigned(AField) then begin - Result := 0; - Exit; - end; - - MaxSeed := 0; - aTable.First; - while not aTable.EOF do begin - if AField.Value > MaxSeed then - MaxSeed := AField.Value; - aTable.Next; - end; - Result := MaxSeed; -end; -{--------} -function FFGetProtocolString (Protocol : TffProtocolType) : string; -begin - case Protocol of - ptIPXSPX : Result := ffc_IPXSPX; - ptTCPIP : Result := ffc_TCPIP; - else - Result := ffc_SingleUser; - end; -end; -{--------} -function FFGetProtocolType (ProtocolStr : string) : TffProtocolType; -begin - if ProtocolStr = ffc_IPXSPX then - Result := ptIPXSPX - else if ProtocolStr = ffc_TCPIP then - Result := ptTCPIP - else - Result := ptSingleUser; -end; -{--------} -procedure FFRetrieveLiveServers(const Protocol: TffProtocolType; ServerNames : TStringList); -var - CE : TffCommsEngine; - SE : TffSession; -begin - CE := TffCommsEngine.Create(nil); - try - CE.CommsEngineName := 'TEST'; - CE.Protocol := Protocol; - CE.Open; - ServerNames.Clear; - if Protocol <> ptSingleUser then begin - CE.GetServerNames(ServerNames); - end else begin - SE := TffSession.Create(nil); - SE.SessionName := 'TEST'; - try - SE.CommsEngineName := 'TEST'; - try - SE.Open; - ServerNames.Add('local'); - except - end; - finally - SE.Free; - end; - end; - finally - CE.Free; - end; -end; -{--------} -procedure FFSeparateAddress(const Original: string; var Name, - Address: string); -var - SepPlace : Integer; - ServerName : string; -begin - ServerName := Original; - SepPlace := Pos('@', ServerName); - if SepPlace > 0 then begin - Name := Copy(ServerName, 1, pred(SepPlace)); - Delete(ServerName,1,SepPlace); - Address := ServerName; - end else begin - Name := ServerName; - end; -end; -{--------} -function FFTransferRecord(Source, Dest : TDataSet) : Boolean; -var - i, nErr : integer; - f1, f2 : TField; -begin - nErr := 0; - if (dest.state in [dsEdit, dsInsert]) {= dsBrowse} then begin - end else begin - Dest.Edit; - end; - for I := 0 to (Dest.FieldCount - 1) do begin - f1 := Dest.FindField(Dest.Fields[I].FieldName); - f2 := Source.FindField(Dest.Fields[I].FieldName); - if (((f1 <> nil) and (f2 <> nil)) and (dest.Fields[I].FieldName <> 'RefNum') and (dest.Fields[I].FieldName <> 'AutoInc')) then begin - try - f1.value := f2.value; - except - inc(nErr); - end; - end else begin - end; - end; - Dest.Post; - Result := (nErr < Dest.FieldCount); -end; -{--------} -procedure FFCopyTableData(SourceTable, DestTable : TDataset); -begin - SourceTable.First; - while not SourceTable.EOF do begin - DestTable.Insert; - FFTransferRecord(SourceTable, DestTable); - SourceTable.Next; - end; -end; - -procedure FFCopyTableDataEx(SourceTable, DestTable : TDataset; ProgressEvent: TffCopyTableProgressEvent); -var - Idx : Integer; -begin - SourceTable.First; - Idx := 0; - while not SourceTable.EOF do begin - DestTable.Insert; - FFTransferRecord(SourceTable, DestTable); - inc(Idx); - if Assigned(ProgressEvent) then - ProgressEvent(Idx); - SourceTable.Next; - end; -end; - -procedure FFStringToVCheckVal(const aStr : string; - const aType : TffFieldType; - var aVal : TffVCheckValue); -var - 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 (aStr <> '') then begin - FillChar(aVal, SizeOf(TffVCheckValue), #0); - case aType of - fftStDate : - begin - TempStDate := FFStringToStDate(aStr); - Move(TempStDate, aVal, sizeof(TStDate)); - end; - fftStTime : - begin - TempStTime := FFStringToStTime(aStr); - Move(TempStTime, aVal, sizeof(TStTime)); - end; - fftWord16 : - begin - TempInt := StrToInt(aStr); - MapBDEDataToFF(fftWord16, sizeof(Word), @TempInt, @aVal); - end; - fftWord32 : - begin - TempInt := StrToInt(aStr); - MapBDEDataToFF(fftWord32, sizeof(TffWord32), @TempInt, @aVal); - end; - fftInt8 : - begin - TempInt := StrToInt(aStr); - MapBDEDataToFF(fftInt8, sizeof(Shortint), @TempInt, @aVal); - end; - fftInt16 : - begin - TempInt := StrToInt(aStr); - MapBDEDataToFF(fftInt16, sizeof(Smallint), @TempInt, @aVal); - end; - fftInt32 : - begin - TempInt := StrToInt(aStr); - MapBDEDataToFF(fftInt32, sizeof(Longint), @TempInt, @aVal); - end; - fftChar : - begin - TempStr := aStr; - MapBDEDataToFF(fftChar, sizeof(Char), @TempStr[1], @aVal); - end; - fftWideChar : - begin - StringToWideChar(aStr, @TempStr, sizeof(WideChar)); - MapBDEDataToFF(fftWideChar, sizeof(WideChar), @TempStr, @aVal); - end; - fftByte : - begin - TempInt := StrToInt(aStr); - MapBDEDataToFF(fftByte, sizeof(Byte), @TempInt, @aVal); - end; - fftSingle : - begin - TempSingle := StrToFloat(aStr); - Move(TempSingle, aVal, sizeof(Single)); - end; - fftDouble : - begin - TempDouble := StrToFloat(aStr); - MapBDEDataToFF(fftDouble, sizeof(Double), @TempDouble, @aVal); - end; - fftExtended : - begin - TempExtend := StrToFloat(aStr); - Move(TempExtend, aVal, sizeof(Extended)); - end; - fftComp : - begin - TempComp := StrToFloat(aStr); - Move(TempComp, aVal, sizeof(Comp)); - end; - fftCurrency : - begin - TempCurrency := StrToFloat(aStr); - Move(TempCurrency, aVal, sizeof(Currency)); - end; - fftDateTime : - begin - TempDT := StrToDateTime(aStr); - TempTS := DateTimeToTimeStamp(TempDT); - TempDT := TimeStampToMSecs(TempTS); - MapBDEDataToFF(fftDateTime, sizeof(TDateTime), @TempDT, @aVal); - end; - fftBoolean : - begin - if ((UpperCase(aStr) = 'TRUE') or (UpperCase(aStr) = 'T')) then - TempInt := 1 - else if ((UpperCase(aStr) = 'FALSE') or (UpperCase(aStr) = 'F')) then - TempInt := 0; - MapBDEDataToFF(fftBoolean, sizeof(Boolean), @TempInt, @aVal); - end; - fftByteArray : - begin - TempStr := aStr; - MapBDEDataToFF(fftByteArray, sizeof(ffcl_MaxVCheckLength), @TempStr, @aVal); - end; - fftShortAnsiStr : - begin - TempStr := aStr; - Move(TempStr, aVal, Succ(Length(aStr))); - end; - fftShortString : - begin - TempStr := aStr; - Move(TempStr, aVal, Succ(Length(aStr))); - end; - fftNullString : - begin - TempStr := aStr; - MapBDEDataToFF(fftNullString, succ(Length(TempStr)), @TempStr[1], @aVal); - end; - fftNullAnsiStr : - begin - TempStr := aStr; - MapBDEDataToFF(fftNullString, succ(Length(TempStr)), @TempStr[1], @aVal); - end; - fftWideString : - begin - StringToWideChar(aStr, @TempWideStr, (Length(aStr) * 2)); - Move(TempWideStr, aVal, (Length(aStr) * 2)); - end; - end; - end; -end; - -function FFVCheckValToString(const aVal : TffVCheckValue; - const aType : TffFieldType) - : string; - -var - TempStr : string[255]; -// TempInt8 : ShortInt; {!!.07} - TempInt16 : SmallInt; - TempInt64 : TffInt64; {!!.13} - TempInt : Longint; - TempExtend : Extended; - TempCurrency: Currency; - TempSingle : Single; - TempDouble : Double; - TempStDate : TStDate; - TempStTime : TStTime; - TempDT : TDateTime; - TempTS : TTimeStamp; - TempComp : Comp; - TempWideStr : WideString; - i : Integer; - -begin - case aType of - fftWord16 : - begin - MapFFDataToBDE(fftWord16, sizeof(Word), @aVal, @TempInt); - TempStr := IntToStr(TempInt); - end; - fftWord32 : - begin - MapFFDataToBDE(fftWord32, sizeof(TffWord32), @aVal, @TempInt); - TempStr := IntToStr(TempInt); - end; - fftInt8 : - begin - {NOTE: Int8 mapped to 16-bit integer because the VCL does not - have a 8-bit integer field type. } - MapFFDataToBDE(fftInt8, SizeOf(ShortInt), @aVal, @TempInt16); {!!.07} - TempStr := IntToStr(TempInt16); {!!.07} - end; - fftInt16 : - begin - MapFFDataToBDE(fftInt16, sizeof(Smallint), @aVal, @TempInt16); - TempStr := IntToStr(TempInt16); - end; - fftInt32 : - begin - MapFFDataToBDE(fftInt32, sizeof(Longint), @aVal, @TempInt); - TempStr := IntToStr(TempInt); - end; - fftStDate : - begin - Move(aVal, TempStDate, sizeof(TStDate)); - TempStr := FFStDateToString(TempStDate); - end; - fftStTime : - begin - Move(aVal, TempStTime, sizeof(TStTime)); - TempStr := FFStTimeToString(TempStTime); - end; - fftChar : - begin - TempInt := 1; - Move(TempInt, TempStr[0], 1); - MapFFDataToBDE(fftChar, sizeof(Char), @aVal, @TempStr[1]); - end; - fftWideChar : - begin - MapFFDataToBDE(fftWideChar, sizeof(Widechar), @aVal, @TempStr); - TempStr := WideCharToString(@TempStr);; - end; - fftByte : - begin - MapFFDataToBDE(fftByte, sizeof(Byte), @aVal, @TempInt); - TempStr := IntToStr(TempInt); - end; - fftSingle : - begin - Move(aVal, TempSingle, sizeof(Single)); - TempStr := FloatToStr(TempSingle); - end; - fftDouble : - begin - MapFFDataToBDE(fftDouble, sizeof(Double), @aVal, @TempDouble); - TempStr := FloatToStr(TempDouble); - end; - fftExtended : - begin - Move(aVal, TempExtend, sizeof(Extended)); - TempStr := FloatToStr(TempExtend); - end; - fftCurrency : - begin - Move(aVal, TempCurrency, sizeof(Currency)); - TempStr := FloatToStr(TempCurrency); - end; - fftComp : - begin - Move(aVal, TempComp, sizeof(Comp)); - TempStr := FloatToStr(TempComp); - end; - fftDateTime : - begin - MapFFDataToBDE(fftDateTime, sizeof(TDateTime), @aVal, @TempDT); - TempTS := MSecsToTimeStamp(TempDT); - TempDT := TimeStampToDateTime(TempTS); - TempStr := DateTimeToStr(TempDT); - end; - fftBoolean : - begin - MapFFDataToBDE(fftBoolean, sizeof(Boolean), @aVal, @TempInt); -// if (TempInt = 0) then {!!.12} - if Byte(TempInt) = 0 then {!!.12} - TempStr := 'False' - else - TempStr := 'True'; - end; - fftByteArray : - begin - MapFFDataToBDE(fftByteArray, ffcl_MaxVCheckLength, @aVal, @TempStr); - end; - fftShortAnsiStr : - begin - MapFFDataToBDE(fftShortAnsiStr, ffcl_MaxVCheckLength, @aVal, @TempStr); - MapFFDataToBDE(fftShortString, ffcl_MaxVCheckLength, @aVal, @TempStr[1]); - i := 0; - while TempStr[succ(i)] <> #0 do - inc(i); - SetLength(TempStr, i); - end; - fftShortString : - begin - MapFFDataToBDE(fftShortString, ffcl_MaxVCheckLength, @aVal, @TempStr[1]); - i := 0; - while TempStr[succ(i)] <> #0 do - inc(i); - SetLength(TempStr, i); - end; - fftNullString : - begin - MapFFDataToBDE(fftNullString, pred(ffcl_MaxVCheckLength), @aVal, @TempStr[1]); - i := 0; - while TempStr[succ(i)] <> #0 do - inc(i); - SetLength(TempStr, i); - end; - fftNullAnsiStr : - begin - MapFFDataToBDE(fftNullString, pred(ffcl_MaxVCheckLength), @aVal, @TempStr[1]); - i := 0; - while TempStr[succ(i)] <> #0 do - inc(i); - SetLength(TempStr, i); - end; - fftWideString : - begin - i := 0; - while ((char(aVal[i])) + - (char(aVal[succ(i)]))) <> #0#0 do - inc(i); - Move(aVal, TempWideStr, succ(i)); - TempStr := WideCharToString(@TempWideStr); - end; -{Begin !!.13} - fftBLOB..fftBLOBTypedBin : - begin - Move(aVal, TempInt64, SizeOf(TempInt64)); - TempStr := IntToStr(TempInt64.iHigh) + ':' + IntToStr(TempInt64.iLow); - end; -{End !!.13} - else - begin - TempStr := ''; - end; - end; - Result := TempStr; -end; - -end. diff --git a/components/flashfiler/sourcelaz/ffwscnst.rc b/components/flashfiler/sourcelaz/ffwscnst.rc deleted file mode 100644 index f1b44ae22..000000000 --- a/components/flashfiler/sourcelaz/ffwscnst.rc +++ /dev/null @@ -1,32 +0,0 @@ -/********************************************************* - * FlashFiler: Winsock error strings 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_WINSOCK_ERROR_STRINGS RCDATA FFWSCNST.SRM - diff --git a/components/flashfiler/sourcelaz/ffwscnst.res b/components/flashfiler/sourcelaz/ffwscnst.res deleted file mode 100644 index d2249157f..000000000 Binary files a/components/flashfiler/sourcelaz/ffwscnst.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffwscnst.srm b/components/flashfiler/sourcelaz/ffwscnst.srm deleted file mode 100644 index f46a98e45..000000000 Binary files a/components/flashfiler/sourcelaz/ffwscnst.srm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffwscnst.str b/components/flashfiler/sourcelaz/ffwscnst.str deleted file mode 100644 index 05085c19f..000000000 --- a/components/flashfiler/sourcelaz/ffwscnst.str +++ /dev/null @@ -1,85 +0,0 @@ -;********************************************************* -;* FlashFiler: Winsock error strings 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 "ffllwsct.inc" - -WSAEINTR, "Interrupted function call" -WSAEBADF, "Bad file number" -WSAEACCES, "Permission denied" -WSAEFAULT, "Unknown error" -WSAEINVAL, "Invalid argument" -WSAEMFILE, "Too many open files" -WSAEWOULDBLOCK, "Warning: the socket would block on this call" -WSAEINPROGRESS, "A blocking call is in progress" -WSAEALREADY, "WSAEALREADY: watch out, Al is ready" -WSAENOTSOCK, "Socket descriptor is (1) not a socket, or (2) is of wrong type" -WSAEDESTADDRREQ, "The destination address is required for this operation" -WSAEMSGSIZE, "The datagram was too large to fit into the buffer and was truncated" -WSAEPROTOTYPE, "WSAEPROTOTYPE" -WSAENOPROTOOPT, "The option is unknown or not supported" -WSAEPROTONOSUPPORT, "Either (1) no buffer space available so socket cannot be created or (2) protocol not supported" -WSAESOCKTNOSUPPORT, "Specified socket type not supported in this address family" -WSAEOPNOTSUPP, "Operation is not supported by this socket" -WSAEPFNOSUPPORT, "Specified protocol family is not supported" -WSAEAFNOSUPPORT, "Specified address family is not supported by this protocol" -WSAEADDRINUSE, "The address is already in use for this operation" -WSAEADDRNOTAVAIL, "The address is not available from this machine" -WSAENETDOWN, "The network subsystem has failed" -WSAENETUNREACH, "The network is unreachable from this machine at this time" -WSAENETRESET, "The network has been reset" -WSAECONNABORTED, "The virtual circuit has been aborted due to timeout, etc" -WSAECONNRESET, "The virtual circuit has been reset by the partner" -WSAENOBUFS, "The descriptor is not a socket, or no buffer space is available" -WSAEISCONN, "The socket is already connected" -WSAENOTCONN, "The socket is not connected" -WSAESHUTDOWN, "The socket has been shutdown" -WSAETOOMANYREFS, "WSAETOOMANYREFS" -WSAETIMEDOUT, "The operation timed out" -WSAECONNREFUSED, "The attempt to connect was forcibly refused" -WSAELOOP, "WSAELOOP: see WSAELOOP" -WSAENAMETOOLONG, "The name is too long" -WSAEHOSTDOWN, "The host machine is down" -WSAEHOSTUNREACH, "The host machine is unreachable" -WSAENOTEMPTY, "WSAENOTEMPTY" -WSAEPROCLIM, "WSAEPROCLIM" -WSAEUSERS, "WSAEUSERS" -WSAEDQUOT, "WSAEDQUOT" -WSAESTALE, "WSAESTALE" -WSAEREMOTE, "WSAEREMOTE" -WSAEDISCON, "WSAEDISCON" -WSASYSNOTREADY, "Network subsystem unusable" -WSAVERNOTSUPPORTED, "Version requested by WSAStartUp not supported by loaded Winsock DLL" -WSANOTINITIALISED, "WSAStartUp not yet called" -WSAHOST_NOT_FOUND, "Host not found" -WSATRY_AGAIN, "Host not found, or SERVERFAIL, can try again" -WSANO_RECOVERY, "Non recoverable errors, FORMERR, REFUSED, NOTIMP" -WSANO_DATA, "Valid name, but no data record of requested type" - - - diff --git a/components/flashfiler/sourcelaz/ffwwreg.dcr b/components/flashfiler/sourcelaz/ffwwreg.dcr deleted file mode 100644 index 27ed537d7..000000000 Binary files a/components/flashfiler/sourcelaz/ffwwreg.dcr and /dev/null differ diff --git a/components/flashfiler/sourcelaz/ffwwreg.pas b/components/flashfiler/sourcelaz/ffwwreg.pas deleted file mode 100644 index 7a41847c2..000000000 --- a/components/flashfiler/sourcelaz/ffwwreg.pas +++ /dev/null @@ -1,63 +0,0 @@ -{*********************************************************} -{* FlashFiler: Register InfoPower-compatible FF 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} - -{Notes: Based on information provided by Woll2Woll Software. - Requires InfoPower 3.01 or later - InfoPower is Copyright (c) 1995-1997 by Woll2Woll Software} - -unit ffwwreg; - -interface - -procedure Register; - -implementation - -uses - {$IFDEF DCC6OrLater} - DesignIntf, DesignEditors, - {$ELSE} - DsgnIntf, - {$ENDIF} - Classes, - Controls, - DB, - ffwwtabl, - ffclver; - -procedure Register; -begin - RegisterComponents('FlashFiler Client', [TffwwTable, TffwwQuery]); - RegisterPropertyEditor(TypeInfo(AnsiString), TffwwTable, 'Version', TffVersionProperty); - RegisterPropertyEditor(TypeInfo(AnsiString), TffwwQuery, 'Version', TffVersionProperty); -end; - -end. diff --git a/components/flashfiler/sourcelaz/ffwwtabl.pas b/components/flashfiler/sourcelaz/ffwwtabl.pas deleted file mode 100644 index 93adbd641..000000000 --- a/components/flashfiler/sourcelaz/ffwwtabl.pas +++ /dev/null @@ -1,202 +0,0 @@ -{*********************************************************} -{* FlashFiler: InfoPower-compatible FlashFiler 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} - -{Notes: Based on information provided by Woll2Woll Software. - Requires InfoPower 3.01 or later - InfoPower is Copyright (c) 1995-1999 by Woll2Woll Software} - -unit ffwwtabl; - -interface - -uses - SysUtils, - Windows, - Classes, - DB, - wwFilter, - wwStr, - wwSystem, - wwTable, - wwTypes, - ffdb; - -type - TffwwTable = class(TffTable) - protected {private} - FControlType : TStrings; - FPictureMasks : TStrings; - FUsePictureMask : boolean; - FOnInvalidValue : TwwInvalidValueEvent; - - protected - function GetControlType : TStrings; - procedure SetControlType(CT : TStrings); - function GetPictureMasks : TStrings; - procedure SetPictureMasks(PM : TStrings); - - procedure DoBeforePost; override; { For picture support } - - public - constructor Create(AOwner : TComponent); override; - destructor Destroy; override; - - published - property IndexDefs; - - property ControlType : TStrings read GetControlType write SetControltype; - property PictureMasks: TStrings read GetPictureMasks write SetPictureMasks; - property ValidateWithMask : boolean read FUsePictureMask write FUsePictureMask; - property OnInvalidValue: TwwInvalidValueEvent read FOnInvalidValue write FOnInvalidValue; - end; - - TffwwQuery = class(TffQuery) - protected {private} - FControlType : TStrings; - FPictureMasks : TStrings; - FUsePictureMask : boolean; - FOnInvalidValue : TwwInvalidValueEvent; - - protected - function GetControlType : TStrings; - procedure SetControlType(CT : TStrings); - function GetPictureMasks : TStrings; - procedure SetPictureMasks(PM : TStrings); - - procedure DoBeforePost; override; { For picture support } - - public - constructor Create(AOwner : TComponent); override; - destructor Destroy; override; - - published - property ControlType : TStrings read GetControlType write SetControltype; - property PictureMasks: TStrings read GetPictureMasks write SetPictureMasks; - property ValidateWithMask : boolean read FUsePictureMask write FUsePictureMask; - property OnInvalidValue: TwwInvalidValueEvent read FOnInvalidValue write FOnInvalidValue; - end; - -implementation - -uses - wwCommon, - DBConsts; - -{===TffwwTable=======================================================} -constructor TffwwTable.Create(AOwner : TComponent); -begin - inherited Create(AOwner); - FControlType := TStringList.Create; - FPictureMasks := TStringList.Create; - FUsePictureMask := true; -end; -{--------} -destructor TffwwTable.Destroy; -begin - FControlType.Free; - FPictureMasks.Free; - inherited Destroy; -end; -{--------} -Procedure TffwwTable.DoBeforePost; -begin - inherited DoBeforePost; - if FUsePictureMask then - wwValidatePictureFields(Self, FOnInvalidValue); -end; -{--------} -function TffwwTable.GetControlType : TStrings; -begin - Result := FControlType; -end; -{--------} -function TffwwTable.GetPictureMasks : TStrings; -begin - Result:= FPictureMasks; -end; -{--------} -procedure TffwwTable.SetControlType(CT : TStrings); -begin - FControlType.Assign(CT); -end; -{--------} -procedure TffwwTable.SetPictureMasks(PM : TStrings); -begin - FPictureMasks.Assign(PM); -end; -{====================================================================} - - -{===TffwwQuery=======================================================} -constructor TffwwQuery.Create(AOwner : TComponent); -begin - inherited Create(AOwner); - FControlType := TStringList.Create; - FPictureMasks := TStringList.Create; - FUsePictureMask := true; -end; -{--------} -destructor TffwwQuery.Destroy; -begin - FControlType.Free; - FPictureMasks.Free; - inherited Destroy; -end; -{--------} -Procedure TffwwQuery.DoBeforePost; -begin - inherited DoBeforePost; - if FUsePictureMask then - wwValidatePictureFields(Self, FOnInvalidValue); -end; -{--------} -function TffwwQuery.GetControlType : TStrings; -begin - Result := FControlType; -end; -{--------} -function TffwwQuery.GetPictureMasks : TStrings; -begin - Result:= FPictureMasks; -end; -{--------} -procedure TffwwQuery.SetControlType(CT : TStrings); -begin - FControlType.Assign(CT); -end; -{--------} -procedure TffwwQuery.SetPictureMasks(PM : TStrings); -begin - FPictureMasks.Assign(PM); -end; -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/lazcommon.pas b/components/flashfiler/sourcelaz/lazcommon.pas deleted file mode 100644 index d79d54b6c..000000000 --- a/components/flashfiler/sourcelaz/lazcommon.pas +++ /dev/null @@ -1,1691 +0,0 @@ -{ This unit is taked from fssql. - It was named fscommon.pas; - ************************************************************** - It looks like he (the author of fssql) take code from delphi! - Most of code looks like in DbCommon.pas from delphi! - ************************************************************** - - // called only from ffdb.pas -} -Unit lazcommon; - -{$T-,H+,X+,R-} -{$I ffdefine.inc} - -Interface - -Uses Classes, - {$IFDEF DCC6OrLater} - Variants, - {$ENDIF} - Db, - windows; - -Type - WCHAR = WideChar; - {$EXTERNALSYM WCHAR} - PWChar = PWideChar; - - LPSTR = PAnsiChar; - {$EXTERNALSYM LPSTR} - PLPSTR = ^LPSTR; - {$EXTERNALSYM PLPSTR} - LPCSTR = PAnsiChar; - {$EXTERNALSYM LPCSTR} - LPCTSTR = PAnsiChar; { should be PWideChar if UNICODE } - {$EXTERNALSYM LPCTSTR} - LPTSTR = PAnsiChar; { should be PWideChar if UNICODE } - {$EXTERNALSYM LPTSTR} - LPWSTR = PWideChar; - {$EXTERNALSYM LPWSTR} - PLPWSTR = ^LPWSTR; - {$EXTERNALSYM PLPWSTR} - LPCWSTR = PWideChar; - {$EXTERNALSYM LPCWSTR} - - DWORD = Longword; - {$EXTERNALSYM DWORD} - BOOL = LongBool; - {$EXTERNALSYM BOOL} - PBOOL = ^BOOL; - {$EXTERNALSYM PBOOL} - PByte = ^Byte; - PINT = ^Integer; - {$EXTERNALSYM PINT} - PSingle = ^Single; - PWORD = ^Word; - {$EXTERNALSYM PWORD} - PDWORD = ^DWORD; - {$EXTERNALSYM PDWORD} - LPDWORD = PDWORD; - {$EXTERNALSYM LPDWORD} - - UCHAR = Byte; - {$EXTERNALSYM UCHAR} - PUCHAR = ^Byte; - {$EXTERNALSYM PUCHAR} - SHORT = Smallint; - {$EXTERNALSYM SHORT} - UINT = Longword; - {$EXTERNALSYM UINT} - PUINT = ^UINT; - {$EXTERNALSYM PUINT} - ULONG = Cardinal; - {$EXTERNALSYM ULONG} - PULONG = ^ULONG; - {$EXTERNALSYM PULONG} - PLongint = ^Longint; - PInteger = ^Integer; - PLongWord = ^Longword; - PSmallInt = ^Smallint; - PDouble = ^Double; - PShortInt = ^Shortint; - - LCID = DWORD; - {$EXTERNALSYM LCID} - LANGID = Word; - {$EXTERNALSYM LANGID} - - THandle = Longword; - PHandle = ^THandle; - - TfsCANOperator = ( - 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 } - ); - - fsNODEClass = ({ 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 } - ); - -Const - CANEXPRSIZE = 10; { SizeOf(CANExpr) } - CANHDRSIZE = 8; { SizeOf(CANHdr) } - CANEXPRVERSION = 2; - -Type - TfsExprData = Array Of Byte; - TFieldMap = Array[TFieldType] Of Byte; - - { TFilterExpr } - -Type - - TfsParserOption = (poExtSyntax, poAggregate, poDefaultExpr, poUseOrigNames, - poFieldNameGiven, poFieldDepend); - TfsParserOptions = Set Of TfsParserOption; - - TfsExprNodeKind = (enField, enConst, enOperator, enFunc); - TfsExprScopeKind = (skField, skAgg, skConst); - - PExprNode = ^TfsExprNode; - TfsExprNode = Record - FNext: PExprNode; - FKind: TfsExprNodeKind; - FPartial: Boolean; - FOperator: TfsCANOperator; - FData: Variant; - FLeft: PExprNode; - FRight: PExprNode; - FDataType: TFieldType; - FDataSize: Integer; - FArgs: TList; - FScopeKind: TfsExprScopeKind; - End ; - - TFilterExpr = Class - Private - FDataSet: TDataSet; - FFieldMap: TFieldMap; - FOptions: TFilterOptions; - FParserOptions: TfsParserOptions; - FNodes: PExprNode; - FExprBuffer: TfsExprData; - 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 PutConstCurrency(Const Value: Variant): Integer; - Function PutConstBool(Const Value: Variant): Integer; - Function PutConstDate(Const Value: Variant): Integer; - Function PutConstDateTime(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; - - {$IFDEF DCC6OrLater} - {$HINTS OFF} - {$ENDIF} - Function PutConstNode64(DataType : TFieldType ; - Data : PChar ; - Size : Integer ) : Int64 ; - {$IFDEF DCC6OrLater} - {$HINTS OFF} - {$ENDIF} - - Function PutConstStr(Const Value: String): Integer; - Function PutConstFsArrayStr(Const Value: String): Integer; - Function PutConstTime(Const Value: Variant): Integer; - Function PutData(Data: PChar; Size: Integer): Integer; - Function PutExprNode(Node: PExprNode; ParentOp: TfsCANOperator): Integer; - Function PutFieldNode(Field: TField; Node: PExprNode): Integer; - Function PutNode(NodeType: fsNODEClass; OpType: TfsCANOperator; - 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: TfsParserOptions; Const FieldName: String; DepFields: TBits; - FieldMap: TFieldMap); - Destructor Destroy; Override; - Function NewCompareNode(Field: TField; Operator: TfsCANOperator; - Const Value: Variant): PExprNode; - Function NewNode(Kind: TfsExprNodeKind; Operator: TfsCANOperator; - Const Data: Variant; Left, Right: PExprNode): PExprNode; - Function GetFilterData(Root: PExprNode): TfsExprData; - Property DataSet: TDataSet Write FDataSet; - End ; - - { TExprParser } - - TfsExprToken = (etEnd, etSymbol, etName, etLiteral, etLParen, etRParen, - etEQ, etNE, etGE, etLE, etGT, etLT, etADD, etSUB, etMUL, etDIV, - etComma, etLIKE, etISNULL, etISNOTNULL, etIN); - - TExprParser = Class - Private - FFilter: TFilterExpr; - FFieldMap: TFieldMap; - FText: String; - FSourcePtr: PChar; - FTokenPtr: PChar; - FTokenString: String; - FStrTrue: String; - FStrFalse: String; - FToken: TfsExprToken; - FPrevToken: TfsExprToken; - FFilterData: TfsExprData; - FNumericLit: Boolean; - FDataSize: Integer; - FParserOptions: TfsParserOptions; - 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: TfsParserOptions; - Const FieldName: String; DepFields: TBits; FieldMap: TFieldMap); - Destructor Destroy; Override; - Procedure SetExprParams(Const Text: String; Options: TFilterOptions; - ParserOptions: TfsParserOptions; Const FieldName: String); - Property FilterData: TfsExprData Read FFilterData; - Property DataSize: Integer Read FDataSize; - End ; - - { Field Origin parser } - -Type - TfsFieldInfo = Record - DataBaseName: String; - TableName: String; - OriginalFieldName: String; - End ; - -Function fsGetFieldInfo(Const Origin: String; Var FieldInfo: TfsFieldInfo): Boolean; - -Implementation - -Uses //soner dont needed: fsllbase, - SysUtils, - {$ifndef fpc} dbconsts, Consts{$else} dbconst, lazconsts{$endif} //soner - ; - -Function fsGetFieldInfo(Const Origin: String; Var FieldInfo: TfsFieldInfo): 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, ftBytes]; - BlobFieldTypes = [ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, - ftTypedBinary]; - -Function IsNumeric(DataType: TFieldType): Boolean; -Begin - Result := DataType In [ftSmallint, ftInteger, ftWord, ftFloat, ftCurrency, - ftBCD, ftAutoInc, ftLargeInt]; -End ; - -Function IsTemporal(DataType: TFieldType): Boolean; -Begin - Result := DataType In [ftDate, ftTime, ftDateTime]; -End ; - -{ TFilterExpr } - -Constructor TFilterExpr.Create(DataSet: TDataSet; Options: TFilterOptions; - ParseOptions: TfsParserOptions; 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): TfsExprData; -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: TfsCANOperator; - 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: TfsExprNodeKind; Operator: TfsCANOperator; - 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 - // note - // bcd not implemented - {If VarType(Value) = varString Then - C := StrToCurr(String(TVarData(Value).VString)) - Else - C := Value; - CurrToBCD(C, BCD, 32, Decimals); - Result := PutConstNode(ftBCD, @BCD, 18); } - Result := 0 ; - End ; - -Function TFilterExpr.PutConstCurrency(Const Value: Variant): Integer; -Var - C: Currency; -Begin - If VarType(Value) = varString Then - C := StrToCurr(String(TVarData(Value).VString)) - Else - C := Value; - Result := PutConstNode(ftCurrency, @C, 8); -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.PutConstFloat(Const Value: Variant): Integer; -Var - F: Extended; -Begin - If VarType(Value) = varString Then - F := StrToFloat(String(TVarData(Value).VString)) - Else - F := Value; - Result := PutConstNode(ftFloat, @F, 10); -End ; - -Function TFilterExpr.PutConstInt(DataType: TFieldType; - Const Value: Variant): Integer; -Var - Size: Integer; - I: Int64; -Begin - If VarType(Value) = varString Then - I := StrToInt64(String(TVarData(Value).VString)) - Else - Begin - {$IFDEF IsNoVariantInt64} - I := Decimal(Value).lo64; - {$ELSE} - I := Value; - {$ENDIF} - End ; - Size := 8; - Case DataType Of - ftSmallint: - If (I < -32768) Or (I > 32767) Then - DatabaseError(SExprRangeError); - ftWord: - If (I < 0) Or (I > 65535) Then - DatabaseError(SExprRangeError); - 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.PutConstNode64(DataType: TFieldType; Data: PChar; - Size: Integer): Int64; -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.PutConstFsArrayStr(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(ftBytes, 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, ftWord, ftAutoInc, ftLargeInt, ftInteger: - Result := PutConstInt(Node^.FDataType, Node^.FData); - ftFloat: Result := PutConstFloat(Node^.FData); - ftString, ftWideString, ftFixedChar: - {$ifdef fpc} - if VarIsArray(Node^.FData) then //soner solves : "Invalid Variant Type Cast": - Result := PutConstStr(Node^.FData[0]) - else - {$endif} - Result := PutConstStr(Node^.FData); - ftBytes: - Result := PutConstFsArrayStr(Node^.FData); - ftDate: - Result := PutConstDate(Node^.FData); - ftTime: - Result := PutConstTime(Node^.FData); - ftDateTime: - Result := PutConstDateTime(Node^.FData); - ftBoolean: - Result := PutConstBool(Node^.FData); - ftBCD: - Result := PutConstBCD(Node^.FData, Node^.FDataSize); - ftCurrency: - Result := PutConstCurrency(Node^.FData); - Else - DatabaseErrorFmt(SExprBadConst, [Node^.FData]); - End ; -End ; - -Function TFilterExpr.PutExprNode(Node: PExprNode; ParentOp: TfsCANOperator): Integer; -Const - ReverseOperator: Array[coEQ..coLE] Of TfsCANOperator = (coEQ, coNE, coLT, - coGT, coLE, coGE); - BoolFalse: WordBool = False; -Var - Field: TField; - Left, Right, Temp: PExprNode; - LeftPos, RightPos, ListElem, PrevListElem, I: Integer; - Operator: TfsCANOperator; - CaseInsensitive, PartialLength, L: Integer; - S: AnsiString; - -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 ; - cStr : String ; - - Begin - cStr := Field.FieldName ; - If (poFieldNameGiven in FParserOptions) then - FDataSet.Translate(PChar(cStr) , 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: fsNODEClass; OpType: TfsCANOperator; - 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.fsNODEClass } - 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: TfsFieldInfo; -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 fsGetFieldInfo(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: TfsParserOptions; Const FieldName: String; - DepFields: TBits; FieldMap: TFieldMap); -Begin - 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: TfsParserOptions; 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 ; - -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 - Result := False; // wik (SysLocale.PriLangID = LANG_JAPANESE) and (Chr in [$A1..$DF]); - 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 - Begin - Inc(P); - If P^ <> '''' Then - Break; - End ; - 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', DecimalSeparator, 'e', 'E', '+', '-']) Do - Inc(P); - If ((P - 1)^ = ',') And (DecimalSeparator = ',') 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 TfsCANOperator = ( - coEQ, coNE, coGE, coLE, coGT, coLT); -Var - Operator: TfsCANOperator; - 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 TfsCANOperator = ( - coADD, coSUB, coMUL, coDIV); -Var - Operator: TfsCANOperator; - 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 TfsCANOperator = ( - coADD, coSUB, coMUL, coDIV); -Var - Operator: TfsCANOperator; - 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, 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/lazconsts.pas b/components/flashfiler/sourcelaz/lazconsts.pas deleted file mode 100644 index 61d2edab6..000000000 --- a/components/flashfiler/sourcelaz/lazconsts.pas +++ /dev/null @@ -1,46 +0,0 @@ -{taked from Delphi DBConsts.pas -used in lazcommon.pas} -unit lazconsts; - -interface - -resourcestring - // ALL FROM DBConsts.pas - SDataSetOpen = 'Cannot perform this operation on an open dataset'; - SInvalidIntegerValue = '''%s'' is not a valid integer value for field ''%s'''; - SInvalidFloatValue = '''%s'' is not a valid floating point value for field ''%s'''; - SFieldRangeError = '%g is not a valid value for field ''%s''. The allowed range is %g to %g'; - - SExprTermination = 'Filter expression incorrectly terminated'; - SExprNameError = 'Unterminated field name'; - SExprStringError = 'Unterminated string constant'; - SExprInvalidChar = 'Invalid filter expression character: ''%s'''; - SExprNoLParen = '''('' expected but %s found'; - SExprNoRParen = ''')'' expected but %s found'; - SExprNoRParenOrComma = ''')'' or '','' expected but %s found'; - SExprExpected = 'Expression expected but %s found'; - SExprBadField = 'Field ''%s'' cannot be used in a filter expression'; - SExprBadNullTest = 'NULL only allowed with ''='' and ''<>'''; - SExprRangeError = 'Constant out of range'; - SExprNotBoolean = 'Field ''%s'' is not of type Boolean'; - SExprIncorrect = 'Incorrectly formed filter expression'; - SExprNothing = 'nothing'; - SExprTypeMis = 'Type mismatch in expression'; - SExprBadScope = 'Operation cannot mix aggregate value with record-varying value'; - SExprNoArith = 'Arithmetic in filter expressions not supported'; - SExprNotAgg = 'Expression is not an aggregate expression'; - SExprBadConst = 'Constant is not correct type %s'; - SExprNoAggFilter = 'Aggregate expressions not allowed in filters'; - SExprEmptyInList = 'IN predicate list may not be empty'; - SExprNoAggOnCalcs = 'Field ''%s'' is not the correct type of calculated field to be used in an aggregate, use an internalcalc'; - - SInvalidKeywordUse = 'Invalid use of keyword'; - STextFalse = 'False'; - STextTrue = 'True'; - SBadFieldType = 'Field ''%s'' is of an unsupported type'; - SInvalidVersion = 'Unable to load bind parameters'; - SBcdOverflow = 'BCD overflow'; - // END OF ALL FROM DBConsts.pas -implementation - -end. diff --git a/components/flashfiler/sourcelaz/lazff.lpi b/components/flashfiler/sourcelaz/lazff.lpi deleted file mode 100644 index cc71e0507..000000000 --- a/components/flashfiler/sourcelaz/lazff.lpi +++ /dev/null @@ -1,77 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?> -<CONFIG> - <ProjectOptions> - <Version Value="9"/> - <PathDelim Value="\"/> - <General> - <Flags> - <MainUnitHasCreateFormStatements Value="False"/> - <MainUnitHasTitleStatement Value="False"/> - </Flags> - <SessionStorage Value="InProjectDir"/> - <MainUnit Value="0"/> - <Title Value="lazff"/> - <UseAppBundle Value="False"/> - <ResourceType Value="res"/> - </General> - <i18n> - <EnableI18N LFM="False"/> - </i18n> - <VersionInfo> - <StringTable ProductVersion=""/> - </VersionInfo> - <BuildModes Count="1"> - <Item1 Name="Default" Default="True"/> - </BuildModes> - <PublishOptions> - <Version Value="2"/> - </PublishOptions> - <RunParams> - <local> - <FormatVersion Value="1"/> - </local> - </RunParams> - <RequiredPackages Count="1"> - <Item1> - <PackageName Value="LCL"/> - </Item1> - </RequiredPackages> - <Units Count="1"> - <Unit0> - <Filename Value="lazff.lpr"/> - <IsPartOfProject Value="True"/> - </Unit0> - </Units> - </ProjectOptions> - <CompilerOptions> - <Version Value="11"/> - <PathDelim Value="\"/> - <Target> - <Filename Value="lazff"/> - </Target> - <SearchPaths> - <IncludeFiles Value="$(ProjOutDir)"/> - <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> - </SearchPaths> - <Linking> - <Options> - <Win32> - <GraphicApplication Value="True"/> - </Win32> - </Options> - </Linking> - </CompilerOptions> - <Debugging> - <Exceptions Count="3"> - <Item1> - <Name Value="EAbort"/> - </Item1> - <Item2> - <Name Value="ECodetoolError"/> - </Item2> - <Item3> - <Name Value="EFOpenError"/> - </Item3> - </Exceptions> - </Debugging> -</CONFIG> diff --git a/components/flashfiler/sourcelaz/lazff.lpr b/components/flashfiler/sourcelaz/lazff.lpr deleted file mode 100644 index a96204fb0..000000000 --- a/components/flashfiler/sourcelaz/lazff.lpr +++ /dev/null @@ -1,95 +0,0 @@ -//convert helper, project only for compiling, can be deleted now, there is lazpackage in packages folder -//compiled: 58units, max units: 84x -//converted in 6std -{hinweise -1. I replaced ffdb.ReSizePersistentFields; FieldDefList with Fielddefs because fpc doesn't has FieldDefList -Look also LazConvertReadMe.txt -} -program lazff; - -{$mode objfpc}{$H+} - -uses - {$IFDEF UNIX}{$IFDEF UseCThreads} - cthreads, - {$ENDIF}{$ENDIF} - Interfaces, // this includes the LCL widgetset - classes, forms, - ffdb, - fflllgcy, - ffclreng; - -type - { TForm1 } - TForm1 = class(TForm) - public - ffSess: TffSession; - CustomerTable: TffTable; - ffClient: TffClient; - ffRSE: TFFRemoteServerEngine; - ltMain: TffLegacyTransport; - constructor Create(TheOwner: TComponent); override; - destructor Destroy; override; - procedure FormShow(Sender: TObject); - end; - -var Form1: TForm1; - -{ TForm1 } - -constructor TForm1.Create(TheOwner: TComponent); -begin - inherited Create(TheOwner); - Caption:='FlashFiler2 for Lazarus'; - - //ff2 - ltMain:= TffLegacyTransport.Create(self); - ltMain.Enabled:=true; - - ffRSE:= TFFRemoteServerEngine.Create(self); - ffRSE.Transport := ltMain; - - ffClient:= TffClient.Create(Self); - ffClient.ClientName := 'ffClient'; - ffClient.ServerEngine := ffRSE; - - ffSess:= TffSession.Create(Self); - ffSess.ClientName := 'ffClient'; - ffSess.SessionName := 'ExCust'; - - CustomerTable:= TffTable.Create(self); - CustomerTable.DatabaseName := 'Tutorial'; - CustomerTable.IndexName := 'ByID'; - CustomerTable.SessionName := 'ExCust'; - CustomerTable.TableName := 'ExCust'; - CustomerTable.Timeout := 10000; - - OnShow:=@FormShow; -end; - -destructor TForm1.Destroy; -begin - inherited Destroy; -end; - -procedure TForm1.FormShow(Sender: TObject); -var aPath : string; -const csAlias = 'Tutorial'; -begin - ffSess.Open; - if not ffSess.IsAlias(csAlias) then begin - ffSess.AddAlias(csAlias, 'D:\AppDev\TDLite\Comps\flashfiler\examples',False); - {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; - -begin - RequireDerivedFormResource:=false; - Application.Initialize; - Application.CreateForm(TForm1, Form1); - Application.Run; -end. - diff --git a/components/flashfiler/sourcelaz/server/ffserver.dpr b/components/flashfiler/sourcelaz/server/ffserver.dpr deleted file mode 100644 index 8e0a6d14e..000000000 --- a/components/flashfiler/sourcelaz/server/ffserver.dpr +++ /dev/null @@ -1,56 +0,0 @@ -{*********************************************************} -{* FlashFiler Server 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 ***** *) - -program FFServer; - -{$I FFDEFINE.INC} - -uses - {$IFDEF USETeDEBUG} - TeDebug, - {$ENDIF} - Forms, - Uffsmain in 'Uffsmain.pas' {frmFFServer}, - Uffsalas in 'Uffsalas.pas' {FFAliasForm}, - uFFSBrws in 'UFFSBRWS.PAS' {DirBrowseForm}, - Uffsuser in 'Uffsuser.pas' {FFUserForm}, - Uffspwd in 'Uffspwd.pas' {PwdForm}, - Uffsgenl in 'Uffsgenl.pas' {FFGenConfigForm}, - UFFSINDX in 'UFFSINDX.PAS' {FFIndexForm}, - uFFEgMgr in 'uFFEgMgr.pas' {FFEngineMgr: TffBaseEngineManager}, - Uffsnet in 'Uffsnet.pas' {FFNetConfigForm}, - uFFSRJrn in '..\uffsrjrn.pas' {JournalForm}; - -{$R FFSERVER.RES} - -begin - Application.HelpFile := 'ffserver.hlp'; - Application.CreateForm(TfrmFFServer, frmFFServer); - Application.Run; -end. diff --git a/components/flashfiler/sourcelaz/server/ffserver.rc b/components/flashfiler/sourcelaz/server/ffserver.rc deleted file mode 100644 index 60126920b..000000000 --- a/components/flashfiler/sourcelaz/server/ffserver.rc +++ /dev/null @@ -1,169 +0,0 @@ -/********************************************************* - * 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 00 00 00 00 4C 44 C4 40 00 00 00 00 00 00 00' - '00 00 00 00 44 C4 4C 44 C4 40 00 00 00 00 00 00' - '00 00 00 04 4C 34 C4 4C 44 C4 00 00 00 00 00 00' - '00 00 00 44 44 33 44 C4 4C 44 C0 00 00 00 00 00' - '00 00 04 44 44 C3 4C 44 C4 4C 4C 00 00 00 00 00' - '00 00 44 44 4C 43 C4 4C 44 C4 C4 C0 00 00 00 00' - '00 00 44 44 44 43 34 C4 4C 4C 4C 40 00 00 00 00' - '00 04 44 44 44 C3 33 44 C4 C4 C4 CC 00 00 00 00' - '00 04 44 44 4C 43 33 3C 4C 4C 4C CC 00 00 00 00' - '00 04 44 44 44 33 33 34 C4 C4 CC C3 00 00 00 00' - '00 04 44 44 44 33 33 3C 4C 4C CC 33 00 00 00 00' - '00 04 44 44 43 33 33 44 C4 CC 33 33 00 00 00 00' - '00 04 44 44 44 34 44 4C 4C CC 33 33 00 00 00 00' - '00 04 44 44 44 34 44 34 CC CC C3 33 00 00 00 00' - '00 04 44 44 43 33 33 3C CC CC 33 33 00 00 00 00' - '00 00 40 00 00 00 33 3C CC CC CC C0 00 00 00 99' - '99 90 40 99 99 90 33 33 CC CC C3 30 00 00 00 09' - '90 00 04 09 90 03 33 33 CC CC C3 00 00 00 00 09' - '90 00 00 09 90 33 33 3C CC CC C0 00 00 00 00 09' - '90 00 00 09 90 44 04 CC CC CC 00 00 00 00 00 09' - '90 00 90 09 90 00 90 CC CC C0 00 00 00 00 00 09' - '99 99 90 09 99 99 90 CC C0 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 FF FF FF FF FF FC 07 FF FF F0' - '01 FF FF E0 00 FF FF C0 00 7F FF 80 00 3F FF 00' - '00 1F FF 00 00 1F FE 00 00 0F FE 00 00 0F FE 00' - '00 0F FE 00 00 0F FE 00 00 0F FE 00 00 0F FE 00' - '00 0F FE 00 00 0F FF 7F 00 1F C1 41 00 1F E7 A6' - '00 3F E7 E4 00 7F E7 E4 80 FF E7 67 41 FF E0 60' - '47 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' -} - - -LOCKEDPADLOCK BITMAP -{ - '42 4D 66 01 00 00 00 00 00 00 76 00 00 00 28 00' - '00 00 14 00 00 00 14 00 00 00 01 00 04 00 00 00' - '00 00 F0 00 00 00 00 00 00 00 00 00 00 00 00 00' - '00 00 10 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 33 33 33 33 33 33 33 33 33 33' - '00 00 33 33 33 30 00 00 03 33 33 33 00 00 33 33' - '33 08 78 87 80 33 33 33 00 00 33 33 30 88 78 87' - '88 03 33 33 00 00 33 33 30 77 70 07 77 03 33 33' - '00 00 33 33 30 88 80 08 88 03 33 33 00 00 33 33' - '30 88 00 00 88 03 33 33 00 00 33 33 30 77 00 00' - '77 03 33 33 00 00 33 33 30 88 88 88 88 03 33 33' - '00 00 33 33 30 88 88 88 88 03 33 33 00 00 33 33' - '30 00 00 00 00 03 33 33 00 00 33 33 30 80 33 33' - '08 03 33 33 00 00 33 33 30 80 33 33 08 03 33 33' - '00 00 33 33 30 80 33 33 08 03 33 33 00 00 33 33' - '30 88 00 00 88 03 33 33 00 00 33 33 33 08 88 88' - '80 33 33 33 00 00 33 33 33 30 00 00 03 33 33 33' - '00 00 33 33 33 33 33 33 33 33 33 33 00 00 33 33' - '33 33 33 33 33 33 33 33 00 00 33 33 33 33 33 33' - '33 33 33 33 00 00' -} - - -UNLOCKEDPADLOCK BITMAP -{ - '42 4D 66 01 00 00 00 00 00 00 76 00 00 00 28 00' - '00 00 14 00 00 00 14 00 00 00 01 00 04 00 00 00' - '00 00 F0 00 00 00 00 00 00 00 00 00 00 00 00 00' - '00 00 10 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 33 33 33 33 33 33 33 33 33 33' - '00 00 33 33 00 00 00 33 33 33 33 33 00 00 33 30' - '87 88 78 03 33 33 33 33 00 00 33 08 87 88 78 80' - '33 33 33 33 00 00 33 07 77 00 77 70 33 33 33 33' - '00 00 33 08 88 00 88 80 33 33 33 33 00 00 33 08' - '80 00 08 80 33 33 33 33 00 00 33 07 70 00 07 70' - '33 33 33 33 00 00 33 08 88 88 88 80 33 33 33 33' - '00 00 33 08 88 88 88 80 33 33 33 33 00 00 33 30' - '00 00 00 00 33 33 33 33 00 00 33 33 33 33 30 80' - '33 33 33 33 00 00 33 33 33 33 30 80 33 33 30 33' - '00 00 33 33 33 33 30 80 33 33 08 03 00 00 33 33' - '33 33 30 80 33 33 08 03 00 00 33 33 33 33 30 78' - '00 00 87 03 00 00 33 33 33 33 33 07 88 88 70 33' - '00 00 33 33 33 33 33 30 00 00 03 33 00 00 33 33' - '33 33 33 33 33 33 33 33 00 00 33 33 33 33 33 33' - '33 33 33 33 00 00' -} - - -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 Server\000" - VALUE "FileVersion", "2.1.3.0\000" - VALUE "InternalName", "FFSERVER\000" - VALUE "LegalCopyright", "Copyright (c) TurboPower Software Co. 1996-2002\000\000" - VALUE "OriginalFilename", "FFSERVER.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/server/ffserver.res b/components/flashfiler/sourcelaz/server/ffserver.res deleted file mode 100644 index ee90cde64..000000000 Binary files a/components/flashfiler/sourcelaz/server/ffserver.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/server/uffegmgr.dfm b/components/flashfiler/sourcelaz/server/uffegmgr.dfm deleted file mode 100644 index f1e967b50..000000000 Binary files a/components/flashfiler/sourcelaz/server/uffegmgr.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/server/uffegmgr.pas b/components/flashfiler/sourcelaz/server/uffegmgr.pas deleted file mode 100644 index 451cc6e6b..000000000 --- a/components/flashfiler/sourcelaz/server/uffegmgr.pas +++ /dev/null @@ -1,209 +0,0 @@ -{*********************************************************} -{* FlashFiler: Engine manager *} -{* Generated on 12/21/2002 with Release 2.0500 *} -{*********************************************************} - -(* ***** 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 uFFEgMgr; - -interface - -uses - windows, messages, sysutils, classes, controls, forms, fflleng, ffsreng, - ffllcomm, fflllgcy, fflllog, ffllthrd, ffnetmsg, ffsrintm, ffsrcmd, ffllbase, - ffsrsec, ffsqlbas, ffsqleng, ffllcomp, ffsrjour; - -type - TFFEngineManager = class(TffBaseEngineManager) - ServerEngine : TFFServerEngine; - EventLog : TffEventLog; - CommandHandler : TFFServerCommandHandler; - SecurityMonitor : TFFSecurityMonitor; - ThreadPool : TFFThreadPool; - SUPTransport : TFFLegacyTransport; - IPXSPXTransport : TFFLegacyTransport; - TCPIPTransport : TFFLegacyTransport; - SQLEngine: TffSqlEngine; - private - { private declarations } - protected - FScriptFile : TffFullFileName; - function GetLogEnabled : boolean; - procedure SetLogEnabled(const aEnabled : boolean); - procedure SetScriptFile(const aFileName : TffFullFileName); - public - constructor Create(Sender: TComponent); override; - procedure GetServerEngines(var aServerList : TffList); - procedure GetTransports(aServer : TffIntermediateServerEngine; var aTransList : TffList); - procedure Process(Msg : PffDataMessage; var Handled : Boolean); override; - procedure Restart; override; - procedure Shutdown; override; - procedure Startup; override; - procedure Stop; override; - - { Properties } - property EventLogEnabled : boolean - read GetLogEnabled - write SetLogEnabled; - - property ScriptFile : TffFullFileName - read FScriptFile - write SetScriptFile; - - end; - -var - FFEngineManager: TFFEngineManager; - -implementation - -{$R *.DFM} - -{====================================================================} -constructor TFFEngineManager.Create(Sender: TComponent); -begin - inherited Create(Sender); - EventLog.FileName := ExtractFilePath(Application.ExeName) + 'FFServer.log'; -end; -{--------} -function TFFEngineManager.GetLogEnabled : boolean; -var - Idx : Integer; -begin - Result := False; - { Assumption: Event log is enabled if we find a server engine - that is routing events to the log. } - for Idx := 0 to Pred(ComponentCount) do - if (Components[Idx] is TffBaseServerEngine) then begin - Result := TffBaseServerEngine(Components[Idx]).EventLogEnabled; - break; - end; -end; -{--------} -procedure TFFEngineManager.GetServerEngines(var aServerList: TffList); -var - ServerListItem : TffIntListItem; - i : Integer; -begin - for I := 0 to Pred(ComponentCount) do - if (Components[i] is TffBaseServerEngine) then begin - ServerListItem := TffIntListItem.Create(longint(Components[i])); - aServerList.Insert(ServerListItem); - end; -end; -{--------} -procedure TFFEngineManager.GetTransports(aServer : TffIntermediateServerEngine; - var aTransList : TffList); -var - TransportItem : TffIntListItem; - i, k : Integer; -begin - for i := 0 to Pred(aServer.CmdHandlerCount) do begin - for k := 0 to Pred(aServer.CmdHandler[i].TransportCount) do begin - TransportItem := TffIntListItem.Create(Integer(aServer.CmdHandler[i].Transports[k])); - aTransList.Insert(TransportItem); - end; - end; -end; -{--------} -procedure TFFEngineManager.Process(Msg : PffDataMessage; var Handled : Boolean); -begin - Handled := True; - case Msg.dmMsg of - ffnmServerRestart : Restart; - ffnmServerShutdown : Shutdown; - ffnmServerStartUp : Startup; - ffnmServerStop : Stop; - else - Handled := False; - end; -end; -{--------} -procedure TFFEngineManager.Restart; -begin - Shutdown; - Startup; -end; -{--------} -procedure TFFEngineManager.SetLogEnabled(const aEnabled : boolean); -var - Idx : Integer; -begin - { Assumption: TffBaseLog is always enabled. We just control which - components are issuing messages to the log. } - for Idx := 0 to Pred(ComponentCount) do - if (Components[Idx] is TffLoggableComponent) and - not (Components[Idx] is TffBaseTransport) then - TffLoggableComponent(Components[Idx]).EventLogEnabled := aEnabled -end; -{--------} -procedure TFFEngineManager.SetScriptFile(const aFileName : TffFullFileName); -var - Idx : Integer; -begin - FScriptFile := aFileName; - for Idx := 0 to Pred(ComponentCount) do - if (Components[Idx] is TffServerEngine) then - TffServerEngine(Components[Idx]).ScriptFile := aFileName; -end; -{--------} -procedure TFFEngineManager.Shutdown; -var - Idx : Integer; -begin - for Idx := 0 to Pred(ComponentCount) do - if ((Components[Idx] is TFFBaseServerEngine) or - (Components[Idx] is TFFBasePluginEngine)) and - not (TffStateComponent(Components[Idx]).State in - [ffesInactive, ffesStopped]) then - TffStateComponent(Components[Idx]).Shutdown; -end; -{--------} -procedure TFFEngineManager.Startup; -var - Idx : Integer; -begin - for Idx := 0 to Pred(ComponentCount) do - if (Components[Idx] is TFFBaseServerEngine) or - (Components[Idx] is TFFBasePluginEngine) then - TffStateComponent(Components[Idx]).Startup; -end; -{--------} -procedure TFFEngineManager.Stop; -var - Idx : Integer; -begin - for Idx := 0 to Pred(ComponentCount) do - if (Components[Idx] is TFFBaseServerEngine) or - (Components[Idx] is TFFBasePluginEngine) then - TffStateComponent(Components[Idx]).Stop; -end; -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/server/uffsalas.dfm b/components/flashfiler/sourcelaz/server/uffsalas.dfm deleted file mode 100644 index ccb304f80..000000000 Binary files a/components/flashfiler/sourcelaz/server/uffsalas.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/server/uffsalas.pas b/components/flashfiler/sourcelaz/server/uffsalas.pas deleted file mode 100644 index 7c4c6c3f8..000000000 --- a/components/flashfiler/sourcelaz/server/uffsalas.pas +++ /dev/null @@ -1,569 +0,0 @@ -{*********************************************************} -{* Alias dialog and maintenance 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 ***** *) - -unit uFFSAlas; - -{$I FFDEFINE.INC} - -interface - -uses - Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, Buttons, ExtCtrls, Grids, Windows, ToolWin, Menus, - ComCtrls, - {$IFDEF DCC4ORLATER} - ImgList, - {$ENDIF} - FFLLBase, - FFLLGrid, - FFLLUNC, - FFTbDict, - FFSrBDE, - FFSrTran, - FFSrCfg, - FFSrEng; - -type - TFFAliasForm = class(TForm) - pnlAliasPath: TPanel; - btnCommit: TBitBtn; - btnCancel: TBitBtn; - grdAliases: TffStringGrid; - tbMain: TToolBar; - pbDelete: TToolButton; - ToolButton2: TToolButton; - pbBrowse: TToolButton; - imMain: TImageList; - mnuMain: TMainMenu; - mnuAlias: TMenuItem; - mnuAliasDelete: TMenuItem; - mnuAliasBrowse: TMenuItem; - imgChkBoxClear: TImage; - imgChkBoxSet: TImage; - procedure btnDeleteClick(Sender: TObject); - procedure btnBrowseClick(Sender: TObject); - procedure btnCommitClick(Sender: TObject); - procedure FormShow(Sender: TObject); - procedure grdAliasesDrawCell(Sender: TObject; ACol, ARow: Integer; - Rect: TRect; State: TGridDrawState); - procedure grdAliasesKeyPress(Sender: TObject; var Key: Char); - procedure grdAliasesKeyDown(Sender: TObject; var Key: Word; - Shift: TShiftState); - procedure grdAliasesExitCell(Sender: TffStringGrid; aCol, - aRow: Integer; const text: String); - procedure grdAliasesSortColumn(Sender: TffStringGrid; aCol: Integer); - procedure grdAliasesSelectCell(Sender: TObject; ACol, ARow: Integer; - var CanSelect: Boolean); - procedure grdAliasesMouseUp(Sender: TObject; Button: TMouseButton; - Shift: TShiftState; X, Y: Integer); - private - { Private declarations } - FEngine : TffServerEngine; - FLastPath : TffPath; - - procedure afPopulateColHeaders; - procedure afPopulateGrid; - procedure afSetColumnWidths; {!!.11} - procedure afSetEngine(anEngine : TffServerEngine); - - public - { Public declarations } - - property ServerEngine : TffServerEngine read FEngine write afSetEngine; - end; - -var - FFAliasForm: TFFAliasForm; - -implementation - -{$R *.DFM} - -uses - FileCtrl, - uFFSBrws, - ffLLExcp; - -const - { Column constants } - cnAlias = 0; - cnPath = 1; - cnCheckSpace = 2; {!!.11} - - { Cell margin constants } - cnTopMargin = 2; - cnLeftMargin = 2; - - { Boolean field constants } {!!.11} - cnTrue = 1; - cnFalse = 0; - -{== Helper methods ===================================================} -procedure TFFAliasForm.afSetEngine(anEngine : TffServerEngine); -begin - FEngine := anEngine; - - { Set the row count. } - FEngine.Configuration.AliasList.BeginRead; - try - grdAliases.RowCount := FEngine.Configuration.AliasList.Count + 2; - finally - FEngine.Configuration.AliasList.EndRead; - end; - grdAliases.Row := 1; -end; -{=====================================================================} - -{== Grid methods & event handlers ====================================} -procedure TFFAliasForm.afPopulateColHeaders; -begin - with grdAliases do begin - BeginUpdate; - try - Cells[cnAlias, 0] := 'Alias'; - Cells[cnPath, 0] := 'Path'; - Cells[cnCheckSpace, 0] := 'Check space'; {!!.11} - finally - EndUpdate; - end; - end; -end; -{--------} -procedure TffAliasForm.afPopulateGrid; -var - AliasItem : TffAliasItem; - Inx : Integer; -begin - with grdAliases do begin - BeginUpdate; - FEngine.Configuration.AliasList.BeginRead; - try - for Inx := 1 to FEngine.Configuration.AliasList.Count do begin - AliasItem := FEngine.Configuration.AliasList[pred(Inx)]; - Cells[cnAlias, Inx] := AliasItem.Alias; - Cells[cnPath, Inx] := AliasItem.Path; - if (AliasItem.CheckSpace) then {!!.11 - Start} - Objects[cnCheckSpace, Inx] := Pointer(cnTrue) - else - Objects[cnCheckSpace, Inx] := Pointer(cnFalse); {!!.11 - End} - end; - finally - FEngine.Configuration.AliasList.EndRead; - EndUpdate; - end; - end; -end; -{--------} -procedure TFFAliasForm.grdAliasesDrawCell(Sender : TObject; - aCol, - aRow : Integer; - Rect : TRect; - State : TGridDrawState); -{!!.11 - Rewritten to add disk space checking option. } -var - Grid : TffStringGrid absolute Sender; - aStr : string; - aBitmap : Graphics.TBitmap; - Dest, - Source : TRect; -begin - - { Leave fixed portion of the grid alone} - if gdFixed in State then - Exit; - - with Grid do begin - if (aCol = cnPath) then begin - aStr := Grid.Cells[aCol, aRow]; - if (aStr <> '') and (not FFDirectoryExists(aStr)) then begin - Canvas.Brush.Color := clRed; - Canvas.Font.Color := clWhite; - end; - Canvas.FillRect(Rect); - Canvas.TextRect(Rect, - Rect.Left + cnLeftMargin, - Rect.Top + cnTopMargin, - aStr); - end else if (aCol = cnCheckSpace) then begin - if (Longint(Grid.Objects[aCol, aRow]) = cnTrue) then - aBitmap := imgChkBoxSet.Picture.Bitmap - else - aBitmap := imgChkBoxClear.Picture.Bitmap; - with Grid.Canvas do begin - Dest := Bounds(Rect.Left + ((Rect.Right - aBitmap.Width - Rect.Left) div 2), - Rect.Top + (Grid.DefaultRowHeight - aBitmap.Height) div 2, - aBitmap.Width, - aBitmap.Height); - Source := Bounds(0, 0, aBitmap.Width, aBitmap.Height); - BrushCopy(Dest, - aBitmap, - Source, - aBitmap.TransparentColor); - end; - end; - end; -end; -{--------} -procedure TFFAliasForm.grdAliasesExitCell(Sender : TffStringGrid; - aCol, - aRow : Integer; - const Text : string); -begin - if (aCol = cnPath) and (Text <> '') and FFDirectoryExists(Text) then - Sender.Cells[aCol, aRow] := FFExpandUNCFileName(Text); -end; -{--------} -procedure TFFAliasForm.grdAliasesKeyDown(Sender : TObject; - var Key : Word; - Shift : TShiftState); -var - Grid : TffStringGrid absolute Sender; -begin - { Change the selected cell (Enter as tab)} - case Key of - VK_RETURN : - with Grid do begin - if Col < Pred(ColCount) then - Col := Col + 1 - else if Row < Pred(RowCount) then begin - Row := Row + 1; - Col := cnAlias; - end else begin - { Is this cell blank? } - if Cells[Col, Row] = '' then begin - { Yes. Wrap to first row of grid. } - Row := 1; - Col := cnAlias; - end else begin - { No. Add a new blank row. } - RowCount := RowCount + 1; - Row := Pred(RowCount); - Col := cnAlias; - end; - end; - end; - VK_DOWN : - with Grid do begin - { Are we trying to arrow down from an incomplete row? } - if (Row = pred(RowCount)) then - if AnyCellIsEmpty(Row) then begin - { Yes. Do not allow this to occur. } - Key := 0; - MessageBeep(0); - end else - { No. Make sure we have a new blank row. } - RowCount := RowCount + 1; - end; - VK_UP, VK_TAB : - with Grid do begin - { Are we trying to arrow up from or Tab forward out of a new, - completed row? } - if ((Row = Pred(RowCount)) and {!!.11 - Start} - (Cells[cnAlias, Row] <> '') and - (Cells[cnPath, Row] <> '')) then {!!.11 - End} - { Yes. Add a new blank row. } - RowCount := RowCount + 1; - end; - end; { case } -end; -{--------} -procedure TFFAliasForm.grdAliasesKeyPress(Sender : TObject; - var Key : Char); -const - ValidEditKeys = [#8, #13]; -var - Grid : TffStringGrid absolute Sender; - Ignore : Boolean; - Value : string; -begin - if not (Key in ValidEditKeys) then begin - { Validate data entry as key's are pressed} - case Grid.Col of - cnAlias: - begin - Value := Grid.Cells[cnAlias, Grid.Row]; - Ignore := (Length(Value) >= ffcl_GeneralNameSize); - end; - - cnPath: - begin - Value := Grid.Cells[cnPath, Grid.Row]; - Ignore := (Length(Value) >= ffcl_Path) - end; - - cnCheckSpace: {!!.11 - Start} - begin - Ignore := (Key <> ' '); - if (not Ignore) then begin - if (Longint(Grid.Objects[Grid.Col, Grid.Row]) = cnTrue) then - Grid.Objects[Grid.Col, Grid.Row] := Pointer(cnFalse) - else - Grid.Objects[Grid.Col, Grid.Row] := Pointer(cnTrue); - end; - end; {!!.11 - End} - else - Ignore := False; - end; - if Ignore then begin - Key := #0; - MessageBeep(0); - end; - end; -end; -{--------} -procedure TFFAliasForm.grdAliasesSelectCell(Sender : TObject; - aCol, - aRow : Integer; - var CanSelect : Boolean); -var - Grid : TffStringGrid absolute Sender; -begin - CanSelect := True; {!!.11 - Start} - {if we're on the checkspace column, no editing} - if (aCol >= cnCheckSpace) then - Grid.Options := Grid.Options - [goAlwaysShowEditor, goEditing] - else {otherwise allow editing} - Grid.Options := Grid.Options + [goEditing]; {!!.11 - End} - - pbBrowse.Enabled := (ACol = cnPath); - mnuAliasBrowse.Enabled := pbBrowse.Enabled; -end; -{--------} -procedure TFFAliasForm.grdAliasesSortColumn(Sender : TffStringGrid; - aCol : Integer); -var - aStr : string; - i, j : Integer; - LastRow : Integer; -begin - if (Sender.RowCount > 1) then - with Sender do begin - - if LastRowIsEmpty then - LastRow := (RowCount - 2) - else - LastRow := pred(RowCount); - - BeginUpdate; - try - for i := 1 to LastRow do begin - SaveRow(i); - aStr := Cells[aCol, i]; - j := i; - while (j > 1) and - (ansiCompareStr(Cells[aCol, j-1], aStr) > 0) do begin - CopyRow(j-1, j); - dec(j); - end; { while } - RestoreToRow(j); - end; { for } - finally - EndUpdate; - end; - end; { with } -end; - -{=====================================================================} - -{== Button methods ===================================================} -procedure TFFAliasForm.btnBrowseClick(Sender : TObject); -var - BrowseForm : TDirBrowseForm; -begin - BrowseForm := TDirBrowseForm.Create(Application); - try - if DirectoryExists(GrdAliases.Cells[cnPath, grdAliases.Row]) then - BrowseForm.dirBox.Directory := GrdAliases.Cells[cnPath, grdAliases.Row] - else if (FLastPath <> '') and DirectoryExists(FLastPath) then - BrowseForm.dirBox.Directory := FLastPath; - if (BrowseForm.ShowModal = mrOK) then - with grdAliases do begin - FLastPath := BrowseForm.dirBox.Directory; - BeginUpdate; - try - Cells[cnPath, Row] := FFExpandUNCFileName(BrowseForm.DirBox.Directory); - finally - EndUpdate; - end; - end; - finally - BrowseForm.Free; - end;{try..finally} -end; -{--------} -procedure TFFAliasForm.btnCommitClick(Sender : TObject); -var - aResult : TffResult; - Inx : Integer; - errStr : array [0..127] of Char; - CheckSpace : Boolean; {!!.11} -begin - { Get rid of the aliases. } - FEngine.Configuration.AliasList.BeginWrite; - try - FEngine.Configuration.AliasList.Empty; - - { Xfer the info from the grid to the server engine's alias list. } - for Inx := 1 to pred(grdAliases.RowCount) do begin - if ((grdAliases.Cells[cnAlias, Inx] <> '') and {!!.11 - Start} - (grdAliases.Cells[cnPath, Inx] <> '')) then begin - CheckSpace := (Longint(grdAliases.Objects[cnCheckSpace, Inx]) = cnTrue); - FEngine.Configuration.AddAlias(grdAliases.Cells[cnAlias, Inx], - grdAliases.Cells[cnPath, Inx], - CheckSpace); - end; {!!.11 - End} - end; - - { Save the aliases. } - aResult := FEngine.WriteAliasData; - finally - FEngine.Configuration.AliasList.EndWrite; - end; - - if (aResult <> DBIERR_NONE) then begin - ffStrResBDE.GetASCIIZ(aResult, errStr, sizeof(DBIMSG)); - ShowMessage(Format('Could not save aliases: %s [$%x/%d])', - [strPas(errStr), aResult, aResult])); - ModalResult := mrNone; - end; -end; -{--------} -procedure TFFAliasForm.btnDeleteClick(Sender : TObject); -var - DeletedRow : Integer; - Inx : Integer; - LastEmpty : Boolean; - LastRow : Integer; -begin - - if (grdAliases.RowCount < 2) then - Exit; - - with grdAliases do begin - BeginUpdate; - try - DeletedRow := Row; - LastRow := pred(RowCount); - LastEmpty := LastRowIsEmpty; - - { Situations where delete is okay: - 1. Non-last row - 2. Last row and it is not empty } - - { Does user want to delete the last row? } - if (DeletedRow < LastRow) then begin - - { No. Move the rows up by one. } - for Inx := succ(DeletedRow) to lastRow do - CopyRow(Inx, pred(Inx)); - - { Get rid of the last row. } - RowCount := RowCount - 1; - - end else if (not LastEmpty) then - { Yes, user wants to delete last row and it is not empty. } - BlankRow(Row); - - finally - EndUpdate; - end; - end; - -end; -{=====================================================================} - -{== Form methods =====================================================} -procedure TFFAliasForm.FormShow(Sender : TObject); -begin - afSetColumnWidths; {!!.11} - afPopulateColHeaders; - afPopulateGrid; - grdAliases.SetFocus; - pbBrowse.Enabled := False; - mnuAliasBrowse.Enabled := pbBrowse.Enabled; - FLastPath := ''; -end; -{=====================================================================} - -{!!.11 - New } -procedure TFFAliasForm.afSetColumnWidths; -begin - with grdAliases do begin - ColWidths[cnAlias] := 100; - ColWidths[cnCheckSpace] := 75; - ColWidths[cnPath] := grdAliases.ClientWidth - 181; - end; -end; - -{!!.11 - New} -procedure TFFAliasForm.grdAliasesMouseUp(Sender : TObject; - Button : TMouseButton; - Shift : TShiftState; - X, Y : Integer); -var - aCol, - aRow : Longint; - Rect, - Dest : TRect; - Grid : TffStringGrid absolute Sender; -begin - if (Button = mbLeft) then begin - Grid.MouseToCell(X, Y, aCol, aRow); - if (aRow >= 0) then begin - if (aCol = cnCheckSpace) then begin - Rect := Grid.CellRect(aCol, aRow); - { Retrieve the rect from around the box itself} - if (Longint(grdAliases.Objects[cnCheckSpace, aRow]) = cnTrue) then - with imgChkBoxSet.Picture do - Dest := Bounds(Rect.Left + ((Rect.Right - Bitmap.Width - Rect.Left) div 2), - Rect.Top + (Grid.DefaultRowHeight - Bitmap.Height) div 2, - Bitmap.Width, - Bitmap.Height) - else - with imgChkBoxClear.Picture do - Dest := Bounds(Rect.Left + ((Rect.Right - Bitmap.Width - Rect.Left) div 2), - Rect.Top + (Grid.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) then begin - if (Longint(Grid.Objects[aCol, aRow]) = cnTrue) then - Grid.Objects[aCol, aRow] := Pointer(cnFalse) - else - Grid.Objects[aCol, aRow] := Pointer(cnTrue); - end; - end; - end; - end; -end; - -end. diff --git a/components/flashfiler/sourcelaz/server/uffsbrws.dfm b/components/flashfiler/sourcelaz/server/uffsbrws.dfm deleted file mode 100644 index 9f7a3c9c8..000000000 Binary files a/components/flashfiler/sourcelaz/server/uffsbrws.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/server/uffsbrws.pas b/components/flashfiler/sourcelaz/server/uffsbrws.pas deleted file mode 100644 index 85dde75a9..000000000 --- a/components/flashfiler/sourcelaz/server/uffsbrws.pas +++ /dev/null @@ -1,70 +0,0 @@ -{*********************************************************} -{* Browsing for directories for aliases *} -{*********************************************************} - -(* ***** 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 uFFSBrws; - -{$I FFDEFINE.INC} - -interface - -uses - Messages, - SysUtils, - Classes, - Graphics, - Controls, - Forms, - Dialogs, - StdCtrls, - Buttons, - FileCtrl, - ExtCtrls; - -type - TDirBrowseForm = class(TForm) - pblUpper: TPanel; - pnlLower: TPanel; - dirBox: TDirectoryListBox; - drvBox: TDriveComboBox; - btnOK: TBitBtn; - btnCancel: TBitBtn; - private - { Private declarations } - public - { Public declarations } - end; - -var - DirBrowseForm: TDirBrowseForm; - -implementation - -{$R *.DFM} - -end. diff --git a/components/flashfiler/sourcelaz/server/uffscfg.pas b/components/flashfiler/sourcelaz/server/uffscfg.pas deleted file mode 100644 index d46943d84..000000000 --- a/components/flashfiler/sourcelaz/server/uffscfg.pas +++ /dev/null @@ -1,111 +0,0 @@ -(* ***** 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 uFFsCfg; - -interface -uses - IniFiles, - Forms; - -procedure FFSConfigSaveFormPrefs(const Section : string; Form : TForm); -procedure FFSConfigGetFormPrefs(const Section : string; Form : TForm); -procedure FFSConfigGetFormPos(const Section : string; Form : TForm); {!!.06} - -var - FFSIni : TIniFile; - -implementation -uses - SysUtils; - -procedure FFSConfigSaveFormPrefs(const Section : string; Form : TForm); -begin - FFSIni.WriteInteger(Section, 'Top', Form.Top); - FFSIni.WriteInteger(Section, 'Left', Form.Left); - FFSIni.WriteInteger(Section, 'Height', Form.Height); - FFSIni.WriteInteger(Section, 'Width', Form.Width); -end; -{--------} -procedure FFSConfigGetFormPrefs(const Section : string; Form : TForm); -{Rewritten !!.06} -var - TmpInt : Integer; -begin - TmpInt := FFSIni.ReadInteger(Section, 'Top', -1); - if TmpInt = -1 then begin - { If no settings available then make sure form height & width do - not exceed the values specified at design-time. For some reason, - on some PCs the initial width & height are given a different - value than established in the IDE. } - if Form.Height > 320 then - Form.Height := 320; - if Form.Width > 600 then - Form.Width := 600; - end - else - begin - Form.Top := TmpInt; - Form.Left := FFSIni.ReadInteger(Section, 'Left', 10); - Form.Height := FFSIni.ReadInteger(Section, 'Height', 318); - Form.Width := FFSIni.ReadInteger(Section, 'Width', 600); - end; { if } -end; -{Begin !!.06} -{--------} -procedure FFSConfigGetFormPos(const Section : string; Form : TForm); -var - TmpInt : Integer; -begin - TmpInt := FFSIni.ReadInteger(Section, 'Top', -1); - { Assumption: If no positioning information found then position the form to - screen center. Otherwise, set position to poDesigned so that it will show - up at the correct coordinates. } - if TmpInt = -1 then - Form.Position := poScreenCenter - else - Form.Position := poDesigned; -end; -{End !!.06} -{--------} -procedure InitUnit; -begin - FFSIni := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'FFServer.ini'); -end; -{--------} -procedure TermUnit; -begin - FFSIni.Free; - FFSIni := nil; -end; -{--------} - -initialization - InitUnit; - -finalization - TermUnit; - -end. diff --git a/components/flashfiler/sourcelaz/server/uffsgenl.dfm b/components/flashfiler/sourcelaz/server/uffsgenl.dfm deleted file mode 100644 index 89733f75d..000000000 Binary files a/components/flashfiler/sourcelaz/server/uffsgenl.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/server/uffsgenl.pas b/components/flashfiler/sourcelaz/server/uffsgenl.pas deleted file mode 100644 index 3f9c9f2bd..000000000 --- a/components/flashfiler/sourcelaz/server/uffsgenl.pas +++ /dev/null @@ -1,296 +0,0 @@ -{*********************************************************} -{* General info maintenance *} -{*********************************************************} - -(* ***** 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 uFFSGenl; - -{$I FFDEFINE.INC} - -interface - -uses - Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - ExtCtrls, StdCtrls, Buttons, - FFSrEng, FFSrCfg; - -type - TFFGenConfigForm = class(TForm) - grpGeneral: TGroupBox; - lblServerName: TLabel; - lblMaxRAM: TLabel; - lblPriority: TLabel; - edtServerName: TEdit; - edtMaxRAM: TEdit; - cbxPriority: TComboBox; - boxEncrypt: TCheckBox; - boxReadOnly: TCheckBox; - boxSecurity: TCheckBox; - boxDebugLog: TCheckBox; - boxNoSaveCfg: TCheckBox; - gbxStartup: TGroupBox; - boxServerUp: TCheckBox; - boxMinimize: TCheckBox; - gbxKeepAlive: TGroupBox; - lblLMInterval: TLabel; - lblBetKeeps: TLabel; - lblKARetries: TLabel; - edtLastMsg: TEdit; - edtKAInterval: TEdit; - edtKARetries: TEdit; - btnDiscard: TBitBtn; - btnSave: TBitBtn; - lblTempStoreSize: TLabel; - edtTempStoreSize: TEdit; - gbCollect: TGroupBox; - boxCollectEnabled: TCheckBox; - lblCollectFreq: TLabel; - edtCollectFreq: TEdit; - procedure btnSaveClick(Sender: TObject); - procedure FormCreate(Sender: TObject); - procedure FormShow(Sender: TObject); - procedure boxReadOnlyClick(Sender: TObject); - procedure boxNoSaveCfgClick(Sender: TObject); - procedure boxCollectEnabledClick(Sender: TObject); - private - { Private declarations } - FEngine : TffServerEngine; - OurGenInfo : TffGeneralInfo; - - procedure InitCtrlStates; - procedure SetControls; - procedure SetEngine(anEngine : TffServerEngine); - - public - { Public declarations } - property ServerEngine : TffServerEngine read FEngine write SetEngine; - { The server engine being configured by this dialog. } - end; - -var - FFGenConfigForm: TFFGenConfigForm; - -implementation - -uses - FFLLComp, - FFLLEng, - FFLLExcp, - FFLLBase, - FFSRBde, - FFLLProt; - -{$R *.DFM} - -{=====================================================================} -procedure TFFGenConfigForm.boxReadOnlyClick(Sender: TObject); -begin - SetControls; -end; -{--------} -procedure TFFGenConfigForm.btnSaveClick(Sender : TObject); -const - PortError = 'Port number should be a unique number between 1024 and 65535 inclusive'; - MaxRAMError = 'Max RAM should have a value between 1 and 2048MB'; - IntervalError = 'The interval should be a number between 1,000 and 86,400,000 milliseconds, inclusive'; - RetriesError = 'The number of retries should be a number between 1 and 100, inclusive'; - TempStorSizeError = 'The temporary storage size should have a value between 1 and 2048MB'; - CollectFreqError = 'The garbage collection frequency should be between 30,000 (30 seconds) and 3,600,000 (60 minutes) milliseconds'; -var - ec : Integer; - MaxRAM : Integer; - TempStorSize : Integer; - CollectFreq : Longint; - LMInterval : Longint; - KAInterval : Longint; - KARetries : Integer; - errStr : array [0..127] of char; - aResult : TffResult; - OverRideRO : Boolean; -begin - Val(edtMaxRAM.Text, MaxRAM, ec); - if (ec <> 0) or (MaxRAM < 1) or (MaxRam > 2048) then begin - ActiveControl := edtMaxRAM; - ShowMessage(MaxRAMError); - Exit; - end; - Val(edtTempStoreSize.Text, TempStorSize, ec); - if (ec <> 0) or (TempStorSize < 1) or (TempStorSize > 2048) then begin - ActiveControl := edtTempStoreSize; - ShowMessage(TempStorSizeError); - Exit; - end; - Val(edtCollectFreq.Text, CollectFreq, ec); - if (ec <> 0) or (CollectFreq < 30000) or (CollectFreq > 3600000) then begin - ActiveControl := edtCollectFreq; - ShowMessage(CollectFreqError); - Exit; - end; - Val(edtLastMsg.Text, LMInterval, ec); - if (ec <> 0) or (LMInterval < 1000) or (LMInterval > 86400000) then begin - ActiveControl := edtLastMsg; - ShowMessage(IntervalError); - Exit; - end; - Val(edtKAInterval.Text, KAInterval, ec); - if (ec <> 0) or (KAInterval < 1000) or (KAInterval > 86400000) then begin - ActiveControl := edtKAInterval; - ShowMessage(IntervalError); - Exit; - end; - Val(edtKARetries.Text, KARetries, ec); - if (ec <> 0) or (KARetries < 1) or (KARetries > 100) then begin - ActiveControl := edtKARetries; - ShowMessage(RetriesError); - Exit; - end; - with OurGenInfo do begin - if (edtServerName.Text <> '') then - giServerName := edtServerName.Text; - giMaxRAM := MaxRAM; - {$IFDEF SecureServer} - giAllowEncrypt := boxEncrypt.Checked; - {$ELSE} - giAllowEncrypt := False; {!!.01} - {$ENDIF} - giReadOnly := boxReadOnly.Checked; - giIsSecure := boxSecurity.Checked; - giAutoUp := boxServerUp.Checked; - giAutoMini := boxMinimize.Checked; - giDebugLog := boxDebugLog.Checked; - giLastMsgInterval := LMInterval; - giKAInterval := KAInterval; - giKARetries := KARetries; - giTempStoreSize := TempStorSize; - giCollectEnabled := boxCollectEnabled.Checked; - giCollectFreq := CollectFreq; - ffc_LastMsgInterval := giLastMsgInterval; - ffc_KeepAliveInterval := giKAInterval; - ffc_KeepAliveRetries := giKARetries; - if (0 <= cbxPriority.ItemIndex) and - (cbxPriority.ItemIndex <= 4) then - giPriority := cbxPriority.ItemIndex - 2 - else - giPriority := 0; - giNoAutoSaveCfg := boxNoSaveCfg.Checked; - end; - {we have to override the ReadOnly setting if we're changing - ReadOnly or NoAutoSaveCfg from False to True.} - with FEngine.Configuration do begin - OverrideRO := ((OurGenInfo.giReadOnly and - (not GeneralInfo^.giReadOnly)) or - (OurGenInfo.giNoAutoSaveCfg and - (not GeneralInfo^.giNoAutoSaveCfg))); - GeneralInfo^ := OurGenInfo; - end; - aResult := FEngine.WriteGeneralInfo(OverrideRO); - if aResult <> DBIERR_NONE then begin - ffStrResBDE.GetASCIIZ(aResult, errStr, sizeof(DBIMSG)); - ShowMessage(Format('Could not save configuration: %s [$%x/%d])', - [strPas(errStr), aResult, aResult])); - ModalResult := mrNone; - end - else - ModalResult := mrOK; -end; -{--------} -procedure TFFGenConfigForm.FormCreate(Sender : TObject); -begin - FEngine := nil; -end; -{--------} -procedure TFFGenConfigForm.FormShow(Sender : TObject); -begin - if FEngine = nil then - Exit; - InitCtrlStates; - if FEngine.State = ffesStarted then - edtMaxRAM.SetFocus - else - edtServerName.SetFocus; -end; - -{--------} -procedure TFFGenConfigForm.InitCtrlStates; -var - ServerUp : Boolean; -begin - ServerUp := (FEngine.State = ffesStarted); - edtServerName.Enabled := (not ServerUp); -end; -{--------} -procedure TFFGenConfigForm.SetControls; -begin - boxNoSaveCfg.Enabled := not boxReadOnly.Checked; - edtCollectFreq.Enabled := boxCollectEnabled.Checked; -end; -{--------} -procedure TFFGenConfigForm.SetEngine(anEngine : TffServerEngine); -begin - FEngine := anEngine; - if assigned(FEngine) then begin - OurGenInfo := FEngine.Configuration.GeneralInfo^; - with OurGenInfo do begin - edtServerName.Text := giServerName; - edtMaxRAM.Text := IntToStr(giMaxRAM); - {$IFDEF SecureServer} - boxEncrypt.Checked := giAllowEncrypt; - {$ELSE} - boxEncrypt.Checked := False; {!!.01} - boxEncrypt.Enabled := False; {!!.01} - {$ENDIF} - boxReadOnly.Checked := giReadOnly; - boxNoSaveCfg.Checked := giNoAutoSaveCfg; - boxSecurity.Checked := giIsSecure; - boxServerUp.Checked := giAutoUp; - boxMinimize.Checked := giAutoMini; - boxDebugLog.Checked := giDebugLog; - edtLastMsg.Text := IntToStr(giLastMsgInterval); - edtKAInterval.Text := IntToStr(giKAInterval); - edtKARetries.Text := IntToStr(giKARetries); - if (giPriority < -2) or (giPriority > 2) then - cbxPriority.ItemIndex := 2 - else - cbxPriority.ItemIndex := giPriority + 2; - edtTempStoreSize.Text := InttoStr(giTempStoreSize); - boxCollectEnabled.Checked := giCollectEnabled; - edtCollectFreq.Text := IntToStr(giCollectFreq); - end; - end; -end; -{=====================================================================} -procedure TFFGenConfigForm.boxNoSaveCfgClick(Sender : TObject); -begin - SetControls; -end; - -procedure TFFGenConfigForm.boxCollectEnabledClick(Sender : TObject); -begin - SetControls; -end; - -end. diff --git a/components/flashfiler/sourcelaz/server/uffsindx.dfm b/components/flashfiler/sourcelaz/server/uffsindx.dfm deleted file mode 100644 index 34e1013a7..000000000 Binary files a/components/flashfiler/sourcelaz/server/uffsindx.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/server/uffsindx.pas b/components/flashfiler/sourcelaz/server/uffsindx.pas deleted file mode 100644 index ab56af9df..000000000 --- a/components/flashfiler/sourcelaz/server/uffsindx.pas +++ /dev/null @@ -1,457 +0,0 @@ -{*********************************************************} -{* User-defined index dialog and maintenance 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 ***** *) - -unit uFFSIndx; - -{$I FFDEFINE.INC} - -interface - -uses - Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, Buttons, ExtCtrls, Windows, Grids, ComCtrls, ToolWin, Menus, - {$IFDEF DCC4ORLATER} - ImgList, - {$ENDIF} - FFLLBase, - ffllgrid, - FFSrEng; - -type - TffKeyProcItemRec = class(TffUCStrListItem) - kirTable : TffFullFileName; - kirIndexID : longint; - kirDLL : TffFullFileName; - kirBuildKey: TffName; - kirCompKey : TffName; - constructor Create; - end; - -type - TFFIndexForm = class(TForm) - pnlBottom: TPanel; - btnSave: TBitBtn; - btnDiscard: TBitBtn; - dlgOpenTable: TOpenDialog; - dlgOpenDLL: TOpenDialog; - grdIndexes: TffStringGrid; - tbMain: TToolBar; - pbDelete: TToolButton; - ToolButton2: TToolButton; - pbBrowse: TToolButton; - imMain: TImageList; - mnuMain: TMainMenu; - mnuIndex: TMenuItem; - mnuIndexBrowse: TMenuItem; - mnuIndexDelete: TMenuItem; - procedure btnBrowseClick(Sender: TObject); - procedure btnDeleteClick(Sender: TObject); - procedure btnSaveClick(Sender: TObject); - procedure FormShow(Sender: TObject); - procedure grdIndexesExitCell(Sender: TffStringGrid; aCol, - aRow: Integer; const text: String); - procedure grdIndexesDrawCell(Sender: TObject; ACol, ARow: Integer; - Rect: TRect; State: TGridDrawState); - procedure grdIndexesKeyDown(Sender: TObject; var Key: Word; - Shift: TShiftState); - procedure grdIndexesKeyPress(Sender: TObject; var Key: Char); - procedure grdIndexesSortColumn(Sender: TffStringGrid; aCol: Integer); - procedure grdIndexesSelectCell(Sender: TObject; ACol, ARow: Integer; - var CanSelect: Boolean); - private - { Private declarations } - FEngine : TffServerEngine; - - procedure ifPopulateColHeaders; - procedure ifPopulateGrid; - procedure ifSetEngine(anEngine : TffServerEngine); - - public - { Public declarations } - - property ServerEngine: TffServerEngine read FEngine write ifSetEngine; - end; - -var - FFIndexForm: TFFIndexForm; - -implementation - -uses - FFLLUNC, - FFLLExcp, - FFSRBde, - FFSrCfg; - -{$R *.DFM} - -const - { Column constants } - cnTableName = 0; - cnIndex = 1; - cnDLLName = 2; - cnBuildKey = 3; - cnCompareKey = 4; - - { Cell margin constants } - cnTopMargin = 2; - cnLeftMargin = 2; - -{===TffKeyProcItemRec==================================================} -constructor TffKeyProcItemRec.Create; -begin - inherited Create(''); -end; -{====================================================================} - - -{===Helper methods===================================================} -procedure TFFIndexForm.ifSetEngine(anEngine : TffServerEngine); -begin - FEngine := anEngine; - - { Set the row count. } - grdIndexes.RowCount := FEngine.Configuration.KeyProcList.Count + 2; - grdIndexes.Row := 1; -end; -{====================================================================} - - -{===Form methods=====================================================} -procedure TFFIndexForm.FormShow(Sender: TObject); -begin - ifPopulateColHeaders; - ifPopulateGrid; - grdIndexes.SetFocus; -end; -{====================================================================} - - -{===Grid methods & event handlers====================================} -procedure TFFIndexForm.grdIndexesDrawCell(Sender: TObject; ACol, - ARow: Integer; Rect: TRect; State: TGridDrawState); -var - Grid : TffStringGrid absolute Sender; - aStr : string; -begin - - { Leave fixed portion of the grid alone} - if gdFixed in State then - Exit; - - aStr := Grid.Cells[aCol, aRow]; - - with Grid do begin - if (aCol = cnTableName) or (aCol = cnDLLName) then begin - if (aStr <> '') and (not FFFileExists(aStr)) then begin - Canvas.Brush.Color := clRed; - Canvas.Font.Color := clWhite; - end; - end; - Canvas.FillRect(Rect); - Canvas.TextRect(Rect, Rect.Left + cnLeftMargin, Rect.Top + cnTopMargin, aStr); - end; - -end; -{--------} -procedure TFFIndexForm.grdIndexesExitCell(Sender: TffStringGrid; aCol, - aRow: Integer; const text: String); -begin - if ((aCol = cnTableName) or (aCol = cnDLLName)) and - (Text <> '') and FFFileExists(Text) then - Sender.Cells[aCol, aRow] := FFExpandUNCFileName(text); -end; -{--------} -procedure TFFIndexForm.grdIndexesKeyDown(Sender: TObject; var Key: Word; - Shift: TShiftState); -var - Grid : TffStringGrid absolute Sender; -begin - { Change the selected cell (Enter as tab)} - case Key of - VK_RETURN : - with Grid do begin - if Col < Pred(ColCount) then - Col := Col + 1 - else if Row < Pred(RowCount) then begin - Row := Row + 1; - Col := cnTableName; - end else begin - { Is this cell blank? } - if Cells[Col, Row] = '' then begin - { Yes. Wrap to first row of grid. } - Row := 1; - Col := cnTableName; - end else begin - { No. Add a new blank row. } - RowCount := RowCount + 1; - Row := Pred(RowCount); - Col := cnTableName; - end; - end; - end; - VK_DOWN : - with Grid do begin - { Are we trying to arrow down from an incomplete row? } - if (Row = pred(RowCount)) then - if AnyCellIsEmpty(Row) then begin - { Yes. Do not allow this to occur. } - Key := 0; - MessageBeep(0); - end else - { No. Make sure we have a new blank row. } - RowCount := RowCount + 1; - end; - VK_UP, VK_TAB : - with Grid do begin - { Are we trying to arrow up from or Tab forward out of a new, - completed row? } - if (Row = pred(RowCount)) and RowIsFilled(Row) then - { Yes. Add a new blank row. } - RowCount := RowCount + 1; - end; - end; { case } -end; -{--------} -procedure TFFIndexForm.grdIndexesKeyPress(Sender: TObject; var Key: Char); -const - validDigits = ['0'..'9']; - validEditKeys = [#8, #13]; -var - Grid : TffStringGrid absolute Sender; - Ignore: Boolean; - Value: string; -begin - if not (Key in validEditKeys) then begin - { Validate data entry as key's are pressed} - case Grid.Col of - cnTableName, cnDLLName : - begin - Value := Grid.Cells[Grid.Col, Grid.Row]; - Ignore := (Length(Value) >= ffcl_Path); - end; - cnIndex : - Ignore := not (Key in validDigits); - else - Ignore := False; - end; { case } - if Ignore then begin - Key := #0; - MessageBeep(0); - end; - end; -end; -{--------} -procedure TFFIndexForm.grdIndexesSelectCell(Sender: TObject; ACol, - ARow: Integer; var CanSelect: Boolean); -begin - pbBrowse.Enabled := (ACol = cnTableName) or (ACol = cnDLLName); - mnuIndexBrowse.Enabled := pbBrowse.Enabled; -end; -{--------} -procedure TFFIndexForm.grdIndexesSortColumn(Sender: TffStringGrid; - aCol: Integer); -var - aStr : string; - i, j : integer; - LastRow : integer; -begin - if (Sender.RowCount > 1) and (aCol <> cnIndex) then - with Sender do begin - - if LastRowIsEmpty then - LastRow := (RowCount - 2) - else - LastRow := pred(RowCount); - - BeginUpdate; - try - for i := 1 to LastRow do begin - SaveRow(i); - aStr := Cells[aCol, i]; - j := i; - while (j > 1) and - (ansiCompareStr(Cells[aCol, j-1], aStr) > 0) do begin - CopyRow(j-1, j); - dec(j); - end; { while } - RestoreToRow(j); - end; { for } - finally - EndUpdate; - end; - end; { with } -end; -{--------} -procedure TFFIndexForm.ifPopulateColHeaders; -begin - with grdIndexes do begin - BeginUpdate; - try - Cells[cnTableName, 0] := 'Table Name & Path'; - Cells[cnIndex, 0] := 'Index'; - Cells[cnDLLName, 0] := 'DLL Name & Path'; - Cells[cnBuildKey, 0] := 'Build Key'; - Cells[cnCompareKey, 0] := 'Compare Key'; - finally - EndUpdate; - end; - end; -end; -{--------} -procedure TFFIndexForm.ifPopulateGrid; -var - Item : TffKeyProcItem; - Inx : integer; -begin - with grdIndexes do begin - BeginUpdate; - try - for Inx := 1 to FEngine.Configuration.KeyProcList.Count do begin - Item := FEngine.Configuration.KeyProcList[pred(Inx)]; - Cells[cnTableName, Inx] := Item.Path + '\' + Item.Table + '.' + {!!.03} - ffc_ExtForData; {!!.03} - Cells[cnIndex, Inx] := IntToStr(Item.IndexID); - Cells[cnDLLName, Inx] := Item.DLLName; - Cells[cnBuildKey, Inx] := Item.BuildKeyName; - Cells[cnCompareKey, Inx] := Item.CompareKeyName; - end; - finally - EndUpdate; - end; - end; -end; -{====================================================================} - - -{===Button event handlers============================================} -procedure TFFIndexForm.btnBrowseClick(Sender: TObject); -var - aDlg : TOpenDialog; -begin - with grdIndexes do begin - if (Col <> cnTableName) and (Col <> cnDLLName) then - exit; - - if Col = cnTableName then - aDlg := dlgOpenTable - else - aDlg := dlgOpenDLL; - - if aDlg.Execute then begin - BeginUpdate; - try - Cells[Col, Row] := FFExpandUNCFileName(aDlg.FileName); - finally - EndUpdate; - end; - end; - end; -end; -{--------} -procedure TFFIndexForm.btnDeleteClick(Sender: TObject); -var - DeletedRow : integer; - Inx : integer; - LastEmpty : boolean; - LastRow : integer; -begin - - if (grdIndexes.RowCount < 2) then - Exit; - - with grdIndexes do begin - BeginUpdate; - try - DeletedRow := Row; - LastRow := pred(RowCount); - LastEmpty := LastRowIsEmpty; - - { Situations where delete is okay: - 1. Non-last row - 2. Last row and it is not empty } - - { Does user want to delete the last row? } - if (DeletedRow < LastRow) then begin - - { No. Move the rows up by one. } - - for Inx := succ(DeletedRow) to lastRow do - CopyRow(Inx, pred(Inx)); - - { Get rid of the last row. } - RowCount := RowCount - 1; - - end else if (not LastEmpty) then - { Yes, user wants to delete last row and it is not empty. } - BlankRow(Row); - - finally - EndUpdate; - end; - end; -end; -{--------} -procedure TFFIndexForm.btnSaveClick(Sender: TObject); -var - Inx : integer; - Path : TffPath; - Table : TffTableName; - errStr : array [0..127] of char; - aResult : TffResult; -begin - - FEngine.Configuration.KeyProcList.Empty; - - { Xfer the info from the grid to the engine's index list. } - with grdIndexes do - for Inx := 1 to pred(RowCount) do - if RowIsFilled(Inx) then begin - Path := FFExtractPath(Cells[cnTableName, Inx]); - Table := FFExtractFileName(Cells[cnTableName, Inx]); - FEngine.Configuration.AddKeyProc(Path, - Table, - StrToInt(Cells[cnIndex, Inx]), - Cells[cnDLLName, Inx], - Cells[cnBuildKey, Inx], - Cells[cnCompareKey, Inx]); - end; - - aResult := FEngine.WriteKeyProcData; - if aResult <> DBIERR_NONE then begin - ffStrResBDE.GetASCIIZ(aResult, errStr, sizeof(DBIMSG)); - showMessage(format('Could not save user-defined indexes: %s [$%x/%d])', - [strPas(errStr), aResult, aResult])); - self.modalResult := mrNone; - end; - -end; -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/server/uffsmain.dfm b/components/flashfiler/sourcelaz/server/uffsmain.dfm deleted file mode 100644 index 1da8d51ae..000000000 Binary files a/components/flashfiler/sourcelaz/server/uffsmain.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/server/uffsmain.pas b/components/flashfiler/sourcelaz/server/uffsmain.pas deleted file mode 100644 index 37c1c492d..000000000 --- a/components/flashfiler/sourcelaz/server/uffsmain.pas +++ /dev/null @@ -1,1432 +0,0 @@ -{*********************************************************} -{* Main window 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 ***** *) - -unit uFFSMain; - -{$I FFDEFINE.INC} - -{$IFDEF SingleEXE} -!! Error: This application should not be compiled with SingleEXE mode enabled -{$ENDIF} - -{$DEFINE UseTrayIcon} - -interface - -uses - Messages, SysUtils, Classes, Graphics, Controls, - Forms, Dialogs, ExtCtrls, StdCtrls, Menus, Buttons, - Windows, - {$IFDEF UseTrayIcon} - ShellAPI, - {$ENDIF} - ffconst, - ffnetmsg, - ffdtmsgq, - ffllbase, - fflllgcy, - fflleng, - ffhash, - ffllprot, - ffsrbase, - ffsrcfg, - ffsreng, - ffsrcmd, - ffllthrd, - uffegmgr, - ffsrintm, - ComCtrls, - {$IFDEF DCC4ORLATER} - ImgList, - {$ENDIF} - ToolWin; - -type - TffServerState = ( - ssInitializing, - ssDown, - ssComingUp, - ssUp, - ssUpMinimized); - -const - {$IFDEF UseTrayIcon} - ffc_tiCallBack = WM_USER + $300; - {$ENDIF} - ffc_Activate = WM_USER + $301; - ffc_Minimize = WM_USER + $302; - -type - TfrmFFServer = class(TForm) - pnlBottom: TPanel; - Timer1: TTimer; - PopupMenu: TPopupMenu; - pumDownServer: TMenuItem; - N3: TMenuItem; - pumExit: TMenuItem; - MainMenu: TMainMenu; - mnuServer: TMenuItem; - mnuServerUp: TMenuItem; - mnuServerDown: TMenuItem; - N1: TMenuItem; - mnuServerExit: TMenuItem; - mnuConfig: TMenuItem; - mnuConfigGeneral: TMenuItem; - mnuConfigNetwork: TMenuItem; - mnuConfigUsers: TMenuItem; - mnuConfigAliases: TMenuItem; - mnuConfigIndexes: TMenuItem; - mnuDebug: TMenuItem; - mnuDebugLog: TMenuItem; - mnuResetCounters: TMenuItem; - mnuHelp: TMenuItem; - mnuHelpAbout: TMenuItem; - mnuHelpWWW: TMenuItem; - mnuHelpEmail: TMenuItem; - pnlBig: TPanel; - pnlServers: TPanel; - gbServers: TGroupBox; - lvServers: TListView; - Splitter1: TSplitter; - pnlTransports: TPanel; - gbTransports: TGroupBox; - lvTransports: TListView; - pmuTrans: TPopupMenu; - pmuTransLog: TMenuItem; - pmuTransLogAll: TMenuItem; - pmuTransLogSep: TMenuItem; - pmuTransLogErr: TMenuItem; - pmuTransLogReq: TMenuItem; - pmuTransLogRep: TMenuItem; - ToolBar: TToolBar; - btnProps: TToolButton; - ToolButton2: TToolButton; - btnStart: TToolButton; - btnStop: TToolButton; - ImageList: TImageList; - pnlTray: TPanel; - imgUnlocked: TImage; - imgStarted: TImage; - lblTime: TLabel; - imgStopped: TImage; - imgLocked: TImage; - imgLogging: TImage; - HelpTopics1: TMenuItem; - N2: TMenuItem; - procedure mnuConfigAliasesClick(Sender: TObject); - procedure mnuDebugLogClick(Sender: TObject); - procedure mnuServerExitClick(Sender: TObject); - procedure pumDownServerClick(Sender: TObject); - procedure pumExitClick(Sender: TObject); - procedure FormActivate(Sender: TObject); - procedure FormClose(Sender: TObject; var Action: TCloseAction); - procedure FormCreate(Sender: TObject); - procedure FormHide(Sender: TObject); - procedure Timer1Timer(Sender: TObject); - procedure mnuResetCountersClick(Sender: TObject); - procedure mnuHelpAboutClick(Sender: TObject); - procedure mnuConfigUsersClick(Sender: TObject); - procedure mnuHelpWWWClick(Sender: TObject); - procedure mnuHelpEmailClick(Sender: TObject); - procedure mnuConfigGeneralClick(Sender: TObject); - procedure FormDestroy(Sender: TObject); - procedure FormPaint(Sender: TObject); - procedure mnuConfigIndexesClick(Sender: TObject); - procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); - procedure FormShow(Sender: TObject); - procedure mnuConfigNetworkClick(Sender: TObject); - procedure lvServersClick(Sender: TObject); - procedure pmuTransLogAllClick(Sender: TObject); - procedure pmuTransLogErrClick(Sender: TObject); - procedure pmuTransLogReqClick(Sender: TObject); - procedure pmuTransLogRepClick(Sender: TObject); - procedure lvTransportsMouseDown(Sender: TObject; Button: TMouseButton; - Shift: TShiftState; X, Y: Integer); - procedure btnStartClick(Sender: TObject); - procedure btnStopClick(Sender: TObject); - procedure btnPropsClick(Sender: TObject); - procedure FormResize(Sender: TObject); - procedure HelpTopics1Click(Sender: TObject); - private - { Private d - procedure FormResize(Sender: TObject);eclarations } - FIgnoreNextLogin : Boolean; - FState : TffServerState; - FStartTime : TDateTime; - FMsgStartTime : TDateTime; - cuIsGreen : Boolean; - FCloseClick : Boolean; - FElapsedTime : TDateTime; - FMustClose : Boolean; - FClosingFromTray : Boolean; - {$IFDEF UseTrayIcon} - tiActive : Boolean; - tiNotifyData : TNotifyIconData; - tiPresent : Boolean; - {$ENDIF} - - - procedure AppException(Sender : TObject; E : Exception); - procedure DisplayHint(Sender : TObject); - function Login : Boolean; - procedure MainFormMinimize(Sender : TObject); - procedure MainFormRestore(Sender : TObject); - procedure PaintPadlockBitmap; - - {$IFDEF UseTrayIcon} - procedure tiAdd; - procedure tiCallBack(var Msg : TMessage); message ffc_tiCallBack; - procedure tiDelete; - function tiGetIconHandle : hIcon; - procedure tiInitNotifyData; - {$ENDIF} - public - { Public declarations } - ServerName : TffNetAddress; - - procedure BringServerUp; - procedure BringServerDown; - procedure CreateEngineMgr; - procedure FreeEngineMgr; {!!.06} - procedure DownServer; - function ElapsedTimeToStr(T : TDateTime) : string; - procedure FFCActivate(var Msg : TMessage); message ffc_Activate; - procedure FFCMinimize(var Msg : TMessage); message ffc_Minimize; - function GetMsgsPerSecAsString(aMsgCount : Longint) : string; - procedure LoadServers; - procedure LoadTransports; - procedure ResetStatistics; - procedure SetControls; - procedure SetServerName; - procedure SetServerPriority(aPriority : longint); - procedure SetState(S : TffServerState); - procedure UpdateServers; - procedure UpdateTransports; - procedure UpServer; - procedure WMSysCommand(var Msg : TMessage); message WM_SYSCOMMAND; - procedure WMQueryEndSession(var msg : TMessage); message WM_QUERYENDSESSION; - - property State : TffServerState read FState write SetState; - end; - -var - frmFFServer: TfrmFFServer; - -implementation - -uses - FFAbout, - FFLLComm, - FFLLComp, - uFFSAlas, - uFFSUser, - uFFSGenl, - uFFSIndx, - uFFSNet, - FFSrJour, - FFLogDlg, uFFsCfg; - -{$R *.DFM} - -{===Main Menu options================================================} -procedure TfrmFFServer.mnuConfigAliasesClick(Sender: TObject); -begin - CreateEngineMgr; - with TFFAliasForm.Create(Application) do - try - ServerEngine := TffServerEngine(lvServers.Selected.Data); - ShowModal; - finally - Free; - end; -end; -{--------} -procedure TfrmFFServer.mnuConfigGeneralClick(Sender: TObject); -begin - CreateEngineMgr; - with TFFGenConfigForm.Create(Application) do - try - ServerEngine := TffServerEngine(lvServers.Selected.Data); - ShowModal; - { Get the bits in which we're interested. } - with ServerEngine.Configuration.GeneralInfo^ do begin - ServerName := giServerName; - ServerEngine.MaxRAM := giMaxRAM; {!!.01} -// ServerEngine.CollectGarbage := giCollectEnabled; {Deleted !!.01} -// ServerEngine.CollectFrequency := giCollectFreq; {Deleted !!.01} - SetServerName; - mnuDebugLog.Checked := giDebugLog; - FFEngineManager.EventLogEnabled := giDebugLog; - imgLogging.Visible := (giDebugLog and (not giReadOnly)); - - SetServerPriority(giPriority); - PaintPadlockBitmap; - end; - SetControls; - finally - Free; - end; - lvServers.Selected.Caption := ServerName; -end; -{--------} -procedure TfrmFFServer.mnuConfigNetworkClick(Sender: TObject); -begin - CreateEngineMgr; - with TffNetConfigForm.Create(Application) do - try - ServerEngine := TffServerEngine(lvServers.Selected.Data); - ShowModal; - if (State = ssUp) then - with ServerEngine.Configuration.GeneralInfo^ do begin - if Assigned(FFEngineManager.IPXSPXTransport) then - FFEngineManager.IPXSPXTransport.RespondToBroadcasts := giIPXSPXLFB; - if Assigned(FFEngineManager.TCPIPTransport) then - FFEngineManager.TCPIPTransport.RespondToBroadcasts := giTCPIPLFB; - end; - finally - Free; - end; -end; -{--------} -procedure TfrmFFServer.mnuConfigIndexesClick(Sender: TObject); -begin - CreateEngineMgr; - with TffIndexForm.Create(Application) do - try - ServerEngine := TffServerEngine(lvServers.Selected.Data); - ShowModal; - finally - Free; - end; -end; -{--------} -procedure TfrmFFServer.mnuConfigUsersClick(Sender: TObject); -begin - CreateEngineMgr; - with TFFUserForm.Create(Application) do - try - ServerEngine := TffServerEngine(lvServers.Selected.Data); - ShowModal; - finally - Free; - end; -end; -{--------} -procedure TfrmFFServer.mnuDebugLogClick(Sender: TObject); -begin - CreateEngineMgr; - mnuDebugLog.Checked := not mnuDebugLog.Checked; - with TffServerEngine(lvServers.Selected.Data) do begin - Configuration.GeneralInfo^.giDebugLog := mnuDebugLog.Checked; - WriteGeneralInfo(False); - FFEngineManager.EventLogEnabled := mnuDebugLog.Checked; - imgLogging.Visible := (mnuDebugLog.Checked and (not Configuration.GeneralInfo^.giReadOnly)); - end; -end; -{--------} -procedure TfrmFFServer.mnuHelpAboutClick(Sender: TObject); -var - AboutBox : TFFAboutBox; -begin - AboutBox := TFFAboutBox.Create(Application); - try - AboutBox.IsServer := true; - AboutBox.Caption := 'About FlashFiler Server'; - AboutBox.ProgramName.Caption := 'FlashFiler Server'; - AboutBox.ShowModal; - finally - AboutBox.Free; - end; -end; -{--------} -procedure TfrmFFServer.mnuHelpWWWClick(Sender: TObject); -begin - ShellToWWW; -end; -{--------} -procedure TfrmFFServer.mnuHelpEmailClick(Sender: TObject); -begin - ShellToEmail; -end; -{--------} -procedure TfrmFFServer.mnuResetCountersClick(Sender : TObject); -begin - FMsgStartTime := Now; - ResetStatistics; -end; -{--------} -procedure TfrmFFServer.mnuServerExitClick(Sender : TObject); -begin - Close; -end; -{====================================================================} - - -{===Popup menu options===============================================} -procedure TfrmFFServer.pumDownServerClick(Sender : TObject); -begin - if not Login then - Exit; - FIgnoreNextLogin := True; - Application.Restore; - Application.ProcessMessages; - BringServerDown; -// FreeEngineMgr; {!!.06}{Deleted !!.13} -end; -{--------} -procedure TfrmFFServer.pumExitClick(Sender : TObject); -begin - FClosingFromTray := True; - Application.Restore; - Close; -end; -{====================================================================} - - -{===Message handlers=================================================} -procedure TfrmFFServer.FFCActivate(var Msg : TMessage); -begin - Update; - BringServerUp; -end; -{--------} -procedure TfrmFFServer.FFCMinimize(var Msg : TMessage); -begin - Application.Minimize; -end; -{--------} -procedure TfrmFFServer.WMQueryEndSession(var msg : TMessage); -begin - FMustClose := true; - inherited; -end; -{--------} -procedure TfrmFFServer.WMSysCommand(var Msg : TMessage); -begin - if (((Msg.wParam) and $FFF0) = SC_CLOSE) then - FCloseClick := true; - inherited; -end; -{====================================================================} - - -{===Timer handler====================================================} -procedure TfrmFFServer.Timer1Timer(Sender: TObject); -begin - if State = ssUpMinimized then {!!.11} - Exit; {!!.11} - UpdateServers; - UpdateTransports; - case State of - ssComingUp : - begin - cuIsGreen := not cuIsGreen; - if cuIsGreen then begin - imgStarted.Visible := True; - imgStopped.Visible := False; - end else begin - imgStarted.Visible := False; - imgStopped.Visible := True; - end; - end; - ssUp : - begin - FElapsedTime := Now - FStartTime; - lblTime.Caption := ElapsedTimeToStr(FElapsedTime); - end; - end;{case} -end; -{====================================================================} - - -{===Form events======================================================} -procedure TfrmFFServer.FormActivate(Sender: TObject); -{$IFDEF UseTrayIcon} -var - OSVerInfo : TOSVersionInfo; -{$ENDIF} -begin - {$IFDEF UseTrayIcon} - tiPresent := false; - OSVerInfo.dwOSVersionInfoSize := sizeof(OSVerInfo); - if GetVersionEx(OSVerInfo) then begin - {Note: Windows95 returns version major:minor = 4:0} - if (OSVerInfo.dwPlatformID = VER_PLATFORM_WIN32_WINDOWS) or {Windows95} - (OSVerInfo.dwPlatformID = VER_PLATFORM_WIN32_NT) then {WindowsNT} - tiPresent := OSVerInfo.dwMajorVersion > 3 - end; - {$ENDIF} - - if Assigned(FFEngineManager) and Assigned(lvServers.Selected) then {!!.13} - if TffServerEngine(lvServers.Selected.Data).Configuration.GeneralInfo^.giAutoMini {!!.13} - and (State = ssInitializing) then FIgnoreNextLogin := true; {!!.13} - - if not Login then begin - PostMessage(Handle, WM_QUIT, 0, 0); - Exit; - end; - try - if assigned(FFEngineManager) and assigned(lvServers.Selected) then {!!.02} - with TffServerEngine(lvServers.Selected.Data).Configuration.GeneralInfo^ do begin - {..server name, etc} - ServerName := giServerName; - TffServerEngine(lvServers.Selected.Data).BufferManager.MaxRAM := giMaxRAM; - {..ports} - FFSetTCPPort(giTCPPort); - FFSetUDPPortServer(giUDPPortSr); - FFSetUDPPortClient(giUDPPortCl); - FFSetIPXSocketServer(giIPXSocketSr); - FFSetIPXSocketClient(giIPXSocketCl); - FFSetSPXSocket(giSPXSocket); - {..keepalive stuff} - ffc_LastMsgInterval := giLastMsgInterval; - ffc_KeepAliveInterval := giKAInterval; - ffc_KeepAliveRetries := giKARetries; - {..priority} - SetServerPriority(giPriority); - {..auto up} - if giAutoUp and (ServerName <> '') then - PostMessage(Handle, ffc_Activate, 0, 0); - {..auto minimize} - if giAutoMini then - PostMessage(Handle, ffc_Minimize, 0, 0); - end; - Application.ShowHint := true; - State := ssDown; - SetServerName; - {$IFDEF UseTrayIcon} - if tiPresent then - tiAdd; - {$ENDIF} - except - {????} - raise; - end; - (****** - {parse out the command line} - ActivateIt := false; - MinimizeIt := false; - ParmCount := ParamCount; - if (ParmCount > 0) then begin - {the server name is parameter 1} - ServerName := ParamStr(1); - {whether to make the server active is parameter 2: the value - should be either 'Up' or 'Down', but actually all other values are ignored - and assumed to be 'Down'} - if (ParmCount > 1) then begin - ParmValue := ParamStr(2); - if (FFCmpShStrUC(ParmValue, 'UP', length(ParmValue)) = 0) then - ActivateIt := true; - end; - if (ParmCount > 2 ) then begin - ParmValue := ParamStr(3); - if ( FFCmpShStrUC( ParmValue, 'WINSOCK', length( ParmValue) ) = 0 ) then - mnuConfigWinsockClick( Self ) - else - if ( FFCmpShStrUC( ParmValue, 'NETBIOS', - length( ParmValue) ) = 0 ) then - mnuConfigNetBIOSClick( Self ); - Application.ProcessMessages; - end; - if ( ParmCount > 3 ) then begin - ParmValue := ParamStr(4); - if (FFCmpShStrUC(ParmValue, 'MINIMIZE', length(ParmValue)) = 0) then - MinimizeIt := true; - end; - end; - *****) -end; -{--------} -procedure TfrmFFServer.FormCloseQuery(Sender: TObject; var CanClose: Boolean); -begin - if FMustClose then begin - if (State <> ssDown) then begin - if (State = ssUpMinimized) then - Application.Restore; - BringServerDown; - end; - CanClose := true; - end else begin - if (State = ssUp) and FCloseClick then begin - FCloseClick := false; - Application.Minimize; - end - else if (State <> ssDown) then begin - if Login then begin - if (State = ssUpMinimized) then - Application.Restore; - BringServerDown; - end; - end; - CanClose := (State = ssDown); - end; -end; -{--------} -procedure TfrmFFServer.FormClose(Sender: TObject; var Action: TCloseAction); -begin - {$IFDEF UseTrayIcon} - tiDelete; - {$ENDIF} -end; -{--------} -procedure TfrmFFServer.FormCreate(Sender : TObject); -begin - FClosingFromTray := False; - FIgnoreNextLogin := False; - State := ssInitializing; - Application.OnMinimize := MainFormMinimize; - Application.OnRestore := MainFormRestore; - Application.OnException := AppException; - Application.OnHint := DisplayHint; - FFEngineManager := nil; - IsMultiThread := True; - pumDownServer.Enabled := False; {!!.01 Added} - FFSConfigGetFormPos('Main', Self); {!!.06} -end; -{--------} -procedure TfrmFFServer.AppException(Sender : TObject; E : Exception); -begin - Application.ShowException(E) -end; -{--------} -procedure TfrmFFServer.DisplayHint(Sender : TObject); -begin - if Application.MainForm.Active then - pnlBottom.Caption := ' ' + Application.Hint; {!!.06} -end; -{--------} -procedure TfrmFFServer.FormDestroy(Sender: TObject); -begin - FFSConfigSaveFormPrefs('Main', Self); - FreeEngineMgr; {!!.06} -end; -{--------} -procedure TfrmFFServer.FormHide(Sender : TObject); -begin - ShowWindow(Application.Handle, SW_HIDE); -end; -{--------} -procedure TfrmFFServer.FormPaint(Sender : TObject); -begin - PaintPadlockBitmap; -end; -{--------} -procedure TfrmFFServer.FormShow(Sender : TObject); -begin - FFSConfigGetFormPrefs('Main', Self); - { Create the engine manager. } - CreateEngineMgr; -{Begin !!.02} - try - LoadServers; - LoadTransports; - finally - SetControls; - end; -{End !!.02} -end; -{--------} -function TfrmFFServer.Login : Boolean; -var - LoginDlg : TFFLoginDialog; - Hash : TffWord32; - Pwd : TffName; - Server : TffServerEngine; - User : TffUserItem; - UserInx : integer; - UserID : TffName; -begin - if FMustClose then begin {!!.11} - Result := True; {!!.11} - Exit; {!!.11} - end; {!!.11} - if FIgnoreNextLogin then begin - FIgnoreNextLogin := False; - Result := True; - Exit; - end; - Server := nil; - if lvServers.SelCount > 0 then - Server := TffServerEngine(lvServers.Selected.Data); - if (not assigned(Server)) or - (not Server.Configuration.GeneralInfo^.giIsSecure) then begin - Result := true; - Exit; - end; - Result := false; - LoginDlg := TFFLoginDialog.Create(Application); - try - if (LoginDlg.ShowModal = mrOK) then begin - UserID := LoginDlg.edtUserName.Text; - Pwd := LoginDlg.edtPassword.Text; - UserInx := Server.Configuration.UserList.UserIndex(UserID); - if (UserInx <> -1) then begin - User := Server.Configuration.UserList[UserInx]; - Hash := FFCalcShStrElfHash(Pwd); - if (Hash = User.PasswordHash) and - (arAdmin in User.Rights) then - Result := true; - end - end; - finally - LoginDlg.Free; - end;{try..finally} -end; -{--------} -procedure TfrmFFServer.MainFormMinimize(Sender : TObject); -begin - if (State = ssUp) then - State := ssUpMinimized; - {$IFDEF UseTrayIcon} - if tiPresent and (State = ssUpMinimized) then begin - Hide; - end; - {$ENDIF} -end; -{--------} -procedure TfrmFFServer.MainFormRestore(Sender : TObject); -begin - {$IFDEF UseTrayIcon} - if tiPresent and (State = ssUpMinimized) then begin - Show; - SetForegroundWindow(Handle); - end; - {$ENDIF} - if (State = ssUpMinimized) then - State := ssUp; - if (not FClosingFromTray) and (not Login) then - Application.Minimize; -end; -{--------} -procedure TfrmFFServer.PaintPadlockBitmap; -begin - if lvServers.SelCount > 0 then begin - imgLocked.Visible := TffServerEngine(lvServers.Selected.Data).Configuration.GeneralInfo^.giIsSecure; - imgUnlocked.Visible := not imgLocked.Visible; - end else begin - imgLocked.Visible := False; - imgUnlocked.Visible := False; - end; -end; -{====================================================================} - - -{===property handlers================================================} -procedure TfrmFFServer.SetState(S : TffServerState); -begin - if (S = FState) and (S <> ssInitializing) then - Exit; - FState := S; - case S of - ssInitializing : - begin - {..edit controls} - lblTime.Caption := ElapsedTimeToStr(0.0); - end; - ssDown : - begin - {..menu items} - if (ServerName = '') then - mnuServerUp.Enabled := false - else - mnuServerUp.Enabled := true; - mnuServerDown.Enabled := false; - if ((assigned(FFEngineManager)) and (lvServers.SelCount > 0)) then - with TffServerEngine(lvServers.Selected.Data).Configuration do begin - FFEngineManager.EventLogEnabled := mnuDebugLog.Checked; - end; - - {..speedbutton actions} - if (ServerName = '') then - btnStart.Enabled := false - else - btnStart.Enabled := true; - btnStop.Enabled := false; - - {..online indicator} - imgStarted.Visible := False; - imgStopped.Visible := True; - - {..timer} - Timer1.Enabled := false; - end; - ssComingUp : - begin - {..menu items} - mnuServerUp.Enabled := false; - {..speedbutton actions} - btnStart.Enabled := false; - {..edit controls} - lblTime.Caption := ElapsedTimeToStr(0.0); - {..form fields} - FStartTime := Now; - FMsgStartTime := Now; - {..timer} - Timer1.Enabled := true; - end; - ssUp : - begin - {..menu items} - mnuServerUp.Enabled := false; - mnuServerDown.Enabled := true; - {..speedbutton actions} - btnStart.Enabled := false; - btnStop.Enabled := true; - {..online indicator} - imgStarted.Visible := True; - imgStopped.Visible := False; - {..timer} - Timer1.Enabled := true; - end; - ssUpMinimized : - begin - {..timer} - Timer1.Enabled := false; - end; - end;{case} -end; -{====================================================================} - - -{===Utility methods==================================================} -procedure TfrmFFServer.BringServerDown; -begin - if (State = ssUp) then begin - DownServer; - State := ssDown; - end; -end; -{--------} -procedure TfrmFFServer.BringServerUp; -begin - if (State = ssDown) then begin - Timer1.Interval := 250; - cuIsGreen := false; - State := ssComingUp; - try - UpServer; - Timer1.Interval := 1000; - State := ssUp; - except - State := ssDown; - raise; - end;{try..except} - end; - LoadServers; - LoadTransports; -end; -{--------} -procedure TfrmFFServer.CreateEngineMgr; -begin - if not assigned(FFEngineManager) then begin - FFEngineManager := TffEngineManager.Create(nil); - if ParamCount > 0 then - FFEngineManager.ScriptFile := ParamStr(1); - end; -end; -{--------} -procedure TfrmFFServer.FreeEngineMgr; {!!.06} -begin - if assigned(FFEngineManager) then - try - FFEngineManager.ShutDown; - finally - FFEngineManager.Free; - FFEngineManager := nil; - end; -end; -{--------} -procedure TfrmFFServer.DownServer; -{Deleted !!.01} -{var - Idx : Integer;} -begin - Screen.Cursor := crHourGlass; - try - {free all server engines} -{Begin !!.01} - if assigned(FFEngineManager) then begin - pumDownServer.Enabled := False; - FFEngineManager.ShutDown; -{ for Idx := 0 to Pred(lvServers.Items.Count) do - with TffServerEngine(lvServers.Items[Idx].Data) do - State := ffesInactive; } - end; -{End !!.01} - finally - Screen.Cursor := crDefault; - end; - {redisplay the counters} - ResetStatistics; - Timer1Timer(Self); -end; -{--------} -function TfrmFFServer.ElapsedTimeToStr(T : TDateTime) : string; -var - Dy : integer; - Hr : integer; - Mi : integer; - Se : integer; - WorkSt : string[9]; -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); - {123456789012345678} - Result := 'Up: 0:00:00:00'; - Result[10] := TimeSeparator; - Result[12] := TimeSeparator; - Result[16] := TimeSeparator; - Str(Dy:5, WorkSt); - Move(WorkSt[1], Result[5], 5); - Str(Hr:2, WorkSt); - Result[12] := WorkSt[2]; - if (Hr > 9) then - Result[11] := WorkSt[1]; - Str(Mi:2, WorkSt); - Result[15] := WorkSt[2]; - if (Mi > 9) then - Result[14] := WorkSt[1]; - Str(Se:2, WorkSt); - Result[18] := WorkSt[2]; - if (Se > 9) then - Result[17] := WorkSt[1]; -end; -{--------} -function TfrmFFServer.GetMsgsPerSecAsString(aMsgCount: Integer): string; -var - MsgsPerSec : double; -begin - if (FElapsedTime > 0.0) then - MsgsPerSec := aMsgCount / (FElapsedTime * 86400.0) - else - MsgsPerSec := 0.0; - Str(MsgsPerSec:0:4, Result); -end; -{--------} -procedure TfrmFFServer.LoadServers; -var - ListItem : TListItem; - SelServIdx : Integer; - Servers : TffList; - i : Integer; -begin - if assigned(FFEngineManager) then begin - if lvServers.SelCount > 0 then - SelServIdx := lvServers.Selected.Index - else - SelServIdx := 0; - lvServers.Items.BeginUpdate; - Servers := TffList.Create; - try - lvServers.Items.Clear; - FFEngineManager.GetServerEngines(Servers); - for i := 0 to Pred(Servers.Count) do begin - ListItem := lvServers.Items.Add; - with TffServerEngine(TffIntListItem(Servers[i]).KeyAsInt) do begin - ListItem.Caption := Configuration.ServerName; - ListItem.Data := Pointer(TffIntListItem(Servers[i]).KeyAsInt); - ListItem.SubItems.Add(FFMapStateToString(State)); - ListItem.SubItems.Add(FFCommaizeChL(ClientList.ClientCount, ThousandSeparator)); - ListItem.SubItems.Add(FFCommaizeChL(SessionList.SessionCount, ThousandSeparator)); - ListItem.SubItems.Add(FFCommaizeChL(DatabaseList.DatabaseCount, ThousandSeparator)); - ListItem.SubItems.Add(FFCommaizeChL(TableList.TableCount, ThousandSeparator)); - ListItem.SubItems.Add(FFCommaizeChL(CursorList.CursorCount, ThousandSeparator)); - ListItem.SubItems.Add(FFCommaizeChL(BufferManager.RAMUsed, ThousandSeparator)); - end; - if i = SelServIdx then - lvServers.Selected := ListItem; - end; - finally - Servers.Free; - lvServers.Items.EndUpdate; - end; - end; -end; -{--------} -procedure TfrmFFServer.LoadTransports; -var - i : Integer; - NewTransItem : TListItem; - Transports : TffList; -begin - Transports := TffList.Create; - try - lvTransports.Items.Clear; - if lvServers.SelCount > 0 then begin - if assigned(FFEngineManager) then begin - FFEngineManager.GetTransports(TffServerEngine(lvServers.Selected.Data), - Transports); - lvTransports.Items.BeginUpdate; - try - lvTransports.Items.Clear; - for i := 0 to Pred(Transports.Count) do begin - with TffBaseTransport(TffIntListItem(Transports[i]).KeyAsInt) do begin - NewTransItem := lvTransports.Items.Add; - NewTransItem.Caption := GetName; - NewTransItem.Data := Pointer(TffIntListItem(Transports[i]).KeyAsInt); - NewTransItem.SubItems.Add(ServerName); - NewTransItem.SubItems.Add(FFMapStateToString(State)); - NewTransItem.SubItems.Add(FFCommaizeChL(ConnectionCount, ThousandSeparator)); - NewTransItem.SubItems.Add(FFCommaizeChL(MsgCount, ThousandSeparator)); - NewTransItem.SubItems.Add(GetMsgsPerSecAsString(MsgCount)); - end; - end; - finally - lvTransports.Items.EndUpdate; - end; - end; - end; - finally - Transports.Free; - end; -end; -{--------} -procedure TfrmFFServer.lvServersClick(Sender: TObject); -begin - LoadTransports; - SetControls; - PaintPadlockBitmap; -end; -{--------} -procedure TfrmFFServer.ResetStatistics; -var - i : Integer; -begin - for i := 0 to pred(lvTransports.Items.Count) do begin - with TffBaseTransport(lvTransports.Items[i].Data) do begin - ResetMsgCount; - end; - end; -end; -{--------} -procedure TfrmFFServer.SetControls; -var - SelectedServer : TffServerEngine; - IsServerSelected : Boolean; -begin - SelectedServer := nil; - IsServerSelected := lvServers.SelCount > 0; - if IsServerSelected then begin - SelectedServer := TffServerEngine(lvServers.Selected.Data); - gbTransports.Caption := format(' Transports for %s ', [lvServers.Selected.Caption]); - imgLogging.Visible := SelectedServer.Configuration.GeneralInfo^.giDebugLog; - mnuDebugLog.Checked := imgLogging.Visible; - end else begin - gbTransports.Caption := ' Transports for selected server '; - imgLogging.Visible := False; - mnuDebugLog.Checked := False; - end; - mnuConfigGeneral.Enabled := IsServerSelected; - mnuConfigNetwork.Enabled := IsServerSelected; - mnuConfigAliases.Enabled := IsServerSelected; - mnuConfigIndexes.Enabled := IsServerSelected; - mnuConfigUsers.Enabled := IsServerSelected; - btnProps.Enabled := IsServerSelected; - if IsServerSelected and Assigned(SelectedServer) then - mnuDebugLog.Enabled := not SelectedServer.Configuration.GeneralInfo^.giReadOnly - else - mnuDebugLog.Enabled := False; - mnuResetCounters.Enabled := IsServerSelected; -end; -{--------} -procedure TfrmFFServer.SetServerName; -begin - if assigned(FFEngineManager) and assigned(lvServers.Selected)then {!!.02} - with TffServerEngine(lvServers.Selected.Data) do - Configuration.GeneralInfo^.giServerName := ServerName; - if (ServerName <> '') then begin - Caption := 'TurboPower FlashFiler [' + ServerName + ']'; - Application.Title := Caption; - if (State = ssDown) then begin - mnuServerUp.Enabled := true; - btnStart.Enabled := true; - end; - {$IFDEF UseTrayIcon} - tiInitNotifyData; - {$ENDIF} - end else begin - Caption := 'FlashFiler Server'; - mnuServerUp.Enabled := false; - btnStart.Enabled := false; - end; -end; -{--------} -procedure TfrmFFServer.SetServerPriority(aPriority : longint); -const - ThreadPriority : array [0..4] of integer = - (THREAD_PRIORITY_LOWEST, - THREAD_PRIORITY_BELOW_NORMAL, - THREAD_PRIORITY_NORMAL, - THREAD_PRIORITY_ABOVE_NORMAL, - THREAD_PRIORITY_HIGHEST); -begin - if (aPriority < -2) or (aPriority > 2) then - aPriority := 2 - else - inc(aPriority, 2); - SetThreadPriority(GetCurrentThread, ThreadPriority[aPriority]); -end; -{--------} -procedure TfrmFFServer.UpdateServers; -var - i : Integer; -begin - for i := 0 to Pred(lvServers.Items.Count) do begin - with lvServers.Items[i], TffServerEngine(lvServers.Items[i].Data) do begin - SubItems[0] := FFMapStateToString(State); - SubItems[1] := FFCommaizeChL(ClientList.ClientCount, ThousandSeparator); - SubItems[2] := FFCommaizeChL(SessionList.SessionCount, ThousandSeparator); - SubItems[3] := FFCommaizeChL(DatabaseList.DatabaseCount, ThousandSeparator); - SubItems[4] := FFCommaizeChL(TableList.TableCount, ThousandSeparator); - SubItems[5] := FFCommaizeChL(CursorList.CursorCount, ThousandSeparator); - SubItems[6] := FFCommaizeChL(BufferManager.RAMUsed, ThousandSeparator); - end; - end; -end; -{--------} -procedure TfrmFFServer.UpdateTransports; -var - i : Integer; -begin - for i := 0 to pred(lvTransports.Items.Count) do begin - with lvTransports.Items[i], - TffBaseTransport(lvTransports.Items[i].Data) do begin - SubItems[0] := ServerName; - SubItems[1] := FFMapStateToString(State); - SubItems[2] := FFCommaizeChL(ConnectionCount, ThousandSeparator); - SubItems[3] := FFCommaizeChL(MsgCount, ThousandSeparator); - SubItems[4] := GetMsgsPerSecAsString(MsgCount); - end; - end; -end; -{--------} -procedure TfrmFFServer.UpServer; -var - SaveCursor : TCursor; -begin - SaveCursor := Cursor; - Cursor := crHourglass; - try - { Create & set up the transports. } - with FFEngineManager.ServerEngine.Configuration.GeneralInfo^ do begin - - FFEngineManager.SUPTransport.Enabled := giSingleUser; - if giSingleUser then begin - FFEngineManager.SUPTransport.BeginUpdate; - try - FFEngineManager.SUPTransport.ServerName := giServerName; - FFEngineManager.SUPTransport.Mode := fftmListen; - FFEngineManager.SUPTransport.EndUpdate; - except - FFEngineManager.SUPTransport.CancelUpdate; - end; - end; - - FFEngineManager.IPXSPXTransport.Enabled := giIPXSPX; - if giIPXSPX then begin - FFEngineManager.IPXSPXTransport.BeginUpdate; - try - FFEngineManager.IPXSPXTransport.ServerName := giServerName; - FFEngineManager.IPXSPXTransport.RespondToBroadcasts := giIPXSPXLFB; - FFEngineManager.IPXSPXTransport.Mode := fftmListen; - FFEngineManager.IPXSPXTransport.EndUpdate; - except - FFEngineManager.IPXSPXTransport.CancelUpdate; - end; - end; - - FFEngineManager.TCPIPTransport.Enabled := giTCPIP; - if giTCPIP then begin - FFEngineManager.TCPIPTransport.BeginUpdate; - try - FFEngineManager.TCPIPTransport.ServerName := giServerName; - FFEngineManager.TCPIPTransport.RespondToBroadcasts := giTCPIPLFB; - FFEngineManager.TCPIPTransport.Mode := fftmListen; - FFEngineManager.TCPIPTransport.EndUpdate; - ffc_TCPInterface := giTCPInterface; {!!.01 Added} - except - FFEngineManager.TCPIPTransport.CancelUpdate; - end; - end; - pumDownServer.Enabled := True; {!!.01 Added} - end; - { Start the engine manager. } - FFEngineManager.StartUp; - finally - Cursor := SaveCursor; - end; -end; -{====================================================================} - -{===Transport logging================================================} -procedure TfrmFFServer.lvTransportsMouseDown(Sender: TObject; - Button: TMouseButton; Shift: TShiftState; X, Y: Integer); -var - anItem : TListItem; - aTransport : TffBaseTransport; - MousePos : TPoint; -begin - if Button <> mbRight then exit; - - { Find the transport under the mouse. } - anItem := lvTransports.GetItemAt(X, Y); - if assigned(anItem) then begin - aTransport := TffBaseTransport(anItem.Data); - - { Attach the transport to the popup menu so that the popup menu handlers - may quickly access the transport. } - lvTransports.Selected := anItem; - pmuTrans.Tag := longInt(aTransport); - - { Update the menu options to reflect the transport. } - pmuTransLogErr.Checked := fftpLogErrors in aTransport.EventLogOptions; - pmuTransLogReq.Checked := fftpLogRequests in aTransport.EventLogOptions; - pmuTransLogRep.Checked := fftpLogReplies in aTransport.EventLogOptions; - pmuTransLogAll.Checked := (pmuTranslogErr.Checked and - pmuTransLogReq.Checked and - pmuTransLogRep.Checked); - - MousePos := lvTransports.ClientToScreen(Point(X, Y)); - pmuTrans.Popup(MousePos.X, MousePos.Y); - end; -end; -{--------} -procedure TfrmFFServer.pmuTransLogAllClick(Sender: TObject); -var - aTransport : TffBaseTransport; -begin - { Enable/Disable logging of all options on the selected transport. } - pmuTransLogAll.Checked := not pmuTransLogAll.Checked; - pmuTransLogErr.Checked := pmuTransLogAll.Checked; - pmuTransLogReq.Checked := pmuTransLogAll.Checked; - pmuTransLogRep.Checked := pmuTransLogAll.Checked; - - { Get the transport of interest. } - aTransport := TffBaseTransport(pmuTrans.Tag); - - { Update the transport as required. } - if pmuTransLogAll.Checked then begin - aTransport.EventLogOptions := [fftpLogErrors, fftpLogRequests, fftpLogReplies]; - aTransport.EventLogEnabled := True; - end - else begin - aTransport.EventLogOptions := []; - aTransport.EventLogEnabled := False; - end; - -end; -{--------} -procedure TfrmFFServer.pmuTransLogErrClick(Sender: TObject); -var - aTransport : TffBaseTransport; - aSet : TffTransportLogOptions; -begin - pmuTransLogErr.Checked := not pmuTransLogErr.Checked; - if not pmuTransLogErr.Checked then - pmuTransLogAll.Checked := False; - - { Get the transport of interest. } - aTransport := TffBaseTransport(pmuTrans.Tag); - - aSet := aTransport.EventLogOptions; - if pmuTransLogErr.Checked then begin - Include(aSet, fftpLogErrors); - aTransport.EventLogEnabled := True; - end else - Exclude(aSet, fftpLogErrors); - aTransport.EventLogOptions := aSet; -end; -{--------} -procedure TfrmFFServer.pmuTransLogReqClick(Sender: TObject); -var - aTransport : TffBaseTransport; - aSet : TffTransportLogOptions; -begin - - pmuTransLogReq.Checked := not pmuTransLogReq.Checked; - if not pmuTransLogReq.Checked then - pmuTransLogAll.Checked := False; - - { Get the transport of interest. } - aTransport := TffBaseTransport(pmuTrans.Tag); - - aSet := aTransport.EventLogOptions; - if pmuTransLogReq.Checked then begin - Include(aSet, fftpLogRequests); - aTransport.EventLogEnabled := True; - end else - Exclude(aSet, fftpLogRequests); - aTransport.EventLogOptions := aSet; -end; -{--------} -procedure TfrmFFServer.pmuTransLogRepClick(Sender: TObject); -var - aTransport : TffBaseTransport; - aSet : TffTransportLogOptions; -begin - - pmuTransLogRep.Checked := not pmuTransLogRep.Checked; - if not pmuTransLogRep.Checked then - pmuTransLogAll.Checked := False; - - { Get the transport of interest. } - aTransport := TffBaseTransport(pmuTrans.Tag); - - aSet := aTransport.EventLogOptions; - if pmuTransLogRep.Checked then begin - Include(aSet, fftpLogReplies); - aTransport.EventLogEnabled := True; - end else - Exclude(aSet, fftpLogReplies); - aTransport.EventLogOptions := aSet; {!!.03} - -end; -{====================================================================} - -{===Tray Icon stuff==================================================} -{$IFDEF UseTrayIcon} -procedure TfrmFFServer.tiAdd; -begin - if tiPresent and (not tiActive) then begin - tiInitNotifyData; - tiActive := Shell_NotifyIcon(NIM_ADD, @tiNotifyData); - end; -end; -{--------} -procedure TfrmFFServer.tiCallBack(var Msg : TMessage); -var - P : TPoint; -begin - if (State = ssUpMinimized) then begin - with Msg do begin - case lParam of - WM_RBUTTONDOWN : - begin - GetCursorPos(P); - SetForegroundWindow(Application.Handle); - Application.ProcessMessages; - PopupMenu.Popup(P.X, P.Y); - end; - WM_LBUTTONDBLCLK : - Application.Restore; - end;{case} - end; - end else begin - case Msg.lParam of - WM_LBUTTONDOWN : - SetForegroundWindow(Handle); - WM_RBUTTONDOWN : - begin - SetForegroundWindow(Handle); - GetCursorPos(P); - Application.ProcessMessages; - PopupMenu.Popup(P.X, P.Y); - end; - end; - end; -end; -{--------} -procedure TfrmFFServer.tiDelete; -begin - if tiPresent and tiActive then begin - tiActive := not Shell_NotifyIcon(NIM_DELETE, @tiNotifyData); - end; -end; -{--------} -function TfrmFFServer.tiGetIconHandle : hIcon; -begin - Result := Application.Icon.Handle; - if Result = 0 then - Result := LoadIcon(0, IDI_Application); -end; -{--------} -procedure TfrmFFServer.tiInitNotifyData; -var - Tip : string; -begin - if tiPresent then begin - FillChar(tiNotifyData, sizeof(tiNotifyData), 0); - with tiNotifyData do begin - cbSize := sizeof(tiNotifyData); - Wnd := Handle; - uID := 1; - uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP; - Tip := 'TurboPower FlashFiler [' + ServerName + ']'; - StrCopy(szTip, @Tip[1]); - uCallBackMessage := ffc_tiCallBack; - hIcon := tiGetIconHandle; - Shell_NotifyIcon(NIM_MODIFY, @tiNotifyData) - end; - end; -end; -{$ENDIF} -{====================================================================} - -procedure TfrmFFServer.btnStartClick(Sender: TObject); -begin - CreateEngineMgr; - if not Login then - Exit; - BringServerUp; - SetControls; -end; - -procedure TfrmFFServer.btnStopClick(Sender: TObject); -begin - if not Login then - Exit; - BringServerDown; -// FreeEngineMgr; {!!.06}{Deleted !!.13} - SetControls; -end; - -procedure TfrmFFServer.btnPropsClick(Sender : TObject); -begin - mnuConfigGeneralClick(Sender); -end; - -procedure TfrmFFServer.FormResize(Sender: TObject); {begin !!.06} -begin - if Width < 605 then - Width := 605; - if Height < 300 then - Height := 300; -end; {end !!.06} - -procedure TfrmFFServer.HelpTopics1Click(Sender: TObject); -begin - Application.HelpCommand(HELP_FINDER, 0); -end; - -end. - diff --git a/components/flashfiler/sourcelaz/server/uffsnet.dfm b/components/flashfiler/sourcelaz/server/uffsnet.dfm deleted file mode 100644 index 70fe2a22b..000000000 Binary files a/components/flashfiler/sourcelaz/server/uffsnet.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/server/uffsnet.pas b/components/flashfiler/sourcelaz/server/uffsnet.pas deleted file mode 100644 index 5dc5b44ce..000000000 --- a/components/flashfiler/sourcelaz/server/uffsnet.pas +++ /dev/null @@ -1,313 +0,0 @@ -{*********************************************************} -{* 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 Uffsnet; - -interface - -uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, ExtCtrls, FFSrCfg, FFSrEng, FFLLWsck; - -type - TFFNetConfigForm = class(TForm) - grpTCPIP: TGroupBox; - Label2: TLabel; - lblTCPPort: TLabel; - lblUDPSr: TLabel; - lblUDPCl: TLabel; - chkTCPEnabled: TCheckBox; - chkTCPListen: TCheckBox; - cmbTCPIntf: TComboBox; - edtTCPPort: TEdit; - edtUDPServer: TEdit; - edtUDPClient: TEdit; - grpIPXSPX: TGroupBox; - lblIPXSocket: TLabel; - lblIPXClient: TLabel; - lblSPX: TLabel; - chkIPXEnabled: TCheckBox; - chkIPXListen: TCheckBox; - edtIPXServer: TEdit; - edtIPXClient: TEdit; - edtSPXSocket: TEdit; - grpSUP: TGroupBox; - chkSUPEnabled: TCheckBox; - btnOK: TButton; - btnCancel: TButton; - procedure FormShow(Sender: TObject); - procedure FormCreate(Sender: TObject); - procedure btnOKClick(Sender: TObject); - private - { Private declarations } - - OurGenInfo : TffGeneralInfo; - - FEngine : TffServerEngine; - - { The following variables are used to hold the values retrieved via - ValidateValues. } - TCPPort : integer; - UDPPortS: integer; - UDPPortC: integer; - IPXPortS: integer; - IPXPortC: integer; - SPXPort : integer; - - procedure InitCtrlStates; - - procedure RefreshBindings; - - procedure SetEngine(anEngine : TffServerEngine); - - function ValidateValues : boolean; - { Used to validate user input once the user clicks the OK button. - If all the network config values are valid then this function - returns True and fills in several private variables (listed above) - with the appropriate information. } - - public - { Public declarations } - - property ServerEngine : TffServerEngine read FEngine write SetEngine; - { The server engine being configured by this dialog. } - end; - - procedure EnableGroupBox(aBox : TGroupBox; Value: Boolean); - -implementation - -uses - FFLLBase, - FFLLComp, - FFLLEng, - FFLLExcp, - FFLLProt, - FFSrBDE, - UffEgMgr; - -{$R *.DFM} - -{====================================================================} -procedure TFFNetConfigForm.FormCreate(Sender: TObject); -begin - FEngine := nil; -end; -{--------} -procedure TFFNetConfigForm.FormShow(Sender: TObject); -begin - if not assigned(FEngine) then - Close; - InitCtrlStates; - RefreshBindings; -end; -{--------} -procedure TFFNetConfigForm.InitCtrlStates; -var - ServerUp : boolean; -begin - - ServerUp := (FEngine.State = ffesStarted); - - EnableGroupBox(grpTCPIP, FFEngineManager.TCPIPTransport.Supported); - EnableGroupBox(grpIPXSPX, FFEngineManager.IPXSPXTransport.Supported); - - cmbTCPIntf.Enabled := (not ServerUp); - edtTCPPort.Enabled := (not ServerUp); - edtUDPServer.Enabled := (not ServerUp); - edtUDPClient.Enabled := (not ServerUp); - edtIPXServer.Enabled := (not ServerUp); - edtIPXClient.Enabled := (not ServerUp); - edtSPXSocket.Enabled := (not ServerUp); - -end; -{--------} -procedure TffNetConfigForm.RefreshBindings; -var - Idx : Integer; -begin - FFWSGetLocalHosts(cmbTCPIntf.Items); - Idx := OurGenInfo.giTCPInterface + 1; - if Idx > Pred(cmbTCPIntf.Items.Count) then begin - MessageDlg('The bound interface is no longer available. '+#13+#10 + - 'Bindings will be reset to all adapters.', - mtInformation, [mbOK], 0); - cmbTCPIntf.ItemIndex := 0; - end else - cmbTCPIntf.ItemIndex := Idx; - -end; -function TffNetConfigForm.ValidateValues : boolean; -const - PortError = 'Port number should be a unique number between 1024 and 65535 inclusive'; -var - aControl : TWinControl; - ec : integer; -begin - aControl := nil; - Result := True; - - Val(edtTCPPort.Text, TCPPort, ec); - if (ec <> 0) or (TCPPort < 1024) or (TCPPort > 65535) then begin - Result := False; - if aControl = nil then - aControl := edtTCPPort; - ShowMessage(PortError); - end; - - Val(edtUDPServer.Text, UDPPortS, ec); - if (ec <> 0) or (UDPPortS < 1024) or (UDPPortS > 65535) then begin - Result := False; - if aControl = nil then - aControl := edtUDPServer; - ShowMessage(PortError); - end; - - Val(edtUDPClient.Text, UDPPortC, ec); - if (ec <> 0) or (UDPPortC < 1024) or (UDPPortC > 65535) or - (UDPPortS = UDPPortC) then begin - Result := False; - if aControl = nil then - aControl := edtUDPClient; - ShowMessage(PortError); - end; - - Val(edtIPXServer.Text, IPXPortS, ec); - if (ec <> 0) or (IPXPortS < 1024) or (IPXPortS > 65535) then begin - Result := False; - if aControl = nil then - aControl := edtIPXServer; - ShowMessage(PortError); - end; - - Val(edtIPXClient.Text, IPXPortC, ec); - if (ec <> 0) or (IPXPortC < 1024) or (IPXPortC > 65535) or - (IPXPortC = IPXPortS) then begin - Result := False; - if aControl = nil then - aControl := edtIPXClient; - ShowMessage(PortError); - end; - - Val(edtSPXSocket.Text, SPXPort, ec); - if (ec <> 0) or (SPXPort < 1024) or (SPXPort > 65535) or - (SPXPort = IPXPortS) or (SPXPort = IPXPortC) then begin - Result := False; - if aControl = nil then - aControl := edtTCPPort; - ShowMessage(PortError); - end; - - if assigned(aControl) then - ActiveControl := aControl; -end; -{--------} -procedure TFFNetConfigForm.btnOKClick(Sender: TObject); -var - errStr : array [0..127] of char; - aResult : TffResult; -begin - if ValidateValues then begin - with OurGenInfo do begin - giTCPPort := TCPPort; - giUDPPortSr := UDPPortS; - giUDPPortCl := UDPPortC; - giIPXSocketSr := IPXPortS; - giIPXSocketCl := IPXPortC; - giSPXSocket := SPXPort; - FFSetTCPPort(TCPPort); - FFSetUDPPortServer(UDPPortS); - FFSetUDPPortClient(UDPPortC); - FFSetIPXSocketServer(IPXPortS); - FFSetIPXSocketClient(IPXPortC); - FFSetSPXSocket(SPXPort); - giSingleUser := chkSUPEnabled.Checked; - giIPXSPX := chkIPXEnabled.Checked; - giIPXSPXLFB := chkIPXListen.Checked; - giTCPIP := chkTCPEnabled.Checked; - giTCPIPLFB := chkTCPListen.Checked; - giTCPInterface := cmbTCPIntf.ItemIndex - 1; - end; - FEngine.Configuration.GeneralInfo^ := OurGenInfo; - aResult := FEngine.WriteGeneralInfo(False); - if aResult <> DBIERR_NONE then begin - ffStrResBDE.GetASCIIZ(aResult, errStr, sizeof(DBIMSG)); - showMessage(format('Could not save configuration: %s [$%x/%d])', - [strPas(errStr), aResult, aResult])); - self.modalResult := mrNone; - end - else - ModalResult := mrOK; - end else - ModalResult := mrNone; -end; -{--------} -procedure TFFNetConfigForm.SetEngine(anEngine : TffServerEngine); -begin - FEngine := anEngine; - if assigned(FEngine) then begin - OurGenInfo := FEngine.Configuration.GeneralInfo^; - with OurGenInfo do begin - chkSUPEnabled.Checked := giSingleUser; - chkIPXEnabled.Checked := giIPXSPX; - chkIPXListen.Checked := giIPXSPXLFB; - chkTCPEnabled.Checked := giTCPIP; - chkTCPListen.Checked := giTCPIPLFB; - edtTCPPort.Text := IntToStr(giTCPPort); - edtUDPServer.Text := IntToStr(giUDPPortSr); - edtUDPClient.Text := IntToStr(giUDPPortCl); - edtIPXServer.Text := IntToStr(giIPXSocketSr); - edtIPXClient.Text := IntToStr(giIPXSocketCl); - edtSPXSocket.Text := IntToStr(giSPXSocket); - end; - end; -end; -{====================================================================} - -{===Utility routines=================================================} -procedure EnableGroupBox(aBox : TGroupBox; Value: Boolean); -var - anIndex : integer; -begin - - aBox.Enabled := Value; - if not Value then - aBox.Font.Color := clGrayText; - - { Disable the child controls. } - for anIndex := 0 to pred(aBox.ControlCount) do begin - aBox.Controls[anIndex].Enabled := Value; - end; - -end; - -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/server/uffspwd.dfm b/components/flashfiler/sourcelaz/server/uffspwd.dfm deleted file mode 100644 index 4637ce9ac..000000000 Binary files a/components/flashfiler/sourcelaz/server/uffspwd.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/server/uffspwd.pas b/components/flashfiler/sourcelaz/server/uffspwd.pas deleted file mode 100644 index 52c2d217d..000000000 --- a/components/flashfiler/sourcelaz/server/uffspwd.pas +++ /dev/null @@ -1,111 +0,0 @@ -{*********************************************************} -{* User password maintenance 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 ***** *) - -unit uFFSPwd; - -{$I FFDEFINE.INC} - -interface - -uses - Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - ExtCtrls, StdCtrls, Buttons; - -type - TPwdForm = class(TForm) - edtFirstTry: TEdit; - lblFisrtTry: TLabel; - lblSecondTry: TLabel; - edtSecondTry: TEdit; - btnOK: TBitBtn; - btnCancel: TBitBtn; - pnlBottom: TPanel; - bvlUpper: TBevel; - procedure btnOKClick(Sender: TObject); - procedure edtFirstTryKeyDown(Sender: TObject; var Key: Word; - Shift: TShiftState); - private - { Private declarations } - PanelVisible : boolean; - OldPanelColor : TColor; - OldPanelFontColor : TColor; - public - { Public declarations } - procedure ShowError(const Msg : string); - end; - -var - PwdForm: TPwdForm; - -implementation - -{$R *.DFM} - -procedure TPwdForm.btnOKClick(Sender: TObject); -begin - if (edtFirstTry.Text = edtSecondTry.Text) then - if (edtFirstTry.Text = '') then - ShowError('The password cannot be blank, please re-enter it') - else - ModalResult := mrOK - else - ShowError('The two passwords are not the same, please re-enter them'); -end; - -procedure TPwdForm.edtFirstTryKeyDown(Sender: TObject; var Key: Word; - Shift: TShiftState); -begin - if PanelVisible then begin - PanelVisible := false; - with pnlBottom do begin - Caption := ''; - Font.Color := OldPanelFontColor; - Color := OldPanelColor; - end; - end; -end; - -procedure TPwdForm.ShowError(const Msg : string); -begin - if not PanelVisible then begin - PanelVisible := true; - with pnlBottom do begin - OldPanelFontColor := Font.Color; - OldPanelColor := Color; - Font.Color := clWhite; - Color := clGreen; - end; - end; - pnlBottom.Caption := Msg; - edtFirstTry.Text := ''; - edtSecondTry.Text := ''; - ActiveControl := edtFirstTry; -end; - -end. diff --git a/components/flashfiler/sourcelaz/server/uffsuser.dfm b/components/flashfiler/sourcelaz/server/uffsuser.dfm deleted file mode 100644 index 214cab565..000000000 Binary files a/components/flashfiler/sourcelaz/server/uffsuser.dfm and /dev/null differ diff --git a/components/flashfiler/sourcelaz/server/uffsuser.pas b/components/flashfiler/sourcelaz/server/uffsuser.pas deleted file mode 100644 index d599825ca..000000000 --- a/components/flashfiler/sourcelaz/server/uffsuser.pas +++ /dev/null @@ -1,600 +0,0 @@ -{*********************************************************} -{* User maintenance 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 ***** *) - -unit uFFSUser; - -{$I FFDEFINE.INC} - -interface - -uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, Buttons, ExtCtrls, Grids, ComCtrls, ToolWin, Menus, - {$IFDEF DCC4ORLATER} - ImgList, - {$ENDIF} - FFLLBase, - FFLLUNC, - FFHash, - FFTbDict, - FFSrBase, - FFSrBDE, - FFSrTran, - FFSrCfg, - FFSrEng, - ffllgrid; - -type - TFFUserForm = class(TForm) - pnlLower: TPanel; - btnSave: TBitBtn; - btnDiscard: TBitBtn; - grdUsers: TffStringGrid; - imgChkBoxClear: TImage; - imgChkBoxSet: TImage; - tbMain: TToolBar; - pbDelete: TToolButton; - ToolButton2: TToolButton; - pbPassword: TToolButton; - mnuMain: TMainMenu; - mnuUser: TMenuItem; - mnuUserDelete: TMenuItem; - mnuUserPassword: TMenuItem; - imgMain: TImageList; - procedure btnDeleteClick(Sender: TObject); - procedure btnPasswordClick(Sender: TObject); - procedure btnSaveClick(Sender: TObject); - procedure FormShow(Sender: TObject); - procedure grdUsersDrawCell(Sender: TObject; ACol, ARow: Integer; - Rect: TRect; State: TGridDrawState); - procedure grdUsersKeyDown(Sender: TObject; var Key: Word; - Shift: TShiftState); - procedure grdUsersKeyPress(Sender: TObject; var Key: Char); - procedure grdUsersSortColumn(Sender: TffStringGrid; aCol: Integer); - procedure grdUsersMouseUp(Sender: TObject; Button: TMouseButton; - Shift: TShiftState; X, Y: Integer); - procedure grdUsersSelectCell(Sender: TObject; ACol, ARow: Integer; - var CanSelect: Boolean); - private - FEngine : TffServerEngine; - - procedure ufPopulateColHeaders; - procedure ufPopulateGrid; - procedure ufSetEngine(anEngine : TffServerEngine); - - public - property ServerEngine : TffServerEngine read FEngine write ufSetEngine; - end; - -var - FFUserForm: TFFUserForm; - -implementation - -uses - uFFSPwd, - FFLLExcp; - -{$R *.DFM} - -const - UnknownPwdHash = $FFFFFFFF; - - { Column constants } - cnUserID = 0; - cnLastName = 1; - cnFirstName = 2; - cnAdmin = 3; - cnRead = 4; - cnInsert = 5; - cnUpdate = 6; - cnDelete = 7; - - { Cell margin constants } - cnTopMargin = 2; - cnLeftMargin = 2; - - { Boolean field constants } - cnTrue = 1; - cnFalse = 0; - -{===Helper methods===================================================} -procedure TFFUserForm.ufSetEngine(anEngine : TffServerEngine); -begin - FEngine := anEngine; - - { Set the row count. } - grdUsers.RowCount := FEngine.Configuration.UserList.Count + 2; - grdUsers.Row := 1; -end; -{====================================================================} - - -{===Grid methods & event handlers====================================} -procedure TFFUserForm.FormShow(Sender: TObject); -begin - ufPopulateColHeaders; - ufPopulateGrid; - grdUsers.SetFocus; - { Psition to the 1st non-admin user row. } - with grdUsers do begin - Col := cnUserID; - { Is the first row the Admin user? } - if Cells[cnUserID, 1] = ffc_AdminUserID then - { Yes. Position to subsequent row. } - Row := 2 - else - { No. Position to the first row. } - Row := 1; - end; -end; -{--------} -procedure TFFUserForm.grdUsersDrawCell(Sender: TObject; ACol, - ARow: Integer; Rect: TRect; State: TGridDrawState); -var - aBitmap: TBitmap; - aStr : string; - Grid : TffStringGrid absolute Sender; - Dest, Source: TRect; -begin - - { Leave fixed portion of the grid alone} - if gdFixed in State then - Exit; - - { Is this a boolean field? } - if aCol >= cnAdmin then begin - if longInt(Grid.Objects[aCol, aRow]) = cnTrue then - aBitmap := imgChkBoxSet.Picture.Bitmap - else - aBitmap := imgChkBoxClear.Picture.Bitmap; - with Grid.Canvas do begin - Dest := Bounds(Rect.Left + ((Rect.Right - aBitmap.Width - Rect.Left) div 2), - Rect.Top + (Grid.DefaultRowHeight - aBitmap.Height) div 2, - aBitmap.Width, - aBitmap.Height); - Source := Bounds(0, 0, aBitmap.Width, aBitmap.Height); - BrushCopy(Dest, - aBitmap, - Source, - aBitmap.TransparentColor); - end; - end else begin - { No. Draw the text. } - aStr := Grid.Cells[aCol, aRow]; - - with Grid do begin - if (aCol = cnUserID) and - (Cells[cnUserID, aRow] <> '') and - (TffWord32(Objects[cnUserID, aRow]) = UnknownPwdHash) then begin - Canvas.Brush.Color := clRed; - Canvas.Font.Color := clWhite; - end; - Canvas.FillRect(Rect); - Canvas.TextRect(Rect, Rect.Left + cnLeftMargin, Rect.Top + cnTopMargin, aStr); - end; - end; - -end; -{--------} -procedure TFFUserForm.grdUsersKeyDown(Sender: TObject; var Key: Word; - Shift: TShiftState); -var - Grid : TffStringGrid absolute Sender; -begin - { Change the selected cell (Enter as tab)} - case Key of - VK_RETURN : - with Grid do begin - if Col < Pred(ColCount) then - Col := Col + 1 - else if Row < Pred(RowCount) then begin - Row := Row + 1; - Objects[cnUserID, Row] := pointer(UnknownPwdHash); - Col := cnUserID; - end else begin - { Is this cell blank? } - if Cells[Col, Row] = '' then begin - { Yes. Wrap to first row of grid. } - Row := 1; - Col := cnUserID; - end else begin - { No. Add a new blank row. } - RowCount := RowCount + 1; - Row := Pred(RowCount); - Col := cnUserID; - Objects[cnUserID, Row] := pointer(UnknownPwdHash); - end; - end; - end; - VK_DOWN : - with Grid do begin - { Are we trying to arrow down from an incomplete row? } - if (Row = pred(RowCount)) then - if AnyCellIsEmpty(Row) then begin - { Yes. Do not allow this to occur. } - Key := 0; - MessageBeep(0); - end else begin - { No. Make sure we have a new blank row. } - RowCount := RowCount + 1; - Objects[cnUserID, pred(RowCount)] := pointer(UnknownPwdHash); - end; - end; - VK_UP, VK_TAB : - with Grid do begin - { Are we trying to arrow up from or Tab forward out of a new, - completed row? } - if (Row = pred(RowCount)) and (Cells[cnUserID, Row] <> '') then - { Yes. Add a new blank row. } - RowCount := RowCount + 1; - Objects[cnUserID, pred(RowCount)] := pointer(UnknownPwdHash); - end; - end; { case } -end; -{--------} -procedure TFFUserForm.grdUsersKeyPress(Sender: TObject; var Key: Char); -const - validEditKeys = [#8, #9, #13]; -var - Grid : TffStringGrid absolute Sender; - Ignore: Boolean; - Value: string; -begin - if not (Key in validEditKeys) then begin - { Validate data entry as key's are pressed} - case Grid.Col of - cnUserID, cnLastName, cnFirstName : - begin - Value := Grid.Cells[Grid.Col, Grid.Row]; - Ignore := (Length(Value) >= ffcl_UserNameSize); - end; - cnAdmin, cnRead, cnInsert, cnUpdate, cnDelete : - begin - Ignore := - (Grid.Cells[cnUserID, Grid.Row] = ffc_AdminUserID) or - (Key <> ' '); - if not Ignore then begin - if longInt(Grid.Objects[Grid.Col, Grid.Row]) = cnTrue then - Grid.Objects[Grid.Col, Grid.Row] := pointer(cnFalse) - else - Grid.Objects[Grid.Col, Grid.Row] := pointer(cnTrue); - end; - end; - else - Ignore := False; - end; { case } - if Ignore then begin - Key := #0; - MessageBeep(0); - end; - end; -end; -{--------} -procedure TFFUserForm.grdUsersMouseUp(Sender: TObject; - Button: TMouseButton; Shift: TShiftState; X, Y: Integer); -var - ACol, ARow: Longint; - Rect, Dest : TRect; - Grid : TffStringGrid absolute Sender; -begin - - if Button <> mbLeft then Exit; - - - Grid.MouseToCell(X, Y, ACol, ARow); - { If this is not a valid row or if this is the Admin user then exit. We do - the latter because the Admin user may not be modified. } - if (ARow < 0) or - (Grid.Cells[cnUserID, ARow] = ffc_AdminUserID) then - exit; - - { Is this a rights cell? } - if ACol >= cnAdmin then begin - Rect := Grid.CellRect(ACol, ARow); - with imgChkBoxSet.Picture do - { Retrieve the rect from around the box itself} - Dest := Bounds(Rect.Left + ((Rect.Right - Bitmap.Width - Rect.Left) div 2), - Rect.Top + (Grid.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) then begin - if longInt(Grid.Objects[aCol, aRow]) = cnTrue then - Grid.Objects[aCol, aRow] := pointer(cnFalse) - else - Grid.Objects[aCol, aRow] := pointer(cnTrue); - end; - end; -end; -{--------} -procedure TFFUserForm.grdUsersSelectCell(Sender : TObject; - ACol, ARow : Integer; - var CanSelect : Boolean); -var - Grid : TffStringGrid absolute Sender; -begin - CanSelect := true; - {if we're on the administrator row, no editing} - if (Grid.Cells[cnUserID, ARow] = ffc_AdminUserID) then - Grid.Options := Grid.Options - [goAlwaysShowEditor, goEditing] - {if we're in a column with checkboxes, no editing} - else if ACol >= cnAdmin then - Grid.Options := Grid.Options - [goAlwaysShowEditor, goEditing] - {otherwise allow editing} - else - Grid.Options := Grid.Options + [goEditing]; - if (ARow = pred(Grid.RowCount)) and - (Grid.Cells[cnUserID, ARow] <> '') then begin - { Yes. Add a new blank row. } - Grid.RowCount := Grid.RowCount + 1; - Grid.Objects[cnUserID, Pred(Grid.RowCount)] := pointer(UnknownPwdHash); - end; -end; -{--------} -procedure TFFUserForm.grdUsersSortColumn(Sender: TffStringGrid; - aCol: Integer); -var - aStr : string; - i, j : integer; - LastRow : integer; -begin - if (Sender.RowCount > 1) and (aCol < cnAdmin) then - with Sender do begin - - if LastRowIsEmpty then - LastRow := (RowCount - 2) - else - LastRow := pred(RowCount); - - BeginUpdate; - try - for i := 1 to LastRow do begin - SaveRow(i); - aStr := Cells[aCol, i]; - j := i; - while (j > 1) and - (ansiCompareStr(Cells[aCol, j-1], aStr) > 0) do begin - CopyRow(j-1, j); - dec(j); - end; { while } - RestoreToRow(j); - end; { for } - finally - EndUpdate; - end; - end; { with } -end; -{--------} -procedure TFFUserForm.ufPopulateColHeaders; -begin - with grdUsers do begin - BeginUpdate; - try - Cells[cnUserID, 0] := 'User ID'; - Cells[cnLastName, 0] := 'Last Name'; - Cells[cnFirstName, 0] := 'First Name'; - Cells[cnAdmin, 0] := 'Admin'; - Cells[cnRead, 0] := 'Read'; - Cells[cnInsert, 0] := 'Insert'; - Cells[cnUpdate, 0] := 'Update'; - Cells[cnDelete, 0] := 'Delete'; - finally - EndUpdate; - end; - end; -end; -{--------} -procedure TffUserForm.ufPopulateGrid; -var - Item : TffUserItem; - Inx : integer; -begin - with grdUsers do begin - BeginUpdate; - try - for Inx := 1 to FEngine.Configuration.UserList.Count do begin - Item := FEngine.Configuration.UserList[pred(Inx)]; - Cells[cnUserID, Inx] := Item.UserID; - Objects[cnUserID, Inx] := pointer(Item.PasswordHash); - Cells[cnLastName, Inx] := Item.LastName; - Cells[cnFirstName, Inx] := Item.FirstName; - if arAdmin in Item.Rights then - Objects[cnAdmin, Inx] := pointer(cnTrue) - else - Objects[cnAdmin, Inx] := pointer(cnFalse); - - if arRead in Item.Rights then - Objects[cnRead, Inx] := pointer(cnTrue) - else - Objects[cnRead, Inx] := pointer(cnFalse); - - if arInsert in Item.Rights then - Objects[cnInsert, Inx] := pointer(cnTrue) - else - Objects[cnInsert, Inx] := pointer(cnFalse); - - if arUpdate in Item.Rights then - Objects[cnUpdate, Inx] := pointer(cnTrue) - else - Objects[cnUpdate, Inx] := pointer(cnFalse); - - if arDelete in Item.Rights then - Objects[cnDelete, Inx] := pointer(cnTrue) - else - Objects[cnDelete, Inx] := pointer(cnFalse); - - end; - finally - EndUpdate; - end; - end; -end; -{====================================================================} - - -{===Button methods===================================================} -procedure TFFUserForm.btnDeleteClick(Sender: TObject); -var - DeletedRow : integer; - Inx : integer; - LastEmpty : boolean; - LastRow : integer; -begin - - if (grdUsers.RowCount < 2) then - Exit; - - with grdUsers do begin - BeginUpdate; - try - DeletedRow := Row; - LastRow := pred(RowCount); - LastEmpty := LastRowIsEmpty; - - { Situation where delete in not okay - 1. When the row represents the admin user } - - if UpperCase(Cells[cnUserID, DeletedRow]) = 'ADMIN' then begin - MessageBeep(0); - Exit; - end; - - { Situations where delete is okay: - 1. Non-last row - 2. Last row and it is not empty } - - { Does user want to delete the last row? } - if (DeletedRow < LastRow) then begin - - { No. Move the rows up by one. } - - for Inx := succ(DeletedRow) to lastRow do - CopyRow(Inx, pred(Inx)); - - { Get rid of the last row. } - RowCount := RowCount - 1; - - end else if (not LastEmpty) then - { Yes, user wants to delete last row and it is not empty. } - BlankRow(Row); - - finally - EndUpdate; - end; - end; -end; -{--------} -procedure TFFUserForm.btnPasswordClick(Sender: TObject); -var - PwdForm : TPwdForm; - User : string; -begin - PwdForm := TPwdForm.Create(Application); - try - User := grdUsers.Cells[cnUserID, grdUsers.Row]; - if User = '' then - PwdForm.Caption := 'Password for unknown user' - else - PwdForm.Caption := 'Password for ' + User; - if (PwdForm.ShowModal = mrOK) then - grdUsers.Objects[cnUserID, grdUsers.Row] := - pointer(FFCalcShStrELFHash(PwdForm.edtFirstTry.Text)); - finally - PwdForm.Free; - end; -end; -{--------} -procedure TFFUserForm.btnSaveClick(Sender: TObject); -var - Inx : integer; - errStr : array [0..127] of char; - aResult : TffResult; - Rights : TffUserRights; - CanSave : Boolean; -begin - CanSave := True; - with grdUsers do - for Inx := 1 to Pred(RowCount - 1) do - if AnsiCompareStr(Cells[cnUserID, Inx], 'admin') <> 0 then - if TffWord32(Objects[cnUserID, Inx]) = UnknownPwdHash then begin - CanSave := False; - Break; - end; - if not CanSave then begin - MessageDlg('Please enter a password for each user.', mtError, [mbOK], 0); - ModalResult := mrNone; - Exit; - end; - - FEngine.Configuration.UserList.Empty; - - { Xfer the info from the grid to the engine's user list. } - with grdUsers do - for Inx := 1 to pred(RowCount) do begin - Rights := []; - { Do we have a user ID? } - if Cells[cnUserID, Inx] <> '' then begin - if longInt(Objects[cnAdmin, Inx]) = cnTrue then - Include(Rights, arAdmin); - - if longInt(Objects[cnRead, Inx]) = cnTrue then - Include(Rights, arRead); - - if longInt(Objects[cnInsert, Inx]) = cnTrue then - Include(Rights, arInsert); - - if longInt(Objects[cnUpdate, Inx]) = cnTrue then - Include(Rights, arUpdate); - - if longInt(Objects[cnDelete, Inx]) = cnTrue then - Include(Rights, arDelete); - - FEngine.Configuration.AddUser(Cells[cnUserID, Inx], - Cells[cnLastName, Inx], - Cells[cnFirstName, Inx], - TffWord32(Objects[cnUserID, Inx]), - Rights); - end; - end; - - aResult := FEngine.WriteUserData; - if aResult <> DBIERR_NONE then begin - ffStrResBDE.GetASCIIZ(aResult, errStr, sizeof(DBIMSG)); - showMessage(format('Could not save users: %s [$%x/%d])', - [strPas(errStr), aResult, aResult])); - self.modalResult := mrNone; - end; -end; -{====================================================================} - -end. diff --git a/components/flashfiler/sourcelaz/service/ffllsvc.pas b/components/flashfiler/sourcelaz/service/ffllsvc.pas deleted file mode 100644 index b85d70606..000000000 --- a/components/flashfiler/sourcelaz/service/ffllsvc.pas +++ /dev/null @@ -1,763 +0,0 @@ -{*********************************************************} -{* FlashFiler service base 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 ffllsvc; - -interface - -uses - Windows, - {$IFNDEF DCC4OrLater} - usvctype, - {$ENDIF} - {$IFDEF DCC6OrLater} - Variants, - {$ENDIF} - WinSvc; - - -type - PArgArray = ^Pchar; - { Represents a pointer to an array of pointers where each element in the - array points to a null-terminated string. } - - procedure Execute; - { This is the main entry point for the executable. If no command line - parameters are present, this method assumes it was started by the - the Service Control Manager (SCM). - - If command line parameters are present, this method evaluates and carries - out the parameters. Each parameter may be prefixed by a '-' or '/'. - Valid parameters: - - D - Enable debug logging - I - Install the service - U - Uninstall the service - } - - { The following procedures are entrypoints for the Service Control Manager - (SCM). } - - procedure ControlHandler(CtrlCode : DWORD); stdcall; - { Called when the SCM sends a control code to the service (e.g., pause, - continue, stop). This method must carry out the requested operation. - Windows SDK topics: - - Handler - - Writing a Control Handler function - - Parameters: - CtrlCode - The control code. } - - - procedure ServiceMain(NumArgs : DWORD; Args : PArgArray); stdcall; - { Called when the SCM wants to execute the service. - Windows SDK topics: - - ServiceMain - - Writing a ServiceMain function - - Parameters: - numArgs - The number of arguments in argArray. - argArray - Pointer to an array of pointers that point to null-terminated - argument strings. The first argument is the name of the service. - Subsequent arguments are strings passed to the service by the process - that initiated the service. } - - -implementation - -{$R FFSVCMSG.RES} - -uses - Registry, - SysUtils, - FFLLBase, - FFLLComm, - ffllprot, {!!.02} -{Begin !!.13} - UffEgMgr, - ffsrjour, - uFFSRJrn; -{End !!.13} - -const - ffc_ConflictingParm : string = 'Conflicting parameter: %s'; - ffc_DisplayName : string = 'FlashFiler Service %5.4f %s'; - ffc_EngMgrStartup : string = 'Error during Engine Mgr startup: %s'; - ffc_EngMgrShutdown : string = 'Error during Engine Mgr shutdown: %s'; - ffc_ServiceName : string = 'FlashFilerService'; - ffc_DebugMode = 'D'; - ffc_GenError = 1000; - ffc_GenDebug = 1000; {!!.02} - ffc_Install = 'I'; - ffc_InvalidParm = 'Invalid parameter: %s'; - ffc_Uninstall = 'U'; - - { Event logging constants } - ffc_EventLogKey = '\System\CurrentControlSet\Services\EventLog\Application'; - { The registry key in which the event log sources are defined. } - ffc_EventMsgFile = 'EventMessageFile'; - { The name of the data value specifying the event message file. NT looks - here to map an event log message ID to an actual message. } - ffc_KeyOpenFail = 'Could not open registry key %s'; - ffc_RegisterSrc = 'Could not register event log source %s'; - ffc_TypesSupported = 'TypesSupported'; - { The name of the data value specifying which types of event log messages - are supported by this source. This example assumes you will need to log - informational messages only. } - - ffc_JournalStateEventTypes : array[TJournalState] of Word = ( - EVENTLOG_WARNING_TYPE, - EVENTLOG_ERROR_TYPE, - EVENTLOG_ERROR_TYPE, - EVENTLOG_ERROR_TYPE ); - -var - ffDebugMode : boolean; - ffEngineMgr : TffEngineManager; - ffIsService : boolean; - ffSvcEvent : TffEvent; - ffSvcStatus : TServiceStatus; - { For info on this data structure, see topic SERVICE_STATUS in the Windows - SDK. } - ffSvcStatusHandle : SERVICE_STATUS_HANDLE; - ffLog : System.Text; - -{===Utility Routines=================================================} -procedure WriteLog(aMsg : string; args : array of const); -{Begin !!.10} -const - LogName = 'FFSrvice.log'; -begin - System.Assign(ffLog, LogName); - if FileExists(LogName) then - System.Append(ffLog) - else - System.Rewrite(ffLog); -{End !!.10} - WriteLn(ffLog, format(aMsg, args)); - System.Close(ffLog); -end; -{--------} -procedure WriteEvent(const aType : Word; const aEventID : DWORD; - const aString : string); -var - LogHandle : THandle; - PMsg : pointer; -begin - - { Open the event log. } - LogHandle := RegisterEventSource(nil, PChar(ffc_ServiceName)); - if LogHandle <> NULL then - try - if aString = '' then - ReportEvent(LogHandle, aType, 0, aEventID, nil, 0, 0, nil, nil) - else begin - PMsg := PChar(aString); - ReportEvent(LogHandle, aType, 0, aEventID, nil, 1, 0, @PMsg, - nil); - end; - finally - { Close the event log. } - CloseEventLog(LogHandle); - end; -end; -{--------} -procedure ReportErrorFmt(const aMsg : string; args : array of const); -begin - if ffIsService then - WriteEvent(EVENTLOG_ERROR_TYPE, ffc_GenError, format(aMsg, args)) - else - WriteLog(aMsg, args); -end; -{--------} -procedure ReportLastError; -var - Buffer : array[0..255] of char; - Len : DWORD; - Status : DWORD; -begin - Status := GetLastError; - Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, Status, 0, - Buffer, SizeOf(Buffer), nil); - if Len > 0 then - if ffIsService then - WriteEvent(EVENTLOG_ERROR_TYPE, ffc_GenError, Buffer) - else - WriteLog(Buffer,['']); -end; -{--------} -procedure Debug(const aMsg : string); -begin - - if not ffDebugMode then exit; - - if ffIsService then - WriteEvent(EVENTLOG_INFORMATION_TYPE, ffc_GenDebug, aMsg) - else - WriteLog(aMsg, ['']); -end; -{--------} -procedure DebugFmt(const aMsg : string; args : array of const); -begin - if not ffDebugMode then exit; - - if ffIsService then - WriteEvent(EVENTLOG_INFORMATION_TYPE, ffc_GenDebug, format(aMsg, args)) - else - WriteLog(aMsg, args); -end; -{--------} -procedure NotifySCM(const WaitHint : DWORD); -begin - ffSvcStatus.dwWaitHint := WaitHint; - if not SetServiceStatus(ffSvcStatusHandle, ffSvcStatus) then - ReportLastError; -end; -{--------} -procedure InitEngineMgr(anEngineMgr : TffEngineManager); -begin - { The following is hard-coded but it is the best we can do - right now. The best solution is to have persistent storage - of transport properties. } - with anEngineMgr.ServerEngine.Configuration.GeneralInfo^ do begin - - DebugFmt('Loading configuration from %s', - [anEngineMgr.ServerEngine.ConfigDir]); - -{Begin !!.02} - anEngineMgr.ServerEngine.BufferManager.MaxRAM := giMaxRAM; - {..ports} - FFSetTCPPort(giTCPPort); - FFSetUDPPortServer(giUDPPortSr); - FFSetUDPPortClient(giUDPPortCl); - FFSetIPXSocketServer(giIPXSocketSr); - FFSetIPXSocketClient(giIPXSocketCl); - FFSetSPXSocket(giSPXSocket); - {..keepalive stuff} - ffc_LastMsgInterval := giLastMsgInterval; - ffc_KeepAliveInterval := giKAInterval; - ffc_KeepAliveRetries := giKARetries; -{End !!.02} - - anEngineMgr.SUPTransport.Enabled := giSingleUser; - if giSingleUser then begin - anEngineMgr.SUPTransport.BeginUpdate; - try - Debug('Starting SUP transport'); - anEngineMgr.SUPTransport.ServerName := giServerName; - anEngineMgr.SUPTransport.Mode := fftmListen; - anEngineMgr.SUPTransport.EndUpdate; - Debug('SUP transport started'); - except - anEngineMgr.SUPTransport.CancelUpdate; - end; - end; - - anEngineMgr.IPXSPXTransport.Enabled := giIPXSPX; - if giIPXSPX then begin - anEngineMgr.IPXSPXTransport.BeginUpdate; - try - Debug('Starting IPXSPX transport'); - anEngineMgr.IPXSPXTransport.ServerName := giServerName; - anEngineMgr.IPXSPXTransport.RespondToBroadcasts := giIPXSPXLFB; - anEngineMgr.IPXSPXTransport.Mode := fftmListen; - anEngineMgr.IPXSPXTransport.EndUpdate; - Debug('IPXSPX transport started'); - except - anEngineMgr.IPXSPXTransport.CancelUpdate; - end; - end; - - anEngineMgr.TCPIPTransport.Enabled := giTCPIP; - if giTCPIP then begin - anEngineMgr.TCPIPTransport.BeginUpdate; - try - Debug('Starting TCPIP transport'); - anEngineMgr.TCPIPTransport.ServerName := giServerName; - anEngineMgr.TCPIPTransport.RespondToBroadcasts := giTCPIPLFB; - anEngineMgr.TcpIPTransport.Mode := fftmListen; - anEngineMgr.TCPIPTransport.EndUpdate; - ffc_TCPInterface := giTCPInterface; {!!.02} - Debug('TCPIP transport started'); - except - anEngineMgr.TCPIPTransport.CancelUpdate; - end; - end else - Debug('TCPIP turned off in config file'); - end; -end; -{--------} -procedure Install; -const - Prefix = 'Install.'; -var - BinaryPathAndName : array[0..MAX_PATH] of char; - Registry : TRegistry; - scmHandle : SC_HANDLE; - svcHandle : SC_HANDLE; - Args : PChar; -begin - - Debug(Prefix + 'OpenSCManager'); - - { Open the service manager on the local computer. } - scmHandle := OpenSCManager(nil, nil, SC_MANAGER_CREATE_SERVICE); - - { Did we get a handle? } - if scmHandle = 0 then begin - { No. Assume we are in console mode & output the associated error - message. } - ReportLastError; - exit; - end; - - try - Debug(Prefix + 'GetModuleFileName'); - - { Get the path and filename of this executable. } - GetModuleFileName(0, BinaryPathAndName, SizeOf(BinaryPathAndName)); - - { Create the service. } - Debug(Prefix + 'CreateService'); - svcHandle := CreateService(scmHandle, - PChar(ffc_ServiceName), - PChar(format(ffc_DisplayName, - [ffVersionNumber/10000.0, - ffSpecialString])), - SERVICE_ALL_ACCESS, - SERVICE_WIN32_OWN_PROCESS, - SERVICE_AUTO_START, - SERVICE_ERROR_NORMAL, - @BinaryPathAndName, - nil, nil, nil, nil, nil); - { Did it work? } - if svcHandle = 0 then - ReportLastError - else begin - Args := nil; - StartService(svcHandle, 0, Args); - CloseServiceHandle(svcHandle); - end; - finally - { Close the handle returned by the service manager. } - CloseServiceHandle(scmHandle); - end; - - { Register ourselves as a message source. - Create registry entries in - HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\EventLog\Application - - <application name> <- regarded as a "source" by Win NT - EventMessageFile - The path for the event identifier message file - TypesSupported - The type of events that may be logged - - NOTE: In order for the application to write to HKEY_LOCAL_MACHINE, the - logged in user must have administrative privileges. - } - - Debug(Prefix + 'TRegistry.Create'); - Registry := TRegistry.Create; - try - Registry.RootKey := HKEY_LOCAL_MACHINE; - - Debug(Prefix + 'Registry.OpenKey'); - if Registry.OpenKey(ffc_EventLogKey, False) then - try - Debug(Prefix + 'Registry.CreateKey'); - Registry.CreateKey(ffc_ServiceName); - Registry.OpenKey(ffc_EventLogKey + '\' + ffc_ServiceName, False); - { Assumes the application contains the messages used for logging. } - Registry.WriteString(ffc_EventMsgFile, BinaryPathAndName); - Registry.WriteInteger(ffc_TypesSupported, - EVENTLOG_INFORMATION_TYPE or - EVENTLOG_ERROR_TYPE); - except - on E:Exception do - ReportErrorFmt(ffc_RegisterSrc, [ffc_ServiceName]); - end - else begin - ReportErrorFmt(ffc_KeyOpenFail, [ffc_EventLogKey]); - end; - finally - Registry.Free; - end; - - Debug(Prefix + 'End'); - -end; -{--------} -procedure Uninstall; -const - Prefix= 'Uninstall'; -var - scmHandle : SC_HANDLE; - svcHandle : SC_HANDLE; -begin - - Debug(Prefix + 'OpenSCManager'); - - { Open the service manager on the local computer. } - scmHandle := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS); - - { Did we get a handle? } - if scmHandle = 0 then begin - { No. Assume we are in console mode & output the associated error - message. } - ReportLastError; - exit; - end; - - try - Debug(Prefix + 'OpenService'); - - { Open the service. } - svcHandle := OpenService(scmHandle, PChar(ffc_ServiceName), - SERVICE_ALL_ACCESS); - - { Did it open? } - if svcHandle = 0 then - { No. Report error and exit. } - ReportLastError - else begin - Debug(Prefix + 'DeleteService'); - { Yes. Stop and delete the service. } - ControlService(svcHandle, SERVICE_CONTROL_STOP, ffSvcStatus); - if not DeleteService(svcHandle) then - ReportLastError; - end; - - finally - CloseServiceHandle(scmHandle); - end; - - Debug(Prefix + 'End'); -end; -{=====================================================================} - -{===Main entry point==================================================} -procedure Execute; -var - DispatchTable : array [0..1] of TServiceTableEntry; - DoInstall : boolean; - DoUninstall : boolean; - Index : integer; -begin - { Any parameters? } - if ParamCount > 0 then begin - { Yes. Must be running from the command line. } - ffIsService := False; - DoInstall := False; - DoUninstall := False; - { Evaluate the command line parameters. } - for Index := 1 to ParamCount do - if (ParamStr(Index)[1] in ['-', '/']) and - (Length(ParamStr(Index)) = 2) then - { Which parameter? } - case UpCase(ParamStr(Index)[2]) of - ffc_DebugMode : - ffDebugMode := True; - ffc_Install : - if DoUnInstall then - ReportErrorFmt(ffc_ConflictingParm, [ParamStr(Index)]) - else - DoInstall := True; - ffc_Uninstall : - if DoInstall then - ReportErrorFmt(ffc_ConflictingParm, [ParamStr(Index)]) - else - DoUnInstall := True; - else - ReportErrorFmt(ffc_InvalidParm, [ParamStr(Index)]) - end { case } - else - ReportErrorFmt(ffc_InvalidParm, [ParamStr(Index)]); - - { Install or uninstall? } - if DoInstall then - Install - else if DoUnInstall then - UnInstall; - - end - else - { No. Must be running as service. Register ServiceMain. } - begin - ffIsService := True; - FillChar(DispatchTable[0], SizeOf(DispatchTable), 0); {!!.02} - DispatchTable[0].lpServiceName := PChar(ffc_ServiceName); - DispatchTable[0].lpServiceProc := @ServiceMain; -// DispatchTable[1].lpServiceName := nil; {Deleted !!.02} -// DispatchTable[1].lpServiceProc := nil; {Deleted !!.02} - if not StartServiceCtrlDispatcher(DispatchTable[0]) then - ReportLastError; - end -end; -{=====================================================================} - -{===SCM Entry points==================================================} -procedure ControlHandler(CtrlCode : DWord); -const - Prefix = 'ControlHandler.'; -var {!!.02} - WaitHint : DWORD; {!!.02} -begin - WaitHint := 0; {!!.02} - case CtrlCode of - SERVICE_CONTROL_STOP : - begin - Debug(Prefix + 'SERVICE_CONTROL_STOP'); - ffSvcStatus.dwCurrentState := SERVICE_STOP_PENDING; - WaitHint := 11000; {!!.06} - end; - SERVICE_CONTROL_SHUTDOWN : - begin - Debug(Prefix + 'SERVICE_CONTROL_SHUTDOWN'); - ffSvcStatus.dwCurrentState := SERVICE_STOP_PENDING; - WaitHint := 11000; {!!.06} - end; - SERVICE_CONTROL_PAUSE : - begin - Debug(Prefix + 'SERVICE_CONTROL_PAUSE'); - ffSvcStatus.dwCurrentState := SERVICE_PAUSE_PENDING; - WaitHint := 11000; {!!.06} - end; - SERVICE_CONTROL_CONTINUE : - begin - Debug(Prefix + 'SERVICE_CONTROL_CONTINUE'); - ffSvcStatus.dwCurrentState := SERVICE_CONTINUE_PENDING; - WaitHint := 1000; {!!.02} - end; - SERVICE_CONTROL_INTERROGATE : - Debug(Prefix + 'SERVICE_CONTROL_INTERROGATE'); - { No state change needed. } - end; { case } - - { Send our status to the SCM. } - Debug(Prefix + 'NotifySCM'); - NotifySCM(WaitHint); - - { Signal ServiceMain that a request has arrived. } - Debug(Prefix + 'SignalEvent'); - ffSvcEvent.SignalEvent; - - Debug(Prefix + 'End'); - -end; -{--------} -procedure ServiceMain(NumArgs : DWORD; Args : PArgArray); -const - Prefix = 'ServiceMain.'; -var - AnArg : PChar; - Finished : boolean; - Index : DWORD; -begin - - ffEngineMgr := nil; - - ffDebugMode := False; - - for Index := 1 to NumArgs do begin - AnArg := Args^; - if (StrLen(AnArg) = 2) and - (AnArg[0] in ['/', '-']) and - (Upcase(AnArg[1]) = ffc_DebugMode) then begin - ffDebugMode := True; - break; - end; - inc(Args); - end; - - { Create the event that tells us the handler has received a control - code. } - ffSvcEvent := TffEvent.Create; - - { Initialize service status. } - Debug(Prefix + 'InitServiceStatus'); - with ffSvcStatus do begin - dwServiceType := SERVICE_WIN32_OWN_PROCESS; - dwCurrentState := SERVICE_START_PENDING; - dwControlsAccepted := SERVICE_ACCEPT_STOP or - SERVICE_ACCEPT_PAUSE_CONTINUE or - SERVICE_ACCEPT_SHUTDOWN; - dwWin32ExitCode := NO_ERROR; - dwServiceSpecificExitCode := 0; - dwCheckPoint := 0; - dwWaitHint := 0; - end; - - { Are we running as a service? } - if ffIsService then begin - Debug(Prefix + 'RegisterServiceCtrlHandler'); - { Yes. Register our handler for service control requests. } - ffSvcStatusHandle := RegisterServiceCtrlHandler(PChar(ffc_ServiceName), - @ControlHandler); - { Did it work? } - if ffSvcStatusHandle = 0 then begin {!!.02} - { No. Report error. } - ReportLastError; - Exit; {!!.02} - end {!!.02} - else - { Yes. We must notify the SCM of our status right away. } - NotifySCM(2000); - end; - - { Start the engine manager. } - try - IsMultiThread := True; - Debug(Prefix + 'InitEngineMgr'); - ffEngineMgr := TffEngineManager.Create(nil); - ffEngineMgr.EventLogEnabled := ffDebugMode; - InitEngineMgr(ffEngineMgr); - Debug(Prefix + 'StartEngineMgr'); - ffEngineMgr.StartUp; - except - on E:Exception do begin - ReportErrorFmt(ffc_EngMgrStartup, [E.Message]); - Exit; - end; - end; - - ffSvcStatus.dwCurrentState := SERVICE_RUNNING; - - { Are we running as a service? } - if ffIsService then - { Yes. Notify SCM we are running. } - NotifySCM(0); - - { Go into a loop. We will stay in the loop until we are told to shut - down. } - Finished := False; - repeat - - Debug(Prefix + 'WaitFor'); - ffSvcEvent.WaitFor(0); - - { What we do depends upon the status set by our control handler. } - case ffSvcStatus.dwCurrentState of - SERVICE_CONTINUE_PENDING : - begin - Debug(Prefix + 'Receive SERVICE_CONTINUE_PENDING'); - try - ffEngineMgr.StartUp; - ffSvcStatus.dwCurrentState := SERVICE_RUNNING; - except - on E:Exception do begin - ReportErrorFmt(ffc_EngMgrStartup, [E.message]); - ffSvcStatus.dwCurrentState := SERVICE_STOPPED; - Finished := True; - end; - end; - end; - SERVICE_PAUSE_PENDING : - begin - Debug(Prefix + 'Receive SERVICE_PAUSE_PENDING'); - try - ffEngineMgr.ShutDown; - ffSvcStatus.dwCurrentState := SERVICE_PAUSED; - except - on E:Exception do begin - ReportErrorFmt(ffc_EngMgrShutdown, [E.message]); - ffSvcStatus.dwCurrentState := SERVICE_STOPPED; - Finished := True; - end; - end; - end; - SERVICE_STOP_PENDING : - begin - Debug(Prefix + 'Receive SERVICE_STOP_PENDING'); - try - ffEngineMgr.ShutDown; - except - on E:Exception do - ReportErrorFmt(ffc_EngMgrShutdown, [E.message]); - end; - Finished := True; - ffSvcStatus.dwCurrentState := SERVICE_STOPPED; - end; - end; { case } - - { Notify the SCM of our status. } - if ffIsService then begin - Debug(Prefix + 'NotifySCM'); - NotifySCM(0); - end; - - until Finished; - - Debug(Prefix + 'FreeVars'); - ffSvcEvent.Free; - try - ffEngineMgr.Free; - except - end; - - { Tell the SCM that we have stopped. } - Debug(Prefix + 'NotifySCM SERVICE_STOPPED'); - ffSvcStatus.dwCurrentState := SERVICE_STOPPED; -// NotifySCM(0); {Deleted !!.02} - - Debug(Prefix + 'End'); - -end; -{=====================================================================} - -{Begin !!.13} -{===TffServiceRecoveryEngine==========================================} -type - TffServiceRecoveryEngine = class(TffRecoveryEngine) - protected - function reReportJournalState( JournalState : TJournalState; - Alias : String; - Path : String; - Filename : String; - ExceptionString : String ): Boolean; override; - end; -{--------} -function TffServiceRecoveryEngine.reReportJournalState( - JournalState: TJournalState; - Alias, Path, Filename, ExceptionString: string): Boolean; -begin - WriteEvent( ffc_JournalStateEventTypes[JournalState], - ffc_GenError, - ffc_JournalCompletenessMsgs[JournalState] + ' ' + - ffc_JournalActionMsgs[JournalState] + - Format( ' (Alias: %s; Path: %s; Filename: %s; Exception: %s )', - [ Alias, Path, Filename, ExceptionString ] ) ); - Result := True; -end; -{=====================================================================} - -initialization - FFRecoveryClass := TffServiceRecoveryEngine; -{End !!.13} -end. diff --git a/components/flashfiler/sourcelaz/service/ffsrvice.dpr b/components/flashfiler/sourcelaz/service/ffsrvice.dpr deleted file mode 100644 index 222ab6268..000000000 --- a/components/flashfiler/sourcelaz/service/ffsrvice.dpr +++ /dev/null @@ -1,45 +0,0 @@ -{*********************************************************} -{* FlashFiler Service 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 ***** *) - -program ffSrvice; -uses - {$IFDEF USETeDEBUG} - TeDebug, - {$ENDIF} - SysUtils, - FFLLSvc in 'FFLLSvc.pas', - uffegmgr in '..\server\uFFEgMgr.pas' {FFEngineManager: TffBaseEngineManager}, - uSvcType in 'uSvcType.pas', - uFFSRJrn in '..\uffsrjrn.pas' {JournalForm}; - -{$R *.RES} - -begin - Execute; -end. diff --git a/components/flashfiler/sourcelaz/service/ffsrvice.rc b/components/flashfiler/sourcelaz/service/ffsrvice.rc deleted file mode 100644 index ae5c0508f..000000000 --- a/components/flashfiler/sourcelaz/service/ffsrvice.rc +++ /dev/null @@ -1,60 +0,0 @@ -/********************************************************* - * 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 Service\000" - VALUE "FileVersion", "2.1.3.0\000" - VALUE "InternalName", "FFSRVICE\000" - VALUE "LegalCopyright", "Copyright (c) TurboPower Software Co. 1996-2002\000\000" - VALUE "OriginalFilename", "FFSRVICE.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/service/ffsrvice.res b/components/flashfiler/sourcelaz/service/ffsrvice.res deleted file mode 100644 index 031055f5c..000000000 Binary files a/components/flashfiler/sourcelaz/service/ffsrvice.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/service/ffsvcmsg.mc b/components/flashfiler/sourcelaz/service/ffsvcmsg.mc deleted file mode 100644 index 95dfd684a..000000000 --- a/components/flashfiler/sourcelaz/service/ffsvcmsg.mc +++ /dev/null @@ -1,5 +0,0 @@ -MessageID=1000 -Language=English -FlashFiler: %1 -. - diff --git a/components/flashfiler/sourcelaz/service/ffsvcmsg.rc b/components/flashfiler/sourcelaz/service/ffsvcmsg.rc deleted file mode 100644 index 0885a897e..000000000 --- a/components/flashfiler/sourcelaz/service/ffsvcmsg.rc +++ /dev/null @@ -1,2 +0,0 @@ -LANGUAGE 0x9,0x1 -1 11 MSG00001.bin diff --git a/components/flashfiler/sourcelaz/service/ffsvcmsg.res b/components/flashfiler/sourcelaz/service/ffsvcmsg.res deleted file mode 100644 index 2f94efb9a..000000000 Binary files a/components/flashfiler/sourcelaz/service/ffsvcmsg.res and /dev/null differ diff --git a/components/flashfiler/sourcelaz/service/msg00001.bin b/components/flashfiler/sourcelaz/service/msg00001.bin deleted file mode 100644 index ca0bc8509..000000000 Binary files a/components/flashfiler/sourcelaz/service/msg00001.bin and /dev/null differ diff --git a/components/flashfiler/sourcelaz/service/usvctype.pas b/components/flashfiler/sourcelaz/service/usvctype.pas deleted file mode 100644 index 5ff2498b6..000000000 --- a/components/flashfiler/sourcelaz/service/usvctype.pas +++ /dev/null @@ -1,47 +0,0 @@ -(* ***** 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 uSvcType; - -interface - -const - EVENTLOG_SUCCESS = $0000; - EVENTLOG_ERROR_TYPE = $0001; - EVENTLOG_WARNING_TYPE = $0002; - EVENTLOG_INFORMATION_TYPE = $0004; - - SERVICE_WIN32_OWN_PROCESS = $00000010; - - SERVICE_INTERACTIVE_PROCESS = $00000100; - - SERVICE_AUTO_START = $00000002; - - SERVICE_ERROR_NORMAL = $00000001; - -implementation - -end. - diff --git a/components/flashfiler/sourcelaz/uffsrjrn.dfm b/components/flashfiler/sourcelaz/uffsrjrn.dfm deleted file mode 100644 index e72a4a265..000000000 --- a/components/flashfiler/sourcelaz/uffsrjrn.dfm +++ /dev/null @@ -1,128 +0,0 @@ -object JournalForm: TJournalForm - Left = 274 - Top = 135 - BorderStyle = bsDialog - Caption = 'FlashFiler Journal Recovery' - ClientHeight = 193 - ClientWidth = 536 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'MS Sans Serif' - Font.Style = [] - OldCreateOrder = True - PixelsPerInch = 96 - TextHeight = 13 - object Panel1: TPanel - Left = 0 - Top = 0 - Width = 427 - Height = 193 - Align = alLeft - TabOrder = 0 - object Bevel1: TBevel - Left = 1 - Top = 1 - Width = 425 - Height = 191 - Align = alClient - end - object CompletenessLabel: TLabel - Left = 15 - Top = 16 - Width = 257 - Height = 24 - Alignment = taCenter - Caption = 'Incomplete Journal File Found' - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -19 - Font.Name = 'MS Sans Serif' - Font.Style = [] - ParentFont = False - end - object ActionLabel: TLabel - Left = 16 - Top = 152 - Width = 370 - Height = 24 - Alignment = taCenter - Caption = 'Recovery is impossible. File will be deleted.' - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -19 - Font.Name = 'MS Sans Serif' - Font.Style = [] - ParentFont = False - end - object ExceptionLabel: TLabel - Left = 16 - Top = 128 - Width = 73 - Height = 13 - Caption = 'ExceptionLabel' - end - object FilenameLabel: TLabel - Left = 16 - Top = 104 - Width = 68 - Height = 13 - Caption = 'FilenameLabel' - end - object PathLabel: TLabel - Left = 16 - Top = 80 - Width = 48 - Height = 13 - Caption = 'PathLabel' - end - object AliasLabel: TLabel - Left = 16 - Top = 56 - Width = 48 - Height = 13 - Caption = 'AliasLabel' - end - end - object Panel2: TPanel - Left = 429 - Top = 0 - Width = 107 - Height = 193 - Align = alRight - TabOrder = 1 - object OKBtn: TBitBtn - Left = 16 - Top = 16 - Width = 75 - Height = 25 - Caption = 'OK' - Default = True - ModalResult = 1 - TabOrder = 0 - NumGlyphs = 2 - end - object RollbackBtn: TBitBtn - Left = 16 - Top = 56 - Width = 75 - Height = 25 - Cancel = True - Caption = '&Rollback' - ModalResult = 2 - TabOrder = 1 - NumGlyphs = 2 - end - object PrintBtn: TBitBtn - Left = 16 - Top = 160 - Width = 75 - Height = 25 - Caption = '&Print' - TabOrder = 2 - OnClick = PrintBtnClick - NumGlyphs = 2 - end - end -end diff --git a/components/flashfiler/sourcelaz/uffsrjrn.pas b/components/flashfiler/sourcelaz/uffsrjrn.pas deleted file mode 100644 index a4e96f919..000000000 --- a/components/flashfiler/sourcelaz/uffsrjrn.pas +++ /dev/null @@ -1,176 +0,0 @@ -{*********************************************************} -{* Journal recovery 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 ***** *) - - -unit uFFSRJrn; - -{$I FFDEFINE.INC} - -interface - -uses - Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, Buttons, ExtCtrls; - -type - TJournalState = ( jsComplete, jsIncomplete, jsTrash, jsSkipping ); - TJournalForm = class(TForm) - Panel1: TPanel; - Panel2: TPanel; - Bevel1: TBevel; - OKBtn: TBitBtn; - RollbackBtn: TBitBtn; - PrintBtn: TBitBtn; - CompletenessLabel: TLabel; - ActionLabel: TLabel; - ExceptionLabel: TLabel; - FilenameLabel: TLabel; - PathLabel: TLabel; - AliasLabel: TLabel; - procedure PrintBtnClick(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - procedure Setup( JournalState : TJournalState; - Alias : String; - Path : String; - Filename : String; - ExceptionString : String ); - end; - -{Begin !!.13} -const - ffc_JournalCompletenessMsgs : array[TJournalState] of string = ( - 'Complete journal file found!', - 'Incomplete journal file found!', - 'Error processing journal file!', - 'Error processing file! Skipped the file.' ); - - ffc_JournalActionMsgs : array[TJournalState] of string = ( - 'Recovery is possible!', - 'Recovery is impossible!', - 'Cannot recover!', - 'Cannot recover!' ); -{End !!.13} - - -var - JournalForm: TJournalForm; - - function ShowJournalForm( JournalState : TJournalState; - Alias : String; - Path : String; - Filename : String; - ExceptionString : String ) : Integer; - -implementation - -{$R *.DFM} - -procedure TJournalForm.Setup( JournalState : TJournalState; - Alias : String; - Path : String; - Filename : String; - ExceptionString : String ); -begin - ExceptionLabel.Visible := False; -{Begin !!.13} - CompletenessLabel.Caption := ffc_JournalCompletenessMsgs[JournalState]; - ActionLabel.Caption := ffc_JournalActionMsgs[JournalState]; -{End !!.13} - case JournalState of - jsComplete : - begin - OKBtn.Caption := '&Commit'; - RollbackBtn.Visible := True; - CompletenessLabel.Font.Color := clGreen; - ActionLabel.Font.Color := clGreen; - end; - jsIncomplete : - begin - OKBtn.Caption := '&OK'; - RollbackBtn.Visible := False; - CompletenessLabel.Font.Color := clRed; - ActionLabel.Font.Color := clRed; - end; - jsTrash : - begin - OKBtn.Caption := '&OK'; - RollbackBtn.Visible := False; - CompletenessLabel.Font.Color := clRed; - ActionLabel.Font.Color := clRed; - ExceptionLabel.Visible := True; - ExceptionLabel.Caption := ExceptionString; - end; - jsSkipping : - begin - OKBtn.Caption := '&OK'; - RollbackBtn.Visible := False; - CompletenessLabel.Font.Color := clRed; - ActionLabel.Font.Color := clRed; - ExceptionLabel.Visible := True; - ExceptionLabel.Caption := ExceptionString; - end; - end; - ActionLabel.Left := 0; - ActionLabel.Width := Bevel1.Width; - CompletenessLabel.Left := 0; - CompletenessLabel.Width := Bevel1.Width; - AliasLabel.Caption := Alias; - PathLabel.Caption := Path; - FilenameLabel.Caption := Filename; -end; - -function ShowJournalForm( JournalState : TJournalState; - Alias : String; - Path : String; - Filename : String; - ExceptionString : String ) : Integer; -begin - JournalForm := TJournalForm.Create( Application ); - try - JournalForm.Setup( JournalState, Alias, Path, Filename, ExceptionString ); - JournalForm.ShowModal; - Result := JournalForm.ModalResult; - finally - JournalForm.Free; - end; -end; - -procedure TJournalForm.PrintBtnClick(Sender: TObject); -begin - {$ifdef fpc} - MessageDlg('Print is for Lazarus disabled.', mtInformation, [mbOK, mbCancel],0); - {$else} - Print; //SONER CAlls TForm.Print: - {$endif} -end; - -end.