home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Decision Cube / MXSTORE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  142.9 KB  |  5,120 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {       Borland Delphi Visual Component Library         }
  4. {                                                       }
  5. {       Copyright (c) 1997,99 Inprise Corporation       }
  6. {                                                       }
  7. {*******************************************************}
  8.  
  9. unit mxstore;
  10.  
  11. interface
  12.  
  13. uses
  14.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  15.   Bde, DB, DBCommon, DBTables, mxArrays, Menus,
  16.   mxpbar, mxcommon, mxTables;
  17.  
  18. const
  19.   SubTotal  = -1;
  20.   NonSparseAgg = -4;
  21.   SparseUnknown = -3;
  22.   SparseAgg = -2;
  23.   SparseSum = -1;
  24.   MaxBinDimensions = 16;
  25.   LargeValueCount = 50;
  26.   
  27. type
  28.   TMultiDimDataLink = class;
  29.   TDataCache = class;
  30.   TCustomDataStore = class;
  31.   TCubeDims = class;
  32.   TCubeDim = class;
  33.  
  34.   TErrorAction = (eaFail, eaContinue);
  35.  
  36.   TCapacityErrorEvent = procedure(var EAction: TErrorAction) of object;
  37.   TCubeNotifyEvent  = procedure(DataCube: TCustomDataStore) of object;
  38.   TCubeRefreshEvent = procedure(DataCube: TCustomDataStore; DimMap: TCubeDims) of object;
  39.  
  40.   { Designtime state }
  41.   TCubeDataState = (dsNoData, dsMetaData, dsDimensionData, dsAllData);
  42.  
  43.   TBuildType = (btHardRebuild, btSoftRebuild, btNoRebuild);
  44.  
  45.   { Public cube state }
  46.   TCubeState = (dcInactive, dcBrowseMetaData, dcBrowseMemberData, dcBrowseAllData);
  47.  
  48.   { These flags govern some of the behaviour of dimensions and summaries }
  49.   TDimFlagSet = set of TDimFlags;
  50.  
  51.   TCubeDimTransformEvent = procedure(var Value: Variant; Data: TCubeDim) of object;
  52.  
  53.   TCubeDim = class(TDimensionItem)
  54.   private
  55.     FBinType: TBinType;
  56.     FTransform: TCubeDimTransformEvent;
  57.     FStartDate: TDate;
  58.     FBinFormat: string;
  59.     FStartValue: string;
  60.     FDirty: Boolean;
  61.     FBinData: TBinData;
  62.     FValues: Integer;
  63.     bWasActive:    Boolean;
  64.     procedure SetBin(Value: TBinType);
  65.     function GetBin: TBinType;
  66.     procedure SetDate(Value: TDate);
  67.     procedure SetStart(Value: string);
  68.     procedure ReadDateBin(Reader: TReader);
  69.     procedure ReadStartDate(Reader: TReader);
  70.     procedure ReadStartValue(Reader: TReader);
  71.     procedure WriteStartValue(Writer: TWriter);
  72.     procedure ReadActive(Reader: TReader);
  73.     procedure WriteActive(Writer: TWriter);
  74.   protected
  75.     procedure YearTransform(var Value: Variant; CubeDim: TCubeDim);
  76.     procedure QuarterTransform(var Value: Variant; CubeDim: TCubeDim);
  77.     procedure MonthTransform(var Value: Variant; CubeDim: TCubeDim);
  78.     procedure DataSetTransform(var Value: Variant; CubeDim: TCubeDim);
  79.     function AssignBinTypeTransform(Bins: TBinType): TCubeDimTransformEvent;
  80.     function AssignBinTypeFormat(Bins: TBinType): string;
  81.     procedure NotifyCollection(aType: TCDNotifyType); override;
  82.     procedure InitializeRange; override;
  83.     procedure DoTransform(var Value: Variant); virtual;
  84.     property Dirty: Boolean read FDirty write FDirty;
  85.     function GetLoaded:    Boolean;
  86.     procedure SetLoaded(Value: Boolean);
  87.     property wasActive: Boolean read bWasActive write bWasActive;
  88.   public
  89.     constructor Create(Collection: TCollection); override;
  90.     destructor Destroy; override;
  91.     procedure Assign(Value: TPersistent); override;
  92.     procedure DefineProperties(Filer: TFiler); override;
  93.     function GetBinValues(Value: Variant): Variant;
  94.     function IsBinData: Boolean;
  95.     property BinFormat: string read FBinformat write FBinformat;
  96.     property StartDate: TDate read FStartDate write SetDate;
  97.     property Loaded: Boolean read GetLoaded write SetLoaded;
  98.     property StartValue: String read FStartValue write SetStart;
  99.     property BinData: TBinData read FBinData;
  100.     property OnTransform: TCubeDimTransformEvent read FTransform write FTransform;
  101.   published
  102.     property BinType: TBinType read GetBin write SetBin;
  103.     property ValueCount: Integer read FValues write FValues;
  104.   end;
  105.  
  106.   TCubeDimClass = class of TCubeDim;
  107.  
  108.   TCubeDims = class(TDimensionItems)
  109.   private
  110.     function GetCubeDim(Index: Integer): TCubeDim;
  111.     procedure SetCubeDim(Index: Integer; Value: TCubeDim);
  112.   protected
  113.     function Add: TCubeDim;
  114.     function GetDirtyFlag: Boolean;
  115.     function GetOwner: TPersistent; override;
  116.   public
  117.     constructor Create(FOwner: TPersistent; ItemClass: TCubeDimClass);
  118.     procedure Assign(Source: TPersistent);override;
  119.     property IsDirty: Boolean read GetDirtyFlag;
  120.     property Items[Index: Integer]: TCubeDim read GetCubeDim write SetCubeDim; default;
  121.   end;
  122.  
  123.   { This is the multi-dimensional data store component }
  124.  
  125.   TCustomDataStore = class(TComponent)
  126.   private
  127.     FCache: TDataCache;          { The data cache object }
  128.     FDataLink: TMultiDimDataLink;    { Links this component to a dataset }
  129.     FState: TCubeState;
  130.     FDesignState: TCubeDataState;
  131.     FDimensionMap: TCubeDims;
  132.     FDataSet: TDataSet;
  133.     FShowProgress: Boolean;
  134.     FBinData: Boolean;
  135.     FDirty: Boolean;
  136.     FMaxDims: Integer;
  137.     FMaxSums: Integer;
  138.     FMaxCells:Integer;
  139.     FInternalDataSource: TDataSource;
  140.     FOnCapacityError: TCapacityErrorEvent;
  141.     FBeforeOpen: TCubeNotifyEvent;
  142.     FAfterOpen: TCubeNotifyEvent;
  143.     FBeforeClose: TCubeNotifyEvent;
  144.     FAfterClose: TCubeNotifyEvent;
  145.     FOnRefresh: TCubeRefreshEvent;
  146.     function GetDataSource: TDataSource;
  147.     procedure SetDataSource(Value: TDataSource);
  148.     procedure SetActive(Value: Boolean);
  149.     function GetDimensionCount: Integer;
  150.     function GetSummaryCount: Integer;
  151.     function GetDimensionMapCount: Integer;
  152.     function GetActive: Boolean;
  153.     procedure SetState(Value: TCubeState);
  154.     procedure SetDesignState(Value: TCubeDataState);
  155.     function GetCubeState: Boolean;
  156.     procedure OpenCache;
  157.     procedure CloseCache;
  158.     procedure SetCapacity(Value: Integer);
  159.     function GetCapacity: Integer;
  160.     procedure SetMaxDims(Value: Integer);
  161.     procedure SetMaxSums(Value: Integer);
  162.     procedure SetBinData(Value: Boolean);
  163.     function CheckDimensionMap(DimMap: TCubeDims; var BuildType: TBuildType): Boolean;
  164.     procedure SetLoadMap(DimMap, OldMap: TCubeDims);
  165.   protected
  166.     procedure ActiveChanged; virtual;
  167.     procedure StateChanged; virtual;
  168.     procedure DoBeforeOpen; virtual;
  169.     procedure DoAfterOpen; virtual;
  170.     procedure DoBeforeClose; virtual;
  171.     procedure DoAfterClose; virtual;
  172.     procedure DoOnRefresh(DimMap: TCubeDims); virtual;
  173.     function GetDataSet: TDataSet;
  174.     function GetDomain(DimensionIDs: TIntArray; ATotals: Boolean; Domain: TTwoDimArray): Integer;
  175.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  176.     procedure SetDataSet(ADataSet: TDataSet);
  177.     function GetCurrentSummary: Integer;
  178.     procedure SetCurrentSummary(Value: Integer);
  179.     procedure LayoutChanged; virtual;
  180.     function BinMapHasBinData: Boolean;
  181.     function CanDimBeClosed(iMapIndex: Integer): Boolean; virtual;
  182.     function CanSumBeClosed(iMapIndex: Integer): Boolean; virtual;
  183.     property DataCache: TDataCache read FCache;
  184.     property DataLink: TMultiDimDataLink read FDataLink;
  185.     property InternalDataSource: TDataSource read FInTernalDataSource;
  186.     property DesignState: TCubeDataState read FDesignState write SetDesignState;
  187.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  188.     property Active: Boolean read GetActive write SetActive default False;
  189.     property State: TCubeState read FState; { Returns the cube state }
  190.   public
  191.     constructor Create(AOwner: TComponent); override;
  192.     destructor Destroy; override;
  193.     procedure CalcSubTotals;
  194.     procedure Refresh(DimMap: TCubeDims; bForce: Boolean); 
  195.     function GetMemoryUsage: Integer;                                        { Gets the total memory consumed by the DecisionCube}
  196.     function GetDimensionName(Dimension: Integer): String; virtual;            { Returns the name of the dimension as a string }
  197.     function GetDimensionMemberCount(Dimension: Integer): Integer; virtual;    { Returns the number of members of a dimension }
  198.     function GetMemberAsString(Dimension, Index: Integer): String; virtual;  { Returns the value of the member at index as a string }
  199.     function GetMemberAsVariant(Dimension, Index: Integer): Variant;        { Returns the value of the member at index as a variant }
  200.     function GetSummaryName(ISum: Integer): String; virtual;            { Returns the name of the summary }
  201.     function GetSummaryAsString(Coord: TSmallIntArray): String; virtual;    { Gets the summary value as a string }
  202.     function GetSummaryAsVariant(Coord: TSmallIntArray): Variant; virtual;    { Gets the summary value as a variant }
  203.     property DimensionMapCount: Integer read GetDimensionMapCount;        { Gets the number of dimensions in TCubeDims }
  204.     property DimensionCount: Integer read GetDimensionCount;              { Gets the number of dimensions }
  205.     property SummaryCount: Integer read GetSummaryCount;                  { Get the number of summaries }
  206.     property CurrentSummary: Integer read GetCurrentSummary write SetCurrentSummary;  { Returns the active summary }
  207.     property Capacity: Integer read GetCapacity write SetCapacity; { Sets the Internal capacity limit for the cache }
  208.     property BinData: Boolean read FBinData write SetBinData;                     { Reports if the data set is being binned or not }
  209.     property DataSet: TDataSet read GetDataSet write SetDataSet;                      { Reads and sets the data set }
  210.     property DimensionMap: TCubeDims read FDimensionMap write FDimensionMap;     { Reads or sets TCubeDims }
  211.     property ShowProgressDialog: Boolean read FShowProgress write FShowProgress;
  212.     property MaxDimensions: Integer read FMaxDims write SetMaxDims;
  213.     property MaxSummaries: Integer read FMaxSums write SetMaxSums;
  214.     property MaxCells: Integer read FMaxCells write FMaxCells;
  215.     property OnLowCapacity: TCapacityErrorEvent read FOnCapacityError write FOnCapacityError;
  216.     property BeforeOpen: TCubeNotifyEvent read FBeforeOpen write FBeforeOpen;
  217.     property AfterOpen: TCubeNotifyEvent read FAfterOpen write FAfterOpen;
  218.     property BeforeClose: TCubeNotifyEvent read FBeforeClose write FBeforeClose;
  219.     property AfterClose: TCubeNotifyEvent read FAfterClose write FAfterClose;
  220.     property OnRefresh: TCubeRefreshEvent read FOnRefresh write FOnRefresh;
  221.   end;
  222.  
  223.   { This object handles the interface to a datasource, be it a table or a query. }
  224.   
  225.   TMultiDimDataLink = class(TDataLink)
  226.   private
  227.     FDataStore: TCustomDataStore;
  228.     FDataSource: TDataSource;
  229.     function EstimateCapacity(RangeCnt: Integer): Integer;
  230.     procedure DoUpdateCache;
  231.   protected
  232.     function AddDimension(DimMap: TCubeDim; Fld: TField): Integer;
  233.     procedure AddSummary(DimMap: TCubeDim; Fld: TField);
  234.     procedure ActiveChanged; override;
  235.     procedure LayoutChanged; override;
  236.     procedure UpdateCache(Sender: TObject);
  237.     procedure UpdateDimensions(DimAllList: TList);
  238.     procedure FetchValues(DimAllList: TList);
  239.     procedure FetchAndBinValues(DimAllList: TList);
  240.     procedure CreateSummaryIndex(DimAllList: TList);
  241.     procedure UpdateFormatStrings;
  242.   public
  243.     constructor Create(AStore: TCustomDataStore);
  244.     destructor Destroy; override;
  245.   end;
  246.  
  247.   { The basic field definition, dependent on DB implementation. }
  248.  
  249.   TFormatType = (fxNone, fxFloat, fxCurrency, fxDateTime, fxTime, fxDate, fxString, fxInteger, fxBoolean);
  250.  
  251.   TFieldDefinition = class
  252.   private
  253.     FFormatString: string;
  254.     FFieldType: TFieldType;
  255.     FWidth: Integer;
  256.     FName: String;
  257.     FFormatType: TFormatType;
  258.     FPrecision: Integer;
  259.     FFieldNo: Integer;
  260.   public
  261.     constructor Create;
  262.     function FormatVariantToStr(Value: Variant): string;
  263.     procedure SetFieldType(FType: TFieldType);
  264.     procedure SetName(Value: String);
  265.     property Width: Integer read FWidth write FWidth;
  266.     property FormatString: string read FFormatString write FFormatString;
  267.     property FieldType: TFieldType read FFieldType write SetFieldType;
  268.     property Precision: Integer read FPrecision write FPrecision;
  269.     property DisplayName:  String read FName write SetName;
  270.     property FieldNo: Integer read FFieldNo write FFieldNo;
  271.   end;
  272.  
  273.   { This is the dimension object that contains unique members for a field }
  274.  
  275.   TDimension = class(TCustomArray)
  276.   private
  277.     FPosition: Integer;     { The position of the field in the data set. Can be different from FieldNo. }
  278.     FRange: Integer;     { This is the group range for a value, Used in summery calculations }
  279.     FFlags: TDimFlagSet; { Flags that determine the attributes for the dimension. }
  280.     FFieldDef: TFieldDefinition;
  281.     FFieldName: string;        { used for matching with the dataset name }
  282.     procedure SetFieldType(Value: TFieldType);
  283.     function GetFieldType: TFieldType;
  284.     procedure SetPosition(Value: Integer);
  285.     procedure SetName(Value: String);
  286.     function GetName: string;
  287.     procedure SetRange(Value: Integer);
  288.   public
  289.     constructor Create(Items: Cardinal; DataType: TFieldType);
  290.     destructor Destroy; override;
  291.     function IsString: Boolean;
  292.     procedure SetFlag(aFlag: TDimFlags);
  293.     function HasFlag(aFlag: TDimFlags): Boolean;
  294.     procedure ClearFlag(aFlag: TDimFlags);
  295.     procedure SetRangeCounting(bRange: Boolean);
  296.     procedure AssignSorted(Dim: TDimension; bUnique: Boolean);
  297.     property Range: Integer read FRange write SetRange;
  298.     property Attributes: TDimFlags write SetFlag;
  299.     property DimensionName: String read GetName write SetName;
  300.     property FieldType: TFieldType read GetFieldType write SetFieldType;
  301.     property Position: Integer read FPosition write SetPosition;
  302.     property FieldDefinition: TFieldDefinition read FFieldDef;
  303.     property FieldName: string read FFieldName write FFieldName;
  304.   end;
  305.  
  306.   TIndexFlag = (idxNormal, idxSparsed, idxFiltered, idxSubTotals, idxDeleted);
  307.   TIndexFlags = set of TIndexFlag;
  308.  
  309.   PIndexInfoRec = ^TIndexInfoRec;
  310.   TIndexInfoRec = Record
  311.     SparseCnt,
  312.     SubTotalCnt,
  313.     AggOffset: Integer;
  314.     Flags: TIndexFlags;
  315.   end;
  316.  
  317.   TIndexInfo = class
  318.   private
  319.     FSparseCnt: Integer;
  320.     FSubTotalCnt: Integer;
  321.     FCount: Integer;
  322.     FExtInfo: Boolean;
  323.     FOffset: TIntArray;
  324.     FAddAggs: Boolean;
  325.     FLock: TRTLCriticalSection;
  326.   public
  327.     constructor Create;
  328.     destructor Destroy; override;
  329.     procedure SetCapacity(Value: Integer);
  330.     function GetCapacity: Integer;
  331.     function Add(pIdxRec: PIndexInfoRec): Integer;
  332.     function IsSparse(Index: Integer): Boolean;
  333.     function IsSparseAgg(Index: Integer): Boolean;
  334.     procedure AddOffset(Index, IdxType: Integer);
  335.     function LockIndex: TIntArray;
  336.     procedure UnlockIndex;
  337.     property Count: Integer read FCount;
  338.     property Capacity: Integer read GetCapacity write SetCapacity;
  339.     property AddAggs: Boolean read FAddAggs write FAddAggs;
  340.   end;
  341.  
  342.   TDerivedAggProc = function(Val1, Val2: Variant): Variant;
  343.   TFieldArgs = array[0..255] of Byte;
  344.  
  345.   TAggDefinition = class
  346.   private
  347.     FSummaryIdx: TFieldArgs;
  348.     FAggProc: TDerivedAggProc;
  349.   public
  350.     property AggProc: TDerivedAggProc read FAggProc write FAggProc;
  351.   end;
  352.  
  353.   TSummary = class;
  354.   TSumMethod = function (SumIndex: TSmallIntArray; Summary: TSummary; var Value: Variant): Boolean of object;
  355.  
  356.   { This is the summary object that contains the summary data and sub-totals }
  357.  
  358.   TSummary = class(TCustomArray)
  359.   private
  360.     FPosition: Integer;       { The position of the field in the data set. Can be different from TField.FieldNo. }
  361.     FCubeDimIndex: Integer;      { The index into the TCubeDim }
  362.     FFlags: TDimFlagSet;   { Flags that determine the attributes for the dimension. }
  363.     FIndexInfo: TIndexInfo;    { Just a copy of the master index info }
  364.     FTotals: TThreadCustomArray;  { Separate array that holds sub-totals }
  365.     FIndexMap: TIndexArray;         { Just a copy of the master map from the data cache }
  366.     FFieldDef: TFieldDefinition;
  367.     FFieldName: string;              { used for matching with the dataset name }
  368.     FAggDef: TAggDefinition;
  369.     FSumMethod: TSumMethod;
  370.     procedure SetFieldType(Value: TFieldType);
  371.     function GetFieldType: TFieldType;
  372.     procedure SetPosition(Value: Integer);
  373.     procedure SetFlag(aFlag: TDimFlags);
  374.     procedure SetName(Value: String);
  375.     function GetName: string;
  376.     function GetDerived: Boolean;
  377.   protected
  378.     function HasFlag(aFlag: TDimFlags): Boolean;
  379.     function SetAggregator(aName: string; DimMap: TCubeDims; dimType: TDimFlags; var dIdx: Integer): Boolean;
  380.   public
  381.     constructor Create(Items: Cardinal; DataType: TFieldType);
  382.     destructor Destroy; override;
  383.     procedure ClearTotals;
  384.     function MemoryUsage: Integer; override;
  385.     function IsSparse(Index: Integer): Boolean;
  386.     procedure UpdateIndexInfo(Index: Integer; Value: Variant);
  387.     function AddIndexInfo(BTotal, bSparse: Boolean; iAggOffset: Integer): Integer;
  388.     function AddSubTotal(Value: Variant): Integer;
  389.     procedure AddSum(var SumIndex: TSmallIntArray; vNew: Variant);
  390.     property Name: String read GetName write SetName;
  391.     property Attributes: TDimFlags write SetFlag;
  392.     property FieldType: TFieldType read GetFieldType write SetFieldType;
  393.     property Position: Integer read FPosition write SetPosition;
  394.     property FieldDefinition: TFieldDefinition read FFieldDef;
  395.     property FieldName: string read FFieldName write FFieldName;
  396.     property SumMethod: TSumMethod read FSumMethod write FSumMethod;
  397.     property CubeDimIndex: Integer read FCubeDimIndex write FCubeDimIndex;
  398.     property AggDefinition: TAggDefinition read FAggDef write FAggDef;
  399.     property IsDerived: Boolean read GetDerived;
  400.   end;
  401.  
  402.   { This class contains the main summary data cache }
  403.  
  404.   ECacheError = class(Exception);
  405.   TAggProc = function (eCnt, Range: Integer; Summary: TSummary; SumIndex: TSmallIntArray; var vNew: Variant): Boolean;
  406.  
  407.   { These flags govern the general build state of the cache. }
  408.   TCacheStateFlags = (csHasIndex, csDirty, csSuccess, csShowProgress, csRefreshing);
  409.   TCacheState = set of TCacheStateFlags;
  410.  
  411.   { These flags govern the building of lookups for pivoting }
  412.   TLookupStateFlags = (lsSparsing, lsCursor, lsShowProgress);
  413.   TLookupState = set of TLookupStateFlags;
  414.  
  415.   { These flags govern how totals will be calculated and stored }
  416.   TCalcTotalsFlags = (ctPreCalc, ctRunning, ctNone);
  417.   TCalcTotals = set of TCalcTotalsFlags;
  418.  
  419.   TDataCache = class
  420.   private
  421.     FSummaryData: TList;           { This is where we cache the summary data }
  422.     FDimensions: TList;           { The list of TDimensions }
  423.     FActiveSummary: Integer;      { The current summary }
  424.     FIndexMap: TIndexArray;  { The index for the cube. }
  425.     FIndexInfo: TIndexInfo;   { Index info, about sparing, etc. }
  426.     FAggProc: TAggProc;
  427.     FErrorCode: Integer;
  428.     FCalcTotals: TCalcTotals;   { How to calculate the totals }
  429.     FLookupState: TLookupState;
  430.     FActive: Boolean;
  431.     FState: TCacheState;   { Cache state flags }
  432.     {$IFDEF PROFILE}
  433.     FTicks: TTicks;
  434.     FProfileLogFile: string;
  435.     {$ENDIF}
  436.     procedure Init;
  437.     function IsBlankSummary: Boolean;
  438.     function GetDimensionCount: Integer;
  439.     function GetDimension(Index: Integer): TDimension;
  440.     procedure SetDimension(Index: Integer; Value: TDimension);
  441.     function GetSummaryCount: Integer;
  442.     function GetSummary(Index: Integer): TSummary;
  443.     procedure SetActiveSummary(Index: Integer);
  444.     procedure GetScope(var OffsetIdx, AggIdx, AggRange: Integer; SumIndex: TSmallIntArray);
  445.     function IsIndexSparse(SumIndex: TSmallIntArray): Boolean;
  446.     function GetSuccess: Boolean;
  447.     procedure SetSuccess(Value: Boolean);
  448.     function GetPreCalcTotals: Boolean;
  449.     procedure SetPreCalcTotals(Value: Boolean);
  450.     function GetSparsing: Boolean;
  451.     procedure SetSparsing(Value: Boolean);
  452.     function GetHasIndex: Boolean;
  453.     procedure SetHasIndex(Value: Boolean);
  454.     function GetAggSummary(SumIndex: TSmallIntArray; Summary: TSummary; var Value: Variant): Boolean;
  455.     function GetBaseSummary(SumIndex: TSmallIntArray; Summary: TSummary; var Value: Variant): Boolean;
  456.   protected
  457.     procedure FreeCache;
  458.   public
  459.     constructor Create;
  460.     destructor Destroy; override;
  461.     function GetMemoryUsage: Integer;
  462.     procedure CalcSubTotals;
  463.     procedure ClearIndexInfo;
  464.     function AddAggIndex(SumIndex: TSmallIntArray; BuilderDims: TList):Integer;
  465.     function AddIndex(SumIndex: TSmallIntArray; bSparse: Boolean):Integer;
  466.     function IsDimension(Position: Integer): Boolean;
  467.     function IsSummary(Position: Integer): Boolean;
  468.     function SummaryFromPosition(Position: Integer): TSummary;
  469.     function SummaryFromFieldName(FldName: string): TSummary;
  470.     function SummaryFromCubeDimIndex(Index: Integer): TSummary;
  471.     function DimensionFromFieldName(FldName: string): TDimension;
  472.     function AppendDimension(Value: TDimension): Integer;
  473.     function AppendSummary(Value: TSummary): Integer;
  474.     function GetDimensionName(DimIndex: Integer): String;
  475.     function GetSummaryName(ISum: Integer): String;
  476.     function GetDimensionMember(DimIndex, MemberIndex: Integer): String;
  477.     function GetDimensionMemberAsVariant(DimIndex, MemberIndex: Integer): Variant;
  478.     function GetDimensionMemberCount(DimIndex : Integer): Integer;
  479.     function GetIndexCount: Integer;
  480.     function IncSummaryIndex(Summary: TSummary; SumIndex, rangeCount: TSmallIntArray; var bGroupBreak: Boolean): Boolean;
  481.     function HasSubTotals(SumIndex: TSmallIntArray): Boolean;
  482.     function HasValidSubTotals(Summary: TSummary ; SumIndex: TSmallIntArray): Boolean;
  483.     function GetSummaryAsString(SumIndex: TSmallIntArray): String;
  484.     function GetSummaryAsVariant(SumIndex: TSmallIntArray): Variant;
  485.     procedure CreateTable(Const Filename: String);
  486.     function GetDomain(DimensionIDs: TIntArray; nDims: Integer; ATotals: Boolean; Domain: TTwoDimArray): Integer;
  487.     property PreCalculateTotals: Boolean read GetPreCalcTotals write SetPreCalcTotals;
  488.     property CurrentSummary: Integer read FActiveSummary write SetActiveSummary;
  489.     property DimensionCount: Integer read GetDimensionCount;
  490.     property SummaryCount: Integer read GetSummaryCount;
  491.     property Summaries[Index: Integer]: TSummary read GetSummary;
  492.     property Dimensions[Index: Integer]: TDimension read GetDimension write SetDimension;
  493.     property Active: Boolean read FActive write FActive;
  494.     property Sparsing: Boolean read GetSparsing write SetSparsing;
  495.     property IndexCount: Integer read GetIndexCount;
  496.     property Success: Boolean read GetSuccess write SetSuccess;
  497.     property ErrorCode: Integer read FErrorCode write FErrorCode;
  498.     property HasIndex: Boolean read GetHasIndex write SetHasIndex;
  499.     {$IFDEF PROFILE}
  500.     property Ticks: TTicks read FTicks;
  501.     property ProfileLogFile: string read FProfileLogFile write FProfileLogFile;
  502.     {$ENDIF}
  503.   end;
  504.  
  505.   TBuilderDim = class(TDimension)
  506.   private
  507.     FGroupBreak: Boolean;
  508.     FActiveIndex: Integer;
  509.     FSummary: TCustomArray;
  510.     FLastVal: Variant;
  511.     FValueList: TStringArray;
  512.     FSummaryDataType: Integer;
  513.   protected
  514.     function GetLastVal: Variant;
  515.     procedure SetLastVal(Value: Variant);
  516.   public
  517.     constructor Create(Items: Cardinal; DataType: TFieldType);
  518.     destructor Destroy; override;
  519.     function GetSumCount: Integer;
  520.     function GetSummary(Value: Variant): Variant;
  521.     procedure InitSummary(DataType: Integer);
  522.     procedure Add(Value: Variant);         { Add the value }
  523.     procedure AddSummary(Value: Variant);  { Add to the running summary }
  524.     function MatchLastVal(Value: Variant): Boolean;
  525.     property GroupBreak: Boolean read FGroupBreak write FGroupBreak;
  526.     property LastVal: Variant read GetLastVal write SetLastVal;
  527.     property SumCount: Integer read GetSumCount;
  528.   end;
  529.  
  530.   function TestMatch(SumIdx: TSmallIntArray): Boolean;
  531.  
  532. implementation
  533.  
  534. uses
  535.   dbConsts, BDEConst, mxconsts;
  536.  
  537.   { Helper functions for this Unit }
  538.  
  539. function TestMatch(SumIdx: TSmallIntArray): Boolean;
  540. var
  541.   mIdx: TSmallIntArray;
  542.   i: Integer;
  543. begin
  544.   Result := True;
  545.   mIdx := TSmallIntArray.Create(0,0);
  546.   mIdx[0] := 1;
  547.   mIdx[1] := 1;
  548.   mIdx[2] := 1;
  549.   mIdx[3] := -1;
  550.   mIdx[4] := -1;
  551.   for i := 0 to SumIdx.Count-1 do
  552.   begin
  553.     if (SumIdx[i] <> mIdx[i]) then
  554.     begin
  555.       Result := False;
  556.       break;
  557.     end;
  558.   end;
  559.   mIdx.Free;
  560. end;
  561.  
  562. function GetDisplayFormat(fld: TField): string;
  563. begin
  564.   case fld.DataType of
  565.     ftCurrency,
  566.     ftFloat,
  567.     ftBCD,
  568.     ftInteger : Result := TNumericField(fld).DisplayFormat;
  569.     ftDate,
  570.     ftTime,
  571.     ftDateTime: Result := TDateTimeField(fld).DisplayFormat;
  572.     else
  573.       Result := '';
  574.   end;
  575. end;
  576.  
  577. function GetPrecision(fld: TField): Integer;
  578. begin
  579.   case fld.DataType of
  580.     ftCurrency,
  581.     ftFloat: Result := TFloatField(fld).Precision;
  582.     else
  583.       Result := 0;
  584.   end;
  585. end;
  586.  
  587. function IsDateField(FldType: TFieldType): Boolean;
  588. begin
  589.   case FldType of
  590.     ftUnknown,
  591.     ftDate,
  592.     ftDateTime: Result := True;
  593.     else
  594.       Result := False;
  595.   end;
  596. end;
  597.  
  598. function CalcTotals1(eCnt, Range: Integer; Summary: TSummary; SumIndex: TSmallIntArray; var vNew: Variant): Boolean;
  599. var
  600.   iOffSet, agg: Integer;
  601.   V: Variant;
  602.  
  603.   function MatchIndex(Idx: Integer; SumIndex: TSmallIntArray): Boolean;
  604.   var
  605.     i: Integer;
  606.     IMap: TSmallIntArray;
  607.   begin
  608.     Result := True;
  609.     IMap := Summary.FIndexMap[Idx];
  610.     for i := 0 to IMap.Count-1 do
  611.     begin
  612.       { Return false if the index is a subtotal }
  613.       if (IMap[i] = SubTotal) then
  614.       begin
  615.         Result := False;
  616.         break;
  617.       end;
  618.       { Ignore the columns with the subtotals }
  619.       if (SumIndex[i] = SubTotal) then Continue;
  620.       if (IMap[i] <> SumIndex[i]) then
  621.       begin
  622.         Result := False;
  623.         break;
  624.       end;
  625.     end;
  626.   end;
  627.  
  628.   function VarScan: Variant;
  629.   var
  630.     vTmp: Variant;
  631.     I: Integer;
  632.   begin
  633.     vTmp := 0;
  634.     for I := 0 to eCnt do
  635.     begin
  636.       iOffSet := Summary.FindexInfo.FOffset[I];
  637.       if (iOffSet < 0) then Continue;
  638.       if MatchIndex(I, SumIndex) then vTmp := vTmp + Summary[iOffSet];
  639.     end;
  640.     Result := vTmp;
  641.   end;
  642.  
  643.   function CurrencyScan: Variant;
  644.   var
  645.     cTmp: Currency;
  646.     ptr: Pointer;
  647.     I: Integer;
  648.   begin
  649.     cTmp := 0;
  650.     ptr  := Summary.List;
  651.     for I := 0 to eCnt do
  652.     begin
  653.       iOffSet := Summary.FindexInfo.FOffset[I];
  654.       if (iOffSet < 0) then Continue;
  655.       if MatchIndex(I, SumIndex) then
  656.         cTmp := cTmp + TCurrencyArray(ptr).GetItem(iOffSet);
  657.     end;
  658.     Result := cTmp;
  659.   end;
  660.  
  661.   function IntScan: Variant;
  662.   var
  663.     iTmp: Integer;
  664.     ptr: Pointer;
  665.     I: Integer;
  666.   begin
  667.     iTmp := 0;
  668.     ptr  := Summary.List;
  669.     for I := 0 to eCnt do
  670.     begin
  671.       iOffSet := Summary.FindexInfo.FOffset[I];
  672.       if (iOffSet < 0) then Continue;
  673.       if MatchIndex(I, SumIndex) then
  674.         iTmp := iTmp + TIntArray(ptr).GetItem(iOffSet);
  675.     end;
  676.     Result := iTmp;
  677.   end;
  678.  
  679.   function DoubleScan: Variant;
  680.   var
  681.     dTmp: double;
  682.     ptr: Pointer;
  683.     I: Integer;
  684.   begin
  685.     dTmp := 0;
  686.     ptr  := Summary.List;
  687.     for I := 0 to eCnt do
  688.     begin
  689.       iOffSet := Summary.FindexInfo.FOffset[I];
  690.       if (iOffSet < 0) then Continue;
  691.       if MatchIndex(I, SumIndex) then
  692.         dTmp := dTmp + TDoubleArray(ptr).GetItem(iOffSet);
  693.     end;
  694.     Result := dTmp;
  695.   end;
  696.  
  697. begin
  698.   V := 0;
  699.   agg := Summary.FindexInfo.FOffset[eCnt];
  700.   Assert(eCnt < Summary.FIndexInfo.Count);
  701.   if (agg = SparseAgg) then    { Sparse, just return }
  702.   begin
  703.     Result := False;
  704.     Exit;
  705.   end
  706.   else if (agg >= 0) then
  707.   begin
  708.     V := Summary.FTotals.GetItem(agg);
  709.   end
  710.   else
  711.   begin
  712.     case Summary.DataType of
  713.       varInteger:  V := IntScan;
  714.       varDouble:   V := DoubleScan;
  715.       varCurrency: V := CurrencyScan;
  716.       else
  717.         V := VarScan;
  718.     end;
  719.   end;
  720.   vNew := V;
  721.   Result := (V <> 0);
  722.   if (agg = SparseUnknown) then Summary.UpdateIndexInfo(eCnt, V);
  723. end;
  724.  
  725. function CalcTotals2(eCnt, Range: Integer; Summary: TSummary; SumIndex: TSmallIntArray; var vNew: Variant): Boolean;
  726. var
  727.   iOffSet, sCnt, agg : Integer;
  728.   V: Variant;
  729.  
  730.   function VarScan: Variant;
  731.   var
  732.     vTmp: Variant;
  733.     I: Integer;
  734.   begin
  735.     vTmp := 0;
  736.     for I := sCnt to eCnt-1 do
  737.     begin
  738.       if Summary.FindexInfo.IsSparse(I) then Continue;
  739.       iOffSet := Summary.FindexInfo.FOffset[I];
  740.       if (iOffSet >= 0) then vTmp := vTmp + Summary[iOffSet];
  741.     end;
  742.     Result := vTmp;
  743.   end;
  744.  
  745.   function CurrencyScan: Variant;
  746.   var
  747.     cTmp: Currency;
  748.     I: Integer;
  749.     ptr: Pointer;
  750.   begin
  751.     cTmp := 0;
  752.     ptr := Summary.List;
  753.     for I := sCnt to eCnt-1 do
  754.     begin
  755.       if Summary.FindexInfo.IsSparse(I) then Continue;
  756.       iOffSet := Summary.FindexInfo.FOffset[I];
  757.       if (iOffSet >= 0) then
  758.         cTmp := cTmp + TCurrencyArray(ptr).GetItem(iOffSet);
  759.     end;
  760.     Result := cTmp;
  761.   end;
  762.  
  763.   function IntScan: Variant;
  764.   var
  765.     iTmp: Integer;
  766.     I: Integer;
  767.     ptr: Pointer;    
  768.   begin
  769.     iTmp := 0;
  770.     ptr := Summary.List;
  771.     for I := sCnt to eCnt-1 do
  772.     begin
  773.       if Summary.FindexInfo.IsSparse(I) then Continue;
  774.       iOffSet := Summary.FindexInfo.FOffset[I];
  775.       if (iOffSet >= 0) then
  776.         iTmp := iTmp + TIntArray(ptr).GetItem(iOffSet);
  777.     end;
  778.     Result := iTmp;
  779.   end;
  780.  
  781.   function DoubleScan: Variant;
  782.   var
  783.     dTmp: Double;
  784.     I: Integer;
  785.     ptr: Pointer;
  786.  
  787.   begin
  788.     dTmp := 0;
  789.     ptr := Summary.List;
  790.     for I := sCnt to eCnt-1 do
  791.     begin
  792.       if Summary.FindexInfo.IsSparse(I) then Continue;
  793.       iOffSet := Summary.FindexInfo.FOffset[I];
  794.       if (iOffSet >= 0) then
  795.         dTmp := dTmp + TDoubleArray(ptr).GetItem(iOffSet);
  796.     end;    
  797.     Result := dTmp;
  798.   end;
  799.  
  800. begin
  801.   Assert(eCnt < Summary.FIndexInfo.Count);
  802.   V := 0;
  803.   agg := Summary.FindexInfo.FOffset[eCnt];
  804.   if (agg = SparseAgg) then
  805.   begin
  806.     Result := False;
  807.     Exit;
  808.   end
  809.   else if (agg >= 0) then
  810.   begin
  811.     V := Summary.FTotals.GetItem(agg);
  812.   end
  813.   else
  814.   begin
  815.     sCnt := eCnt - Range;
  816.     case Summary.DataType of
  817.       varInteger:  V := IntScan;
  818.       varDouble:   V := DoubleScan;
  819.       varCurrency: V := CurrencyScan;
  820.       else
  821.         V := VarScan;
  822.     end;
  823.   end;
  824.   vNew := V;
  825.   Result := (V <> 0);
  826.   if (agg = SparseUnknown) then Summary.UpdateIndexInfo(eCnt, V);
  827. end;
  828.  
  829.   { TCustomDataStore }
  830.  
  831. constructor TCustomDataStore.Create(AOwner: TComponent);
  832. begin
  833.   inherited Create(AOwner);
  834.   FDataLink := TMultiDimDataLink.Create(Self);
  835.   FInternalDataSource := TDataSource.Create(Self);
  836.   FCache := TDataCache.Create;
  837.   FDesignState := dsAllData;
  838.   FShowProgress := True;
  839.   FMaxDims := 5;
  840.   FMaxSums := 10;
  841.   FMaxCells := 0;
  842.   FBinData := False;
  843.   FDirty := False;
  844.   FDimensionMap := TCubeDims.Create(self, TCubeDim);
  845.   DataSource := FInternalDataSource; { must be the last thing }
  846. end;
  847.  
  848. destructor TCustomDataStore.Destroy;
  849. begin
  850.   FDataLink.Free;
  851.   FDataLink := nil;
  852.   FInternalDataSource.Free;
  853.   FInternalDataSource := nil;
  854.   FCache.Free;
  855.   FDimensionMap.Free;
  856.   inherited Destroy;
  857. end;
  858.  
  859. procedure TCustomDataStore.SetDesignState(Value: TCubeDataState);
  860. begin
  861.   if (FDesignState <> Value) then
  862.   begin
  863.     FDesignState := Value;
  864.     FDirty := True;
  865.   end;
  866. end;
  867.  
  868. function TCustomDataStore.GetCubeState: Boolean;
  869. begin
  870.   if (csDesigning in ComponentState) then
  871.   begin
  872.     case FDesignState of
  873.        dsNoData: SetState(dcInactive);
  874.        dsMetaData: SetState(dcBrowseMetaData);
  875.        dsDimensionData: SetState(dcBrowseMemberData);
  876.        else
  877.          SetState(dcBrowseAllData);
  878.     end;
  879.   end
  880.   else
  881.     SetState(dcBrowseAllData);
  882.   Result := FState <> dcInactive;
  883. end;
  884.  
  885. procedure TCustomDataStore.SetState(Value: TCubeState);
  886. begin
  887.   if (FState <> Value) then FState := Value;
  888. end;
  889.  
  890. function TCustomDataStore.GetActive: Boolean;
  891. begin
  892.   Result := State <> dcInactive;
  893. end;
  894.  
  895.   { Sets the cache active or inactive. }
  896.  
  897. procedure TCustomDataStore.SetActive(Value: Boolean);
  898. begin
  899.   if (Active <> Value) then
  900.   begin
  901.     if Value then
  902.     begin
  903.       DoBeforeOpen;
  904.       try
  905.         OpenCache;
  906.       except
  907.         SetState(dcInactive);
  908.         CloseCache;
  909.         Assert(FCache.ErrorCode = 0, Format(sFatalCacheError , [FCache.ErrorCode]));
  910.         raise;
  911.       end;
  912.       DoAfterOpen;
  913.     end
  914.     else
  915.     begin
  916.       if not (csDestroying in ComponentState) then DoBeforeClose;
  917.       SetState(dcInactive);
  918.       CloseCache;
  919.       if not (csDestroying in ComponentState) then DoAfterClose;
  920.     end;
  921.     StateChanged;
  922.   end;
  923. end;
  924.  
  925.   { Opens the cache only if there is a live datalink. }
  926.  
  927. procedure TCustomDataStore.OpenCache;
  928. begin
  929.   if not FCache.Active then
  930.   begin
  931.     if (Assigned(FDatalink.Datasource)) and
  932.     (FDataLink.Active = True) and
  933.     (GetCubeState = True) then
  934.     begin
  935.       FCache.Init;
  936.       FDataLink.DoUpdateCache;
  937.       FCache.Active := True;
  938.     end
  939.     else
  940.       SetState(dcInactive);
  941.   end;
  942. end;
  943.  
  944. procedure TCustomDataStore.CloseCache;
  945. begin
  946.   FCache.FreeCache;
  947.   FCache.Active := False
  948. end;
  949.  
  950. function TCustomDataStore.GetDataSource: TDataSource;
  951. begin
  952.   Result := FDataLink.DataSource;
  953. end;
  954.  
  955. procedure TCustomDataStore.SetDataSource(Value: TDataSource);
  956. begin
  957.   { Already attached to the datasource, just exit }
  958.   if Value = FDatalink.Datasource then Exit;
  959.   { New datasource. Try to open/reopen the cache if the datasource.dataset is active }
  960.   FDataLink.DataSource := Value;
  961.   if (Value <> nil) then Value.FreeNotification(Self);
  962.   if (Value <> nil) then SetActive(FDataLink.Active);
  963. end;
  964.  
  965. procedure TCustomDataStore.SetDataSet(ADataSet: TDataSet);
  966. begin
  967.   if (FDataSet <> ADataSet) then
  968.   begin
  969.     if (ADataSet <> nil) then
  970.       ADataSet.FreeNotification(Self);
  971.     FDataSet := ADataSet;
  972.     InternalDataSource.DataSet := FDataSet;
  973.   end;
  974. end;
  975.  
  976. procedure TCustomDataStore.Notification(AComponent: TComponent; Operation: TOperation);
  977. begin
  978.   inherited Notification(AComponent, Operation);
  979.   if (Operation = opRemove) and (AComponent = FDataSet) then
  980.     FDataSet := nil;
  981. end;
  982.  
  983. function TCustomDataStore.GetDataSet: TDataSet;
  984. begin
  985.   Result := FDataSet;
  986. end;
  987.  
  988. procedure TCustomDataStore.LayoutChanged;
  989. begin
  990.   DataLink.LayoutChanged;
  991. end;
  992.  
  993. procedure TCustomDataStore.ActiveChanged;
  994. begin
  995. end;
  996.  
  997. procedure TCustomDataStore.StateChanged;
  998. begin
  999. end;
  1000.  
  1001. function TCustomDataStore.GetDimensionName(Dimension: Integer): String;
  1002. var
  1003.   i, iActive: Integer;
  1004. begin
  1005.   Result := '';
  1006.   if assigned (DimensionMap) then
  1007.   begin
  1008.     iActive := 0;
  1009.     for i := 0 to DimensionMap.count-1 do
  1010.     begin
  1011.       if DimensionMap[i].active and (DimensionMap[i].DimensionType = dimDimension) then
  1012.       begin
  1013.         if (Dimension = iActive) then Result := DimensionMap[i].Name;
  1014.         iActive := iActive + 1;
  1015.       end;
  1016.     end;
  1017.   end;
  1018.   if (Result = '') then
  1019.     Result := FCache.GetDimensionName(Dimension);
  1020. end;
  1021.  
  1022. function TCustomDataStore.GetMemberAsString(Dimension, Index: Integer): String;
  1023. begin
  1024.   Result := FCache.GetDimensionMember(Dimension, Index);
  1025. end;
  1026.  
  1027. function TCustomDataStore.GetMemberAsVariant(Dimension, Index: Integer): Variant;
  1028. begin
  1029.   Result := FCache.GetDimensionMemberAsVariant(Dimension, Index);
  1030. end;
  1031.  
  1032. function TCustomDataStore.GetDomain(DimensionIDs: TIntArray; ATotals: Boolean; Domain: TTwoDimArray): Integer;
  1033. begin
  1034.   Result := FCache.GetDomain(DimensionIDs, DimensionCount, ATotals, Domain);
  1035. end;
  1036.  
  1037. function TCustomDataStore.GetDimensionMemberCount(Dimension: Integer): Integer;
  1038. begin
  1039.   Result := FCache.GetDimensionMemberCount(Dimension);
  1040. end;
  1041.  
  1042. function TCustomDataStore.GetDimensionCount: Integer;
  1043. begin
  1044.   Result := FCache.DimensionCount;
  1045. end;
  1046.  
  1047. function TCustomDataStore.GetSummaryCount: Integer;
  1048. begin
  1049.   Result := FCache.SummaryCount;
  1050. end;
  1051.  
  1052. function TCustomDataStore.GetSummaryName(ISum: Integer): String;
  1053. var
  1054.   i, iActive: Integer;
  1055. begin
  1056.   Result := '';
  1057.   if assigned (DimensionMap) then
  1058.   begin
  1059.     iActive := 0;
  1060.     for i := 0 to DimensionMap.count-1 do
  1061.     begin
  1062.       if DimensionMap[i].active and (DimensionMap[i].DimensionType <> dimDimension) then
  1063.       begin
  1064.         if (iSum = iActive) then Result := DimensionMap[i].Name;
  1065.         iActive := iActive + 1;
  1066.       end;
  1067.     end;
  1068.   end;
  1069.   if (Result = '') then Result := FCache.GetSummaryName(ISum);
  1070. end;
  1071.  
  1072. function TCustomDataStore.GetSummaryAsString(Coord: TSmallIntArray): String;
  1073. begin
  1074.   Result := FCache.GetSummaryAsString(Coord);
  1075. end;
  1076.  
  1077. function TCustomDataStore.GetSummaryAsVariant(Coord: TSmallIntArray): Variant;
  1078. begin
  1079.   Result := FCache.GetSummaryAsVariant(Coord);
  1080. end;
  1081.  
  1082. function TCustomDataStore.GetCurrentSummary: Integer;
  1083. begin
  1084.   Result := FCache.CurrentSummary;
  1085. end;
  1086.  
  1087. procedure TCustomDataStore.SetCurrentSummary(Value: Integer);
  1088. begin
  1089.   if (FCache.CurrentSummary <> Value) then
  1090.   begin
  1091.     FCache.CurrentSummary := Value;
  1092.     StateChanged;
  1093.   end;
  1094. end;
  1095.  
  1096. function TCustomDataStore.GetMemoryUsage: Integer;
  1097. begin
  1098.   Result := 0;
  1099.   if Assigned(FCache) then Result := FCache.GetMemoryUsage;
  1100. end;
  1101.  
  1102. function TCustomDataStore.BinMapHasBinData: Boolean;
  1103. var
  1104.   I: Integer;
  1105. begin
  1106.   Result := False;
  1107.   for I := 0 to FDimensionMap.Count-1 do
  1108.   begin
  1109.     if FDimensionMap[I].IsBinData or (FDimensionMap[I].active = False) then
  1110.     begin
  1111.       Result := True;
  1112.       break;
  1113.     end;
  1114.   end;
  1115. end;
  1116.  
  1117. function TCustomDataStore.GetDimensionMapCount: Integer;
  1118. begin
  1119.   Result := FDimensionMap.Count;
  1120. end;
  1121.  
  1122. procedure TCustomDataStore.SetCapacity(Value: Integer);
  1123. begin
  1124.   SetMemoryCapacity(Value);
  1125. end;
  1126.  
  1127. function TCustomDataStore.GetCapacity: Integer;
  1128. begin
  1129.   Result := GetMemoryCapacity;
  1130. end;
  1131.  
  1132. procedure TCustomDataStore.DoBeforeOpen;
  1133. begin
  1134.   if Assigned(FBeforeOpen) then
  1135.     FBeforeOpen(Self);
  1136. end;
  1137.  
  1138. procedure TCustomDataStore.DoAfterOpen;
  1139. begin
  1140.   if Assigned(FAfterOpen) then
  1141.     FAfterOpen(Self);
  1142. end;
  1143.  
  1144. procedure TCustomDataStore.DoBeforeClose;
  1145. begin
  1146.   if Assigned(FBeforeClose) then
  1147.     FBeforeClose(Self);
  1148. end;
  1149.  
  1150. procedure TCustomDataStore.DoAfterClose;
  1151. begin
  1152.   if Assigned(FAfterClose) then
  1153.     FAfterClose(Self);
  1154. end;
  1155.  
  1156. procedure TCustomDataStore.DoOnRefresh(DimMap: TCubeDims);
  1157. begin
  1158.   if Assigned(FOnRefresh) then
  1159.     FOnRefresh(Self, DimMap);
  1160. end;
  1161.  
  1162. procedure TCustomDataStore.SetMaxDims(Value: Integer);
  1163. begin
  1164.   if (Value <> FMaxDims) then
  1165.   begin
  1166.     if (Value >= MaxBinDimensions) then  { This is the absolute limit }
  1167.       FMaxDims := MaxBinDimensions
  1168.     else
  1169.       FMaxDims := Value;
  1170.   end;
  1171. end;
  1172.  
  1173. procedure TCustomDataStore.SetMaxSums(Value: Integer);
  1174. begin
  1175.   if (Value <> FMaxSums) then FMaxSums := Value;
  1176. end;
  1177.  
  1178. procedure TCustomDataStore.SetBinData(Value: Boolean);
  1179. begin
  1180.   if (Value <> FBinData) then FBinData := Value;
  1181. end;
  1182.  
  1183.  
  1184. function TCustomDataStore.CheckDimensionMap(DimMap: TCubeDims; var BuildType: TBuildType): Boolean;
  1185. var
  1186.   OldMap: TCubeDims;
  1187.   I: Integer;
  1188.   Dim: TDimension;
  1189.   Summary: TSummary;
  1190. begin
  1191.   Result := False;
  1192.   if not Assigned(DimensionMap) or (DimensionMap.Count = 0) then Exit;
  1193.   if FDirty then
  1194.   begin
  1195.     FDirty := False;
  1196.     Result := True;
  1197.     BuildType := btHardRebuild;
  1198.     Exit;
  1199.   end;
  1200.   OldMap := DimensionMap;
  1201.   for I := 0 to DimMap.Count-1 do
  1202.   begin
  1203.     if (OldMap[I].FieldName = DimMap[I].FieldName) then
  1204.     begin
  1205.       if (OldMap[I].active <> DimMap[I].active) then
  1206.       begin
  1207.         Result := True;
  1208.         BuildType := btHardRebuild;
  1209.         break;
  1210.       end;
  1211.       if (DimMap[I].FieldType = ftDateTime) or (DimMap[I].FieldType = ftDate) then
  1212.       begin
  1213.         if (OldMap[I].StartDate <> DimMap[I].StartDate) then
  1214.         begin
  1215.           Result := True;
  1216.           BuildType := btHardRebuild;
  1217.           break;
  1218.         end;
  1219.       end;
  1220.       if (OldMap[I].BinType <> DimMap[I].BinType) then
  1221.       begin
  1222.         Result := True;
  1223.         BuildType := btHardRebuild;
  1224.         break;
  1225.       end;
  1226.       if (OldMap[I].Name <> DimMap[I].Name) then Result := True;
  1227.       if (OldMap[I].Format <> DimMap[I].Format) then
  1228.       begin
  1229.         if DimMap[I].IsDimension then
  1230.         begin
  1231.           Dim := DataCache.DimensionFromFieldName(DimMap[I].FieldName);
  1232.           if Assigned(Dim) then
  1233.             Dim.FieldDefinition.FormatString := DimMap[I].Format;
  1234.         end
  1235.         else
  1236.         begin
  1237.           Summary := DataCache.SummaryFromFieldName(DimMap[I].FieldName);
  1238.           if Assigned(Summary) then
  1239.             Summary.FieldDefinition.FormatString := DimMap[I].Format;
  1240.         end;
  1241.         Result := True;
  1242.       end;
  1243.     end
  1244.     else
  1245.     begin
  1246.       Result := True;
  1247.       BuildType := btHardRebuild;
  1248.       break;
  1249.     end;
  1250.   end;
  1251. end;
  1252.  
  1253. {
  1254.   SetLoadMap:  on entry, dimMap contains a new map with Loaded set
  1255.   on dimensions which must be loaded.  If a previous map existed,
  1256.   it is passed in OldMap
  1257. }
  1258.  
  1259. procedure TCustomDataStore.SetLoadMap(DimMap, OldMap: TCubeDims);
  1260. var
  1261.   i, si, ci, iDims, iSums, maxCells: Integer;
  1262.   iCells, x: Integer;
  1263.   DM: TCubeDim;
  1264. begin
  1265.   maxCells := self.maxCells;
  1266.   if (maxCells <= 0) then maxCells := 2000000000;
  1267.   { Initially set the active flase on dimensions and summaries }
  1268.   { which must be loaded.  Override this flag if incompatible with ActiveTypes }
  1269.   iDims := 0; iSums := 0;
  1270.   for i := 0 to DimMap.count-1 do
  1271.   begin
  1272.     DM := DimMap[i];
  1273.     if assigned(OldMap) and (i < OldMap.Count) then
  1274.       DM.wasActive := OldMap[i].Active and (DM.ActiveFlag <> diInactive);
  1275.     case DM.ActiveFlag of
  1276.       diInactive: DM.active := false;
  1277.       diActive: DM.active := true;
  1278.     end;
  1279.     if DM.Active then
  1280.     begin
  1281.       if DM.IsDimension then
  1282.         iDims := iDims + 1
  1283.       else if (DM.DerivedFrom < 0) then
  1284.         iSums := iSums + 1;
  1285.     end;
  1286.   end;
  1287.   { pre-calculate the number of dimensions that need to be loaded }
  1288.   { Try to load all dimensions that were active before or that are being requested }
  1289.   iCells := iSums;
  1290.   if (iCells <= 0) then iCells := 1;    { always assume one summary }
  1291.   { Multiply out the ValueCounts for the already marked dimensions }
  1292.   for i := 0 to DimMap.count-1 do
  1293.   begin
  1294.     DM := DimMap[i];
  1295.     if DM.isDimension and (DM.ActiveFlag <> diInactive) then
  1296.     begin
  1297.       if DM.Active then
  1298.       begin
  1299.         if (DM.ValueCount > 0) then
  1300.           iCells := iCells * DM.ValueCount
  1301.         else
  1302.           iCells := iCells * LargeValueCount;
  1303.       end;
  1304.     end;
  1305.   end;
  1306.   { start by loading the ones that are already open somewhere }
  1307.   for i := DimMap.count-1 downto 0 do
  1308.   begin
  1309.     DM := DimMap[i];
  1310.     if DM.Active then Continue;   { already loaded }
  1311.     if DM.isDimension and CanDimBeClosed(i) then Continue;
  1312.     if DM.isSummary and CanSumBeClosed(i) then Continue;
  1313.     if DM.IsDimension then
  1314.     begin
  1315.       if (IDims < MaxDimensions) and (iCells < maxCells) then
  1316.       begin
  1317.         x := iCells;
  1318.         if (DM.ValueCount > 0) then
  1319.           x := x * DM.ValueCount
  1320.         else
  1321.           x:= x*LargeValueCount;
  1322.         if (x > MaxCells) then
  1323.           Continue;
  1324.         iCells := x;
  1325.         IDims := IDims + 1;
  1326.         DM.active := true;
  1327.       end;
  1328.     end
  1329.     else
  1330.     begin
  1331.       if (iSums < MaxSummaries) and (iCells < maxCells) then
  1332.       begin
  1333.         if (iSums > 0) then   { the first one is always precalculated }
  1334.         begin
  1335.           x := (iCells * (iSums+1)) div iSums;
  1336.           if (x > maxCells) then Continue;
  1337.           iCells := x;
  1338.         end;
  1339.         iSums := iSums + 1;
  1340.         DM.active := true;
  1341.       end;
  1342.     end;
  1343.   end;
  1344.   { Now try to load the dimensions which were formerly active }
  1345.   for i := DimMap.count-1 downto 0 do
  1346.   begin
  1347.     DM := DimMap[i];
  1348.     if DM.Active then Continue;   { already loaded }
  1349.     if not DM.wasActive then Continue;
  1350.     if DM.IsDimension then
  1351.     begin
  1352.       if (IDims < MaxDimensions) and (iCells < maxCells) then
  1353.       begin
  1354.         x := iCells;
  1355.         if (DM.ValueCount > 0) then
  1356.           x := x * DM.ValueCount
  1357.         else
  1358.           x := x*LargeValueCount;
  1359.         if (x > MaxCells) then Continue;
  1360.         iCells := x;
  1361.         IDims := IDims + 1;
  1362.         DM.active := true;
  1363.       end;
  1364.     end
  1365.     else
  1366.     begin
  1367.       if (iSums < MaxSummaries) and (iCells < maxCells) then
  1368.       begin
  1369.         if (iSums > 0) then   { the first one is always precalculated }
  1370.         begin
  1371.           x := (iCells * (iSums+1)) div iSums;
  1372.           if (x > maxCells) then Continue;
  1373.           iCells := x;
  1374.         end;
  1375.         iSums := iSums + 1;
  1376.         DM.active := true;
  1377.       end;
  1378.     end;
  1379.   end;
  1380.   for i := DimMap.count-1 downto 0 do
  1381.   begin
  1382.     DM := DimMap[i];
  1383.     if DM.Active then Continue;   { already loaded }
  1384.     if (DM.ActiveFlag <> diAsNeeded) then Continue;
  1385.     if DM.IsDimension then
  1386.     begin
  1387.       if (IDims < MaxDimensions) and (iCells < maxCells) then
  1388.       begin
  1389.         x := iCells;
  1390.         if (DM.ValueCount > 0) then
  1391.           x := x * DM.ValueCount
  1392.         else
  1393.           x:= x*LargeValueCount;
  1394.         if (x > MaxCells) then Continue;
  1395.         iCells := x;
  1396.         IDims := IDims + 1;
  1397.         DM.active := true;
  1398.       end;
  1399.     end
  1400.     else
  1401.     begin
  1402.       if (iSums < MaxSummaries) and (iCells < maxCells) then
  1403.       begin
  1404.         if (iSums > 0) then    { the first one is always precalculated }
  1405.         begin
  1406.           x := (iCells * (iSums+1)) div iSums;
  1407.           if (x > maxCells) then Continue;
  1408.           iCells := x;
  1409.         end;
  1410.         iSums := iSums + 1;
  1411.         DM.active := true;
  1412.       end;
  1413.     end;
  1414.   end;
  1415.   { Now test to see if limits were met }
  1416.   { Enable derived summaries }
  1417.   for i := 0 to DimMap.count-1 do
  1418.   begin
  1419.     DM := DimMap[i];
  1420.     if (DM.dimensionType <> dimDimension) and (DM.derivedFrom >= 0) then
  1421.     begin
  1422.       DM.Active := DimMap.AverageFieldCheck(i, si, ci) and DimMap[si].active and DimMap[ci].active;
  1423.     end;
  1424.   end;
  1425.   { Only raise an exception if in Design Mode. }
  1426.   if (csDesigning in ComponentState) then
  1427.   begin
  1428.     if (iSums > MaxSummaries) then
  1429.       raise EDimensionMapError.CreateFMT(sMaxAllowedSums, [MaxSummaries]);
  1430.     if (iDims > MaxDimensions) then
  1431.       raise EDimensionMapError.CreateFMT(sMaxAllowedDims, [MaxDimensions]);
  1432.     if (MaxCells > 0) and (iCells > MaxCells) then
  1433.       raise EDimensionMapError.createFMT(sMaxAllowedCells, [iCells,maxCells]);
  1434.   end;
  1435.   if (iSums = 0) then
  1436.   begin
  1437.     for i := 0 to DimMap.count-1 do
  1438.     begin
  1439.       if DimMap[i].isSummary and (DimMap[i].ActiveFlag <> diInactive) then
  1440.         iSums := iSums + 1;
  1441.     end;
  1442.     if (iSums = 0) then
  1443.       raise EDimensionMapError.Create(sNoSumsAvailable)
  1444.     else
  1445.       raise EDimensionMapError.Create(sNoSumsCouldBeLoaded);
  1446.   end;
  1447.   if (iDims = 0) then
  1448.   begin
  1449.     for i := 0 to DimMap.count-1 do
  1450.     begin
  1451.       if DimMap[i].isDimension and (DimMap[i].ActiveFlag<>diInactive) then
  1452.         iDims := iDims + 1;
  1453.     end;
  1454.     if (iDims = 0) then
  1455.       raise EDimensionMapError.Create(sNoDimsAvailable)
  1456.     else
  1457.       raise EDimensionMapError.Create(sNoDimsCouldBeLoaded);
  1458.   end;
  1459. end;
  1460.  
  1461. function TCustomDataStore.CanDimBeClosed(iMapIndex: Integer): Boolean;
  1462. begin
  1463.   Result := true;
  1464. end;
  1465.  
  1466. function TCustomDataStore.CanSumBeClosed(iMapIndex: Integer): Boolean;
  1467. begin
  1468.   Result := true;
  1469. end;
  1470.  
  1471. procedure TCustomDataStore.Refresh(DimMap: TCubeDims; bForce: Boolean);    //pg
  1472. var
  1473.   BuildType: TBuildType;
  1474.  
  1475.   procedure HardRebuild;
  1476.   begin
  1477.     SetActive(False);
  1478.     SetActive(True);
  1479.   end;
  1480.  
  1481. begin
  1482.   BuildType := btNoRebuild;
  1483.   if not Assigned(DimMap) then
  1484.   begin
  1485.     HardRebuild;
  1486.     Exit;
  1487.   end;
  1488.   { Give the developer a chance to change the dimension map and/or the data set }
  1489.   DoOnRefresh(DimMap);
  1490.   { Set up the load states for the dimensions }
  1491.   SetLoadMap(DimMap, DimensionMap);
  1492.   { Check the DimensionMap to see if we need to rebuild or not }
  1493.   if CheckDimensionMap(DimMap, BuildType) or bForce then
  1494.   begin
  1495.     if bForce then BuildType := btHardRebuild;
  1496.     DimensionMap.Assign(DimMap);
  1497.     case BuildType of
  1498.       btSoftRebuild,
  1499.       btHardRebuild: HardRebuild;
  1500.       btNoRebuild:
  1501.       begin
  1502.         SetState(dcInactive);
  1503.         StateChanged;
  1504.         SetState(dcBrowseAllData);
  1505.       end;
  1506.     end;
  1507.     if (BuildType <> btHardRebuild) then StateChanged;
  1508.   end
  1509.   else
  1510.     DimensionMap.Assign(DimMap);
  1511. end;
  1512.  
  1513. procedure TCustomDataStore.CalcSubTotals;
  1514. begin
  1515.   FCache.CalcSubTotals;
  1516. end;
  1517.  
  1518.   { TBinTable }
  1519.  
  1520. type
  1521.   PFieldDescList = ^TFieldDescList;
  1522.   TFieldDescList = array[0..1023] of FLDDesc;
  1523.  
  1524.   TBinTable = class(TDBDataSet)
  1525.   private
  1526.     FTableName: TFileName;
  1527.     FTmpHandle: HDBICur;
  1528.     FTableLevel: Integer;
  1529.     FTableType: TTableType;
  1530.     FGroupBreak: Boolean;
  1531.     FDimensionMap: TCubeDims;
  1532.     FDBHandle: HDBIDB;
  1533.     function GetDriverTypeName(Buffer: PChar): PChar;
  1534.     function GetTableTypeName: PChar;
  1535.     procedure SetTableName(const Value: TFileName);
  1536.     procedure SetTableType(Value: TTableType);
  1537.     function GetTableLevel: Integer;
  1538.     procedure EncodeFieldDesc(var FieldDesc: FLDDesc; const Name: string; DataType: TFieldType; Size: Word);
  1539.     procedure HandleKeyViol;
  1540.   protected
  1541.     function CreateHandle: HDBICur; override;
  1542.     function GetCanModify: Boolean; override;
  1543.     function GetHandle: HDBICur;
  1544.   public
  1545.     procedure CleanUp;
  1546.     procedure Attach(ASource: TMultiDimDataLink);
  1547.     function CreateTempTable: HDBICur;
  1548.     procedure CreateIndexTable(Cache: TDataCache);
  1549.     procedure save(TabName: TFileName);
  1550.     procedure EmptyTable;
  1551.     procedure BinPost;
  1552.     function CheckKeyViol(Status: DBIResult): Boolean;
  1553.     function FillRecord(ASource: TDataSet): Boolean;
  1554.     function IsDBaseTable: Boolean;
  1555.     property TableName: TFileName read FTableName write SetTableName;
  1556.     property TableType: TTableType read FTableType write SetTableType default ttDefault;
  1557.     property TableLevel: Integer read GetTableLevel write FTableLevel;
  1558.     property TempHandle: HDBICur read GetHandle write FTmpHandle;
  1559.     property GroupBreak: Boolean read FGroupBreak write FGroupBreak default False;
  1560.     property DimensionMap: TCubeDims read FDimensionMap;
  1561.   end;
  1562.  
  1563. function GetIntProp(const Handle: Pointer; PropName: Integer): Integer;
  1564. var
  1565.   Length: Word;
  1566.   Value: Integer;
  1567. begin
  1568.   Value := 0;
  1569.   Check(DbiGetProp(HDBIObj(Handle), propName, @Value, SizeOf(Value), Length));
  1570.   Result := Value;
  1571. end;
  1572.  
  1573. var
  1574.   MXDBLocale: TLocale;
  1575.  
  1576. procedure TBinTable.CleanUp;
  1577. begin
  1578.   if Assigned(FDimensionMap) then FDimensionMap.Free;
  1579. end;
  1580.  
  1581. procedure TBinTable.Attach(ASource: TMultiDimDataLink);
  1582. var
  1583.   I, Cnt: Integer;
  1584.   OrigDimMap: TCubeDim;
  1585.   newDim: TCubeDim;
  1586.  
  1587.   function GetDimFromFieldName(FldName: string): TCubeDim;
  1588.   var
  1589.     I: Integer;
  1590.   begin
  1591.     result := nil;
  1592.     for I := 0 to Asource.FDataStore.FDimensionMap.Count-1 do
  1593.     begin
  1594.       if (Asource.FDataStore.FDimensionMap[I].FieldName = FldName) then
  1595.       begin
  1596.         Result := Asource.FDataStore.FDimensionMap[I];
  1597.         break;
  1598.       end;
  1599.     end;
  1600.   end;
  1601.  
  1602. begin
  1603.   Cnt := 0;
  1604.   { Force to the highest table level }
  1605.   TableLevel := 7;
  1606.   { Get the table descriptor from the source table }
  1607.   TableName  := 'TmpTab';  { Do not localize }
  1608.   { Reorder The original dimension map so that the active dimensions are ordered first }
  1609.   FDimensionMap  := TCubeDims.Create(self, TCubeDim);
  1610.   for I := 0 to ASource.DataSet.FieldCount - 1 do
  1611.   begin
  1612.     with Asource.DataSet.Fields[I] do
  1613.     begin
  1614.       OrigDimMap := GetDimFromFieldName(FieldName);
  1615.       if (OrigDimMap.active = True) and (OrigDimMap.IsDimension) then
  1616.       begin
  1617.         Inc(Cnt);
  1618.         if (Cnt > MaxBinDimensions) then
  1619.         begin
  1620.           FDimensionMap.Free;
  1621.           raise ECacheError.CreateFMT(sMaxAllowedDims, [MaxBinDimensions]);
  1622.         end;
  1623.         { Set up field types }
  1624.         FDimensionMap.Add;
  1625.         newDim := FDimensionMap[FDimensionMap.Count-1];
  1626.         newDim.Assign(OrigDimMap);
  1627.         if (FieldKind = fkData) or (FieldKind = fkCalculated) then
  1628.         begin
  1629.           if OrigDimMap.BinType = binSet then
  1630.             FieldDefs.Add(FieldName, OrigDimMap.FBinData.GetBinNameDataType,
  1631.                           OrigDimMap.FBinData.GetMaxBinNameSize, Required)
  1632.           else
  1633.             FieldDefs.Add(FieldName, DataType, Size, Required);
  1634.         end;
  1635.       end;
  1636.     end;
  1637.   end;
  1638.   { Scan sumnmaries }
  1639.   for I := 0 to ASource.DataSet.FieldCount - 1 do
  1640.   begin
  1641.     with Asource.DataSet.Fields[I] do
  1642.     begin
  1643.       OrigDimMap := GetDimFromFieldName(FieldName);
  1644.       if (OrigDimMap.active = True) and (OrigDimMap.IsSummary) then
  1645.       begin
  1646.         FDimensionMap.Add;
  1647.         newDim := FDimensionMap[FDimensionMap.Count-1];
  1648.         newDim.Assign(OrigDimMap);
  1649.         if (FieldKind = fkData) or (FieldKind = fkCalculated)  then
  1650.           FieldDefs.Add(FieldName, DataType, Size, Required);
  1651.       end;
  1652.     end;
  1653.   end;
  1654.   if (ASource.DataSet is TDBDataSet) then
  1655.     with TDBDataSet(ASource.DataSet) do
  1656.     begin
  1657.       if DataBase.IsSQLBased then
  1658.         FDBHandle := nil
  1659.       else
  1660.         FDBHandle := DataBase.Handle;
  1661.     end
  1662.   else
  1663.     FDBHandle := nil;
  1664.   { Create the table TDataSet }
  1665.   FTmpHandle := CreateTempTable;
  1666.   { Give us logical field types }
  1667.   Check(DbiSetProp(hDbiObj(FTmpHandle), curXLTMODE, Longint(xltFIELD)));
  1668.   { Set active to true. }
  1669.   Self.Active := True;
  1670. end;
  1671.  
  1672. function TBinTable.CreateTempTable: HDBICur;
  1673. var
  1674.   I: Integer;
  1675.   FieldDescs: PFLDDesc;
  1676.   DriverTypeName: DBINAME;
  1677.   TableDesc: CRTblDesc;
  1678.   LDName: DBIName;           
  1679.   LName: string;
  1680.   TempLocale, OldLocale: TLocale;
  1681.   SQLLName: DBIName;
  1682.   PSQLLName: PChar;
  1683.   Level: string;
  1684.   pOptDesc, pOrigDesc: pFLDDesc;
  1685.   pOrigData: pBYTE;
  1686.  
  1687.   function GetStandardLanguageDriver: string;
  1688.   var
  1689.     DriverName: string;
  1690.     Buffer: array[0..DBIMAXNAMELEN - 1] of Char;
  1691.   begin
  1692.     if not Database.IsSQLBased then
  1693.     begin
  1694.       DriverName := GetTableTypeName;
  1695.       if (DriverName = '') then
  1696.         if IsDBaseTable then
  1697.           DriverName := szDBASE
  1698.         else
  1699.           DriverName := szPARADOX;
  1700.       if (DbiGetLdName(PChar(DriverName), nil, Buffer) = 0) then
  1701.         Result := Buffer;
  1702.     end
  1703.     else
  1704.       Result := '';
  1705.   end;
  1706.  
  1707. begin
  1708.   FieldDescs := nil;
  1709.   pOrigDesc  := nil;
  1710.   pOrigData  := nil;
  1711.   { Fill the table descriptor }
  1712.   FillChar(TableDesc, SizeOf(TableDesc), 0);
  1713.   with TableDesc do
  1714.   begin
  1715.     SetDBFlag(dbfTable, True);
  1716.     try
  1717.       { Add the table names }
  1718.       OldLocale := Locale;
  1719.       if (MXDBLocale <> nil) then SetLocale(MXDBLocale);
  1720.       AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);
  1721.       if (GetTableTypeName <> nil) then StrCopy(szTblType, GetTableTypeName);
  1722.       iFldCount := FieldDefs.Count;
  1723.       { Setup and add the field descriptors }
  1724.       FieldDescs := AllocMem(iFldCount * SizeOf(FLDDesc));
  1725.       TempLocale := nil;
  1726.       LName := '';
  1727.       if (Locale <> nil) then
  1728.         if (OsLdGetSymbName(Locale, @LDName) = 0) then LName := LDName;
  1729.       if (LName = '') then LName := GetStandardLanguageDriver;
  1730.       if (LName <> '') and (OsLdLoadBySymbName(PChar(LName), TempLocale) = 0) then
  1731.         SetLocale(TempLocale);
  1732.       try
  1733.         for I := 0 to FieldDefs.Count - 1 do
  1734.           with FieldDefs[I] do
  1735.           begin
  1736.             EncodeFieldDesc(PFieldDescList(FieldDescs)^[I], Name, DataType, Size);
  1737.             if Required then Inc(iValChkCount);
  1738.           end;
  1739.       finally
  1740.         if (TempLocale <> nil) then
  1741.         begin
  1742.           OsLdUnloadObj(TempLocale);
  1743.           SetLocale(OldLocale);
  1744.         end;
  1745.       end;
  1746.       pFldDesc := AllocMem(iFldCount * SizeOf(FLDDesc));
  1747.       PSQLLName := nil;
  1748.       if Database.IsSQLBased then
  1749.         if (DbiGetLdNameFromDB(DBHandle, nil, SQLLName) = 0) then
  1750.           PSQLLName := SQLLName;
  1751.       Check(DbiTranslateRecordStructure(nil, iFldCount, FieldDescs,
  1752.             GetDriverTypeName(DriverTypeName), PSQLLName, pFLDDesc, False));
  1753.       iValChkCount := 0;
  1754.       { Add the primary index }
  1755.       if Assigned(FDimensionMap) and (FDimensionMap.Count > 0) then
  1756.       begin
  1757.         iIdxCount := 1;
  1758.         pIdxDesc := AllocMem(iIdxCount * SizeOf(IDXDesc));
  1759.         pIdxDesc^.bPrimary := True;
  1760.         for I := 0 to FDimensionMap.Count-1 do
  1761.         begin
  1762.           if FDimensionMap[I].IsDimension then
  1763.           begin
  1764.             pIdxDesc.aiKeyFld[pIdxDesc.iFldsInKey] := FieldDefs[I].FieldNo;
  1765.             Inc(pIdxDesc.iFldsInKey);
  1766.           end;
  1767.         end;
  1768.       end;
  1769.       with TableDesc do
  1770.       begin
  1771.         iOptParams := 2;
  1772.         pOptDesc := AllocMem(iOptParams * sizeof(FLDDesc));
  1773.         pOrigDesc := pOptDesc;
  1774.         pOptData := AllocMem(Length(LName) + 2);
  1775.         pOrigData := pOptData;
  1776.         { Table level }
  1777.         Level := IntToStr(TableLevel);
  1778.         pOptDesc.iOffset := 0;
  1779.         pOptDesc.iLen := Length(Level) + 1;
  1780.         StrCopy(pOptDesc.szName, szCFGDRVLEVEL);
  1781.         StrPCopy(PChar(pOptData), Level);
  1782.         Inc(PChar(pOptData), Length(Level) + 1);
  1783.         Inc(pOptDesc);
  1784.         { language driver }
  1785.         pOptDesc.iOffset := Length(Level) + 1;
  1786.         pOptDesc.iLen := Length(Level) + 1 + Length(LName) + 1;
  1787.         StrCopy(pOptDesc.szName, szCFGDRVLANGDRIVER);
  1788.         StrPCopy(PChar(pOptData), LName);
  1789.         Inc(PChar(pOptData), Length(LName) + 1);
  1790.         pFldOptParams := pOrigDesc;
  1791.         pOptData := pOrigData;
  1792.       end;
  1793.       Check(DbiCreateTempTable(FDBHandle, TableDesc, Result));
  1794.     finally
  1795.       if (pFldDesc <> nil) then
  1796.         FreeMem(pFldDesc, iFldCount * SizeOf(FLDDesc));
  1797.       if (FieldDescs <> nil) then
  1798.         FreeMem(FieldDescs, iFldCount * SizeOf(FLDDesc));
  1799.       if (pIdxDesc <> nil) then
  1800.         FreeMem(pIdxDesc, iIdxCount * SizeOf(IDXDesc));
  1801.       FreeMem(pOrigDesc, 3 * sizeof(FLDDesc));
  1802.       FreeMem(pOrigData, 20);
  1803.       SetDBFlag(dbfTable, False);
  1804.     end;
  1805.   end;
  1806. end;
  1807.  
  1808. procedure TBinTable.CreateIndexTable(Cache: TDataCache);
  1809. var
  1810.   I: Integer;
  1811.   FieldName: string;
  1812. begin
  1813.   { Get the table descriptor from the source table }
  1814.   TableName  := 'IdxTab'; { Do not localize }
  1815.   TableLevel := 7;
  1816.   if FieldDefs.Count = 0 then
  1817.   begin
  1818.     FieldDefs.Add('Position', ftInteger, 0, False); { Do not localize }
  1819.     for I := 0 to Cache.DimensionCount - 1 do
  1820.     begin
  1821.       FieldName := Cache.GetDimensionName(I);
  1822.       FieldDefs.Add(FieldName, ftSmallint, 0, False);
  1823.     end;
  1824.     FieldDefs.Add('Offset', ftInteger, 0, False); { Do not localize }
  1825.     FieldDefs.Add('Sparse', ftBoolean, 0, False); { Do not localize }
  1826.     FieldDefs.Add(Cache.GetSummaryName(Cache.CurrentSummary), ftFloat, 0, False);
  1827.   end;
  1828.   { Create the table  TDataSet }
  1829.   FTmpHandle := CreateTempTable;
  1830.   { Give us logical field types }
  1831.   Check(DbiSetProp(hDbiObj(FTmpHandle), curXLTMODE, Longint(xltFIELD)));
  1832.   { Set active to true. }
  1833.   Self.Active := True;
  1834. end;
  1835.  
  1836. procedure TBinTable.Save(TabName: TFileName);
  1837. begin
  1838.   Check(DbiMakePermanent(FTmpHandle, PChar(TabName), True));
  1839. end;
  1840.  
  1841. function TBinTable.GetTableTypeName: PChar;
  1842. const
  1843.   Names: array[TTableType] of PChar = (szPARADOX, szPARADOX, szDBASE, szDBASE, szASCII);
  1844. var
  1845.   TblType: TTableType;
  1846.   Extension: string;
  1847. begin
  1848.   Result := nil;
  1849.   TblType := TableType;
  1850.   if not Database.IsSQLBased then
  1851.   begin
  1852.     if (TblType = ttDefault) then
  1853.     begin
  1854.       Extension := ExtractFileExt(FTableName);
  1855.       if (CompareText(Extension, '.DBF') = 0) then TblType := ttDBase;
  1856.       if (CompareText(Extension, '.TXT') = 0) then TblType := ttASCII;
  1857.     end;
  1858.     Result := Names[TblType];
  1859.   end;
  1860.   TableType := TblType;
  1861. end;
  1862.  
  1863. procedure TBinTable.EncodeFieldDesc(var FieldDesc: FLDDesc; const Name: string; DataType: TFieldType; Size: Word);
  1864. begin
  1865.   with FieldDesc do
  1866.   begin
  1867.     AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
  1868.     iFldType := FldTypeMap[DataType];
  1869.     iSubType := FldSubTypeMap[DataType];
  1870.     case DataType of
  1871.       ftString,
  1872.       ftBytes,
  1873.       ftVarBytes,
  1874.       ftBlob,
  1875.       ftMemo,
  1876.       ftGraphic,
  1877.       ftFmtMemo,
  1878.       ftParadoxOle,
  1879.       ftDBaseOle,
  1880.       ftTypedBinary: iUnits1 := Size;
  1881.       ftBCD:
  1882.       begin
  1883.         iUnits1 := 32;
  1884.         iUnits2 := Size;
  1885.       end;
  1886.     end;
  1887.   end;
  1888. end;
  1889.  
  1890. function TBinTable.GetHandle: HDBICur;
  1891. begin
  1892.   Result := FTmpHandle;
  1893. end;
  1894.  
  1895. function TBinTable.CreateHandle: HDBICur;
  1896. begin
  1897.   if (FTableName = '') then DatabaseError(SNoTableName);
  1898.   Result := GetHandle;
  1899. end;
  1900.  
  1901. function TBinTable.GetTableLevel: Integer;
  1902. begin
  1903.   if (Handle <> nil) then
  1904.     Result := GetIntProp(Handle, curTABLELEVEL)
  1905.   else
  1906.     Result := FTableLevel;
  1907. end;
  1908.  
  1909. procedure TBinTable.EmptyTable;
  1910. var
  1911.   STableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  1912. begin
  1913.   if Active then
  1914.   begin
  1915.     CheckBrowseMode;
  1916.     Check(DbiEmptyTable(DBHandle, Handle, nil, nil));
  1917.     ClearBuffers;
  1918.     DataEvent(deDataSetChange, 0);
  1919.   end
  1920.   else
  1921.   begin
  1922.     SetDBFlag(dbfTable, True);
  1923.     try
  1924.       Check(DbiEmptyTable(DBHandle, nil, AnsiToNative(DBLocale, TableName,
  1925.             STableName, SizeOf(STableName) - 1), GetTableTypeName));
  1926.     finally
  1927.       SetDBFlag(dbfTable, False);
  1928.     end;
  1929.   end;
  1930. end;
  1931.  
  1932. procedure TBinTable.SetTableName(const Value: TFileName);
  1933. begin
  1934.   CheckInactive;
  1935.   FTableName := Value;
  1936.   DataEvent(dePropertyChange, 0);
  1937. end;
  1938.  
  1939. procedure TBinTable.SetTableType(Value: TTableType);
  1940. begin
  1941.   CheckInactive;
  1942.   FTableType := Value;
  1943. end;
  1944.  
  1945. function TBinTable.IsDBaseTable: Boolean;
  1946. begin
  1947.   Result := (TableType = ttDBase) or
  1948.             (CompareText(ExtractFileExt(TableName), '.DBF') = 0);
  1949. end;
  1950.  
  1951. function TBinTable.GetDriverTypeName(Buffer: PChar): PChar;
  1952. var
  1953.   Length: Word;
  1954. begin
  1955.   Result := Buffer;
  1956.   Check(DbiGetProp(HDBIOBJ(DBHandle), dbDATABASETYPE, Buffer,
  1957.                    SizeOf(DBINAME), Length));
  1958.   if (StrIComp(Buffer, szCFGDBSTANDARD) = 0) then
  1959.   begin
  1960.     Result := GetTableTypeName;
  1961.     if (Result <> nil) then Result := StrCopy(Buffer, Result);
  1962.   end;
  1963. end;
  1964.  
  1965. function TBinTable.GetCanModify: Boolean;
  1966. begin
  1967.   Result := True;
  1968. end;
  1969.  
  1970. function TBinTable.FillRecord(ASource: TDataSet): Boolean;
  1971. var
  1972.   I, flds: Integer;
  1973.   Value: Variant;
  1974.   CubeDim: TCubeDim;
  1975.  
  1976.   function GetDimFromFieldName(FldName: string): TCubeDim;
  1977.   var
  1978.     I: Integer;
  1979.   begin
  1980.     result := nil;
  1981.     for I := 0 to FDimensionMap.Count-1 do
  1982.     begin
  1983.       if (FDimensionMap[I].FieldName = FldName) then
  1984.       begin
  1985.         Result := FDimensionMap[I];
  1986.         break;
  1987.       end;
  1988.     end;
  1989.   end;
  1990.   
  1991. begin
  1992.   Result := ASource.EOF;
  1993.   if (Result = True) then Exit;
  1994.   { Add a new record }
  1995.   Append;
  1996.   { Get the field values }
  1997.   flds := ASource.FieldCount;
  1998.   for I := 0 to flds-1 do
  1999.   begin
  2000.     { Get the value from the data set }
  2001.     Value := ASource.FieldValues[ASource.Fields[I].FieldName];
  2002.     CubeDim := GetDimFromFieldName(ASource.Fields[I].FieldName);
  2003.     if (CubeDim = nil) then Continue;
  2004.     if CubeDim.IsBinData then CubeDim.DoTransform(Value);
  2005.     FieldValues[ASource.Fields[I].FieldName] := Value;
  2006.   end;
  2007.   { Post the values to the bin table. }
  2008.   BinPost;
  2009. end;
  2010.  
  2011. procedure TBinTable.HandleKeyViol;
  2012. var
  2013.   ValSumRecord, ValDimRecord: Variant;
  2014.   DimNames: string;
  2015.   I, SumRecCnt: Integer;
  2016. begin
  2017.   if (FDimensionMap.DimensionCount > 1) then
  2018.     ValDimRecord := VarArrayCreate([0, FDimensionMap.DimensionCount-1], varVariant);
  2019.   ValSumRecord := VarArrayCreate([0, FDimensionMap.SummaryCount-1], varVariant);
  2020.   SumRecCnt := 0;
  2021.   for I := 0 to FDimensionMap.Count-1 do
  2022.   begin
  2023.     if FDimensionMap[I].IsDimension then
  2024.     begin
  2025.       DimNames := DimNames + Fields[I].FieldName + ';';
  2026.       if (FDimensionMap.DimensionCount > 1) then
  2027.         ValDimRecord[I] := FieldValues[Fields[I].FieldName]
  2028.       else
  2029.         ValDimRecord := FieldValues[Fields[I].FieldName];
  2030.     end
  2031.     else
  2032.     begin
  2033.       ValSumRecord[SumRecCnt] := FieldValues[Fields[I].FieldName];
  2034.       Inc(SumRecCnt);
  2035.     end;
  2036.   end;
  2037.   { Cancel changes }
  2038.   Cancel;
  2039.   First;
  2040.   {  Locate the duplicate record }
  2041.   Locate(DimNames, ValDimRecord, []);
  2042.   Edit;
  2043.   { Apply the summary }
  2044.   SumRecCnt := 0;
  2045.   for I := 0 to FDimensionMap.Count-1 do
  2046.     if FDimensionMap[I].IsSummary then
  2047.     begin
  2048.       FieldValues[Fields[I].FieldName] := FieldValues[Fields[I].FieldName] +
  2049.       ValSumRecord[SumRecCnt];
  2050.       Inc(SumRecCnt);
  2051.     end;
  2052. end;
  2053.  
  2054. procedure TBinTable.BinPost;
  2055. var
  2056.   Done: Boolean;
  2057. begin
  2058.   UpdateRecord;
  2059.   DataEvent(deCheckBrowseMode, 0);
  2060.   repeat
  2061.     UpdateCursorPos;
  2062.     if (State = dsEdit) then
  2063.       Done := CheckKeyViol(DbiModifyRecord(Handle, ActiveBuffer, True))
  2064.     else
  2065.       Done := CheckKeyViol(DbiInsertRecord(Handle, dbiNoLock, ActiveBuffer));
  2066.   until Done;
  2067.   inherited FreeFieldBuffers;
  2068.   SetState(dsBrowse);
  2069.   Resync([]);
  2070. end;
  2071.  
  2072. function TBinTable.CheckKeyViol(Status: DBIResult): Boolean;
  2073. begin
  2074.   Result := True;
  2075.   if (Status = DBIERR_KEYVIOL) then
  2076.   begin
  2077.     HandleKeyViol;
  2078.     Result := False;
  2079.   end
  2080.   else
  2081.     if (Status <> 0) then
  2082.       DbiError(Status);
  2083. end;
  2084.  
  2085.   { TMultiDimDataLink }
  2086.  
  2087. constructor TMultiDimDataLink.Create(AStore: TCustomDataStore);
  2088. begin
  2089.   inherited Create;
  2090.   FDataStore := AStore;
  2091.   FDataSource := nil;
  2092. end;
  2093.  
  2094. destructor TMultiDimDataLink.Destroy;
  2095. begin
  2096.   inherited Destroy;
  2097. end;
  2098.  
  2099. function DBCompareString(Var item1, item2): Integer;
  2100. begin
  2101.   Result := NativeCompareStrBuf(MXDBLocale, PChar(item1), PChar(item2), 0);
  2102. end;
  2103.  
  2104. procedure TMultiDimDataLink.DoUpdateCache;
  2105. var
  2106.   OldCursor: HCursor;
  2107. begin
  2108.   if FDataStore.ShowProgressDialog then
  2109.     OldCursor := GetCursor
  2110.   else
  2111.     OldCursor := SetCursor(LoadCursor(0, IDC_WAIT));
  2112.   try
  2113.     if FDataStore.ShowProgressDialog then
  2114.     begin
  2115.       ProgressDlg := TProgressDialog.Create(Application);
  2116.       try
  2117.         ProgressDlg.OnPerformBuild := UpdateCache;
  2118.         ProgressDlg.Caption := sBuildingDataStore;
  2119.         ProgressDlg.ShowModal;
  2120.         if (ProgressDlg.ExceptMessage <> '') then
  2121.           raise ECacheError.Create(ProgressDlg.ExceptMessage);  { reraise any exceptions that occured in the dlg }
  2122.       finally
  2123.         ProgressDlg.Free;
  2124.         ProgressDlg := nil;
  2125.       end;
  2126.     end
  2127.     else
  2128.       UpdateCache(Self);
  2129.   finally
  2130.     SetCursor(OldCursor);
  2131.   end;
  2132. end;
  2133.  
  2134. procedure TMultiDimDataLink.UpdateCache(Sender: TObject);
  2135. var
  2136.   i: Integer;
  2137.   Dim: TDimension;
  2138.   DimAllVals: TBuilderDim;
  2139.   DimAllList: TList;
  2140.   rString: string;
  2141.   bDataSetMatch: Boolean;
  2142.   bHaveBDE: Boolean;
  2143.   EAction: TErrorAction;
  2144.  
  2145.   procedure CleanUp;
  2146.   begin
  2147.     if Assigned(DimAllList) then
  2148.     begin
  2149.       while (DimAllList.Count > 0) do
  2150.       begin
  2151.         Dim := DimAllList.Last;
  2152.         DimAllList.Remove(Dim);
  2153.         Dim.Free;
  2154.       end;
  2155.     end;
  2156.     DimAllList.Free;
  2157.     DimAllList := nil;
  2158.   end;
  2159.  
  2160.   function SumsOrdered: Boolean;
  2161.   var
  2162.     I: Integer;
  2163.   begin
  2164.     Result := True;
  2165.     for I := 0 to FDataStore.FDimensionMap.Count-1 do
  2166.       if FDataStore.FDimensionMap[I].IsDimension then
  2167.         Result := False
  2168.       else
  2169.         Result := True;
  2170.   end;
  2171.  
  2172. begin
  2173.   {$IFDEF PROFILE}
  2174.   FDataStore.DataCache.FTicks.Ticks('CacheVerification');
  2175.   {$ENDIF}
  2176.   { Set some initial state flags }
  2177.   FDataStore.DataCache.Success := False;
  2178.   bHaveBDE := True;
  2179.   { 1. Create and verify dimension map }
  2180.   if(FDataStore.DataSet is TDecisionQuery) then
  2181.     rString := SDecisionQueryError
  2182.   else if (FDataStore.DataSet is TQuery) then
  2183.     rString := SQueryError
  2184.   else
  2185.     rString := SDataSetError;
  2186.  
  2187.   case VerifyRTQuery(FDataStore.DataSet, FDataStore.DimensionMap, bDataSetMatch) of
  2188.     tqeOK           : ;
  2189.     tqeNoAggs       : raise EDimensionMapError.create(SNoAggs + ' ' + rString);
  2190.     tqeNotGrouped   : raise EDimensionMapError.create(SGroupsMissing + ' ' + rString);
  2191.     tqeNoDimensions : raise EDimensionMapError.create(SNoDims + ' ' + rString);
  2192.     tqeUnknownDims  : raise EDimensionMapError.create(sUnknownDims);
  2193.   else
  2194.     raise EDimensionMapError.create(rString);
  2195.   end;
  2196.   FDataStore.SetLoadMap(FDataStore.DimensionMap, nil);
  2197.   if (FDataStore.DimensionMap.ActiveDimensionCount > FDataStore.MaxDimensions) then
  2198.     raise EDimensionMapError.CreateFmt(sMaxAllowedDims, [FDataStore.MaxDimensions]);
  2199.   if (FDataStore.DimensionMap.ActiveSummaryCount > FDataStore.MaxSummaries) then
  2200.     raise EDimensionMapError.CreateFmt(sMaxAllowedSums, [FDataStore.MaxSummaries]);
  2201.   { Stop on empty data sets }
  2202.   if FDataStore.DataSet.RecordCount <= 1 then raise ECacheError.Create(sEmptyDataSet);
  2203.   { Determine if we must bin data. }
  2204.   { True : If any of the cube dims are inactive }
  2205.   { True : If the logical data set field mapping does }
  2206.   { not match the SQL field mapping or the physical structure of a table }
  2207.   if (FDataStore.BinData = False) then
  2208.   begin
  2209.     if FDataStore.BinMapHasBinData or (bDataSetMatch = False) then
  2210.       FDataStore.BinData := True;
  2211.   end;
  2212.   {$IFDEF PROFILE}
  2213.   FDataStore.DataCache.FTicks.Ticks('CacheVerification');
  2214.   {$ENDIF}
  2215.   if (csDesigning in FDataStore.ComponentState) and
  2216.   (FDataStore.DesignState = dsNoData) then
  2217.     Exit;
  2218.   {$IFDEF PROFILE}
  2219.   FDataStore.DataCache.FTicks.Ticks('CreateDimensionObjects');
  2220.   {$ENDIF}
  2221.   if DataSet is TBDEDataSet then
  2222.     MXDBLocale := TBDEDataSet(DataSet).Locale
  2223.   else
  2224.     MXDBLocale := nil;
  2225.   DimAllList := TList.Create;
  2226.   { 2. Initialize the dimension and summary objects TDataSet }
  2227.   UpdateDimensions(DimAllList);
  2228.   Assert(FDataStore.DimensionCount >= 1);
  2229.   Assert(FDataStore.SummaryCount > 0);
  2230.   {$IFDEF PROFILE}
  2231.   FDataStore.DataCache.FTicks.Ticks('CreateDimensionObjects');
  2232.   {$ENDIF}
  2233.   if (csDesigning in FDataStore.ComponentState) and
  2234.   (FDataStore.DesignState = dsMetaData) then
  2235.   begin
  2236.     CleanUp;
  2237.     Exit;
  2238.   end;
  2239.   try
  2240.     { 3. Fill the dimension store with unique values and summary data }
  2241.     if not (FDataStore.DataSet is TBDEDataSet) then
  2242.       bHaveBDE := IsBDEAvailable;
  2243.     if (FDataStore.BinData) and (bHaveBDE) then
  2244.       FetchAndBinValues(DimAllList) { Bins values as it scans datasets, used with histograms, will be slower }
  2245.     else
  2246.       FetchValues(DimAllList);
  2247.   {$IFDEF PROFILE}
  2248.   FDataStore.DataCache.FTicks.Ticks('SortAndCompressDimensions');
  2249.   {$ENDIF}
  2250.     { 4.  Sort and compress to unique values the dimension data members. }
  2251.     for i := 0 to FDataStore.DimensionCount-1 do
  2252.     begin
  2253.       Dim := FDataStore.DataCache.Dimensions[i];
  2254.       DimAllVals := DimAllList[i];
  2255.       if (MXDBLocale <> nil) and (Dim.IsString) then
  2256.         Dim.CompareProc := DBCompareString;
  2257.       try
  2258.         Dim.AssignSorted(DimAllVals, True);
  2259.       except
  2260.         on E: ELowCapacityError do
  2261.         begin
  2262.           EAction := eaFail;
  2263.           if not (csDesigning in FDataStore.ComponentState) and
  2264.             Assigned(FDataStore.FOnCapacityError) then FDataStore.FOnCapacityError(EAction);
  2265.           if (EAction = eaFail) then
  2266.           begin
  2267.             Cleanup;
  2268.             raise;
  2269.           end;
  2270.         end
  2271.         else
  2272.         begin
  2273.           FDataStore.DataCache.ErrorCode := 105;
  2274.           CleanUp;
  2275.           raise;
  2276.         end;
  2277.       end;
  2278.     end;
  2279.     if (csDesigning in FDataStore.ComponentState) and
  2280.     (FDataStore.DesignState = dsDimensionData) then
  2281.     begin
  2282.       CleanUp;
  2283.       exit;
  2284.     end;
  2285.  
  2286.   {$IFDEF PROFILE}
  2287.   FDataStore.DataCache.FTicks.Ticks('SortAndCompressDimensions');
  2288.   {$ENDIF}
  2289.   { 5. Create the summary index, precalculate totals if needed }
  2290.   CreateSummaryIndex(DimAllList);
  2291.   FDataStore.DataCache.Success := True;
  2292.  
  2293.   {$IFDEF PROFILE}
  2294.   FDataStore.DataCache.FTicks.NumberOfValues := FDataStore.DataCache.IndexCount;
  2295.   {$ENDIF}
  2296.  
  2297.   finally
  2298.     { 6. cleanup }
  2299.     CleanUp;
  2300.   end;
  2301. end;
  2302.  
  2303. procedure TMultiDimDataLink.UpdateDimensions(DimAllList: TList);
  2304. var
  2305.   I: Integer;
  2306.   DimMap: TCubeDims;
  2307.   Map: TCubeDim;
  2308.   Fld: TField;
  2309.   DimAllVals: TBuilderDim;
  2310.   EAction: TErrorAction;
  2311.  
  2312.   procedure TypeError(Fld: TField);
  2313.   begin
  2314.     raise EUnsupportedTypeError.CreateFMT(sUnsupportedFieldType,
  2315.       [Fld.FieldName, FieldTypeNames[Fld.DataType]]);
  2316.   end;
  2317.  
  2318.   procedure AddDim;
  2319.   var
  2320.     Pos: Integer;
  2321.     fldType: TFieldType;
  2322.   begin
  2323.     Pos := 0;
  2324.     try
  2325.       if (Map.BinType = binSet) then
  2326.         fldType := Map.FBinData.GetBinNameDataType
  2327.       else
  2328.         fldType := Fld.DataType;
  2329.       Pos := AddDimension(Map, Fld);
  2330.       try
  2331.         DimAllVals := TBuilderDim.Create(DataSet.RecordCount, fldType);
  2332.       except
  2333.         on E: ELowCapacityError do
  2334.         begin
  2335.           EAction := eaFail;
  2336.           if not (csDesigning in FDataStore.ComponentState) and
  2337.           Assigned(FDataStore.FOnCapacityError) then
  2338.             FDataStore.FOnCapacityError(EAction);
  2339.           if (EAction = eaFail) then raise;
  2340.         end;
  2341.       end;
  2342.       DimAllVals.FValueList.CompareProc := DBCompareString;
  2343.       DimAllVals.FValueList.SortOrder := tsNone;
  2344.       DimAllVals.Position := Fld.Index;
  2345.       DimAllVals.FieldName := Fld.FieldName;
  2346.     except
  2347.       on EUnsupportedTypeError do TypeError(Fld);
  2348.       else
  2349.       begin
  2350.         FDataStore.DataCache.ErrorCode := 35;
  2351.         raise;
  2352.       end;
  2353.     end;
  2354.     { Sorted according to physical field order }
  2355.     DimAllList.Insert(Pos, DimAllVals);
  2356.   end;
  2357.  
  2358.   procedure AddSum;
  2359.   begin
  2360.     try
  2361.       AddSummary(Map, Fld);
  2362.     except
  2363.       on EUnsupportedTypeError do TypeError(Fld);
  2364.       else
  2365.       begin
  2366.         FDataStore.DataCache.ErrorCode := 36;
  2367.  
  2368.         raise;
  2369.       end;
  2370.     end;
  2371.   end;
  2372.  
  2373. begin
  2374.   Map := nil;
  2375.   DimMap := FDataStore.DimensionMap;
  2376.   { Scan the fields in the data set }
  2377.   for I := 0 to DataSet.FieldCount-1  do
  2378.   begin
  2379.     { Get the TField from the data set }
  2380.     Fld := DataSet.Fields[I];
  2381.     Map := DimMap[i];
  2382.     if (Map.active = True) then
  2383.     begin
  2384.       if Map.IsDimension then
  2385.       begin
  2386.         AddDim;
  2387.       end
  2388.       else
  2389.       begin
  2390.         AddSum;
  2391.       end;
  2392.     end;
  2393.   end;
  2394.   { Add derived summaries }
  2395.   for I := 0 to DimMap.Count-1 do
  2396.     if (DimMap[I].DerivedFrom >= 0) and DimMap[I].IsSummary and dimMap[i].active then
  2397.       AddSummary(DimMap[I], nil);
  2398. end;
  2399.  
  2400. procedure TMultiDimDataLink.FetchValues(DimAllList: TList);
  2401. var
  2402.   flds, mCnt, i: Integer;
  2403.   K: Integer;
  2404.   Summary: TSummary;
  2405.   DimAllVals: TBuilderDim;
  2406.   vNew: Variant;
  2407.   DimMap: TCubeDims;
  2408.   EAction: TErrorAction;
  2409.  
  2410.   function FromFieldPos(Value: Integer): TBuilderDim;
  2411.   var
  2412.     I: Integer;
  2413.     BDim: TBuilderDim;
  2414.   begin
  2415.     Result := nil;
  2416.     for I := 0 to DimAllList.Count-1 do
  2417.     begin
  2418.       BDim := DimAllList[i];
  2419.       if (BDim.Position = Value) then Result := BDim;
  2420.     end;
  2421.   end;
  2422.   
  2423. begin
  2424.   {$IFDEF PROFILE}
  2425.   FDataStore.DataCache.FTicks.Ticks('FetchValues');
  2426.   {$ENDIF}
  2427.   if FDataStore.DataCache.PreCalculateTotals then
  2428.   begin
  2429.     Summary := FDataStore.DataCache.Summaries[FDataStore.CurrentSummary];
  2430.     for K := 0 to FDataStore.DimensionCount-1 do
  2431.     begin
  2432.       DimAllVals := DimAllList[K];
  2433.       DimAllVals.InitSummary(Summary.DataType);
  2434.     end;
  2435.   end;
  2436.   DimMap := FDataStore.DimensionMap;
  2437.   flds := DataSet.FieldCount;
  2438.   if Assigned(ProgressDlg) then
  2439.   begin
  2440.     ProgressDlg.Max := DataSet.RecordCount;
  2441.     ProgressDlg.Caption := sFetchValues;
  2442.   end;
  2443.   with DataSet do
  2444.   begin
  2445.     { Move to the first record in the data set }
  2446.     mCnt := 0;
  2447.     First;
  2448.     with FDataStore.DataCache do
  2449.     begin
  2450.       while not EOF do
  2451.       begin
  2452.         { Update the progress bar }
  2453.         if Assigned(ProgressDlg) then
  2454.         begin
  2455.           if (ProgressDlg.UpdateProgress = -1) then
  2456.             raise EUserCanceled.Create(sUserCanceled);
  2457.         end;
  2458.         { scan all the fields }
  2459.         for i := 0 to flds - 1 do
  2460.         begin
  2461.           { If its a dimension, then attempt to store the value }
  2462.           if (DimMap[i].active = True) then
  2463.           begin
  2464.             try
  2465.             { Get the value from the data set }
  2466.               vNew := FieldValues[Fields[i].FieldName];
  2467.             except
  2468.               ErrorCode := 115;
  2469.               raise;
  2470.             end;
  2471.             if DimMap[i].IsDimension then
  2472.             begin
  2473.               try
  2474.                 { Get the cooresponding dimension for the field in the data set }
  2475.                 DimAllVals := FromFieldPos(Fields[i].Index);
  2476.                 { Assign the data set value to the dimension array }
  2477.                 DimAllVals[mCnt] := vNew;
  2478.                 { See if we are at a group break for the dimension }
  2479.                 if PreCalculateTotals then
  2480.                 begin
  2481.                   if DimAllVals.MatchLastVal(vNew) then
  2482.                     DimAllVals.GroupBreak := False
  2483.                   else
  2484.                     DimAllVals.GroupBreak := True;
  2485.                   DimAllVals.LastVal := vNew;
  2486.                 end;
  2487.               except
  2488.                 ErrorCode := 120;
  2489.                 raise;
  2490.               end;
  2491.             end;
  2492.             if DimMap[i].IsSummary then
  2493.             begin
  2494.               try
  2495.                 { Get the summary object based on the field position in the data set }
  2496.                 Summary := SummaryFromPosition(Fields[i].Index);
  2497.                 { Store the value in the summary object }
  2498.                 Summary[mCnt] := vNew;
  2499.                 { Bin vNew into each dimensions running summary }
  2500.                 if PreCalculateTotals then
  2501.                 begin
  2502.                   for K := 0 to DimensionCount-1 do
  2503.                   begin
  2504.                     DimAllVals := DimAllList[K];
  2505.                     DimAllVals.AddSummary(vNew);
  2506.                   end;
  2507.                 end;
  2508.               except
  2509.                 on E: ELowCapacityError do
  2510.                 begin
  2511.                   EAction := eaFail;
  2512.                   if not (csDesigning in FDataStore.ComponentState) and
  2513.                   Assigned(FDataStore.FOnCapacityError) then
  2514.                     FDataStore.FOnCapacityError(EAction);
  2515.                   if (EAction = eaFail) then raise;
  2516.                 end
  2517.                 else
  2518.                 begin
  2519.                   ErrorCode := 130;
  2520.                   raise;
  2521.                 end;
  2522.               end;
  2523.             end;
  2524.           end;
  2525.         end;
  2526.         { Move to the next record }
  2527.         Inc(mCnt);
  2528.         Next;
  2529.       end;
  2530.     end;
  2531.   end;
  2532.   { Assign format strings }
  2533.   if FDataStore.FDimensionMap.IsDirty then UpdateFormatStrings;
  2534.   {$IFDEF PROFILE}
  2535.   FDataStore.DataCache.FTicks.Ticks('FetchValues');
  2536.   {$ENDIF}
  2537. end;
  2538.  
  2539. procedure TMultiDimDataLink.FetchAndBinValues(DimAllList: TList);
  2540. var
  2541.   mCnt, I, k:   Integer;
  2542.   bGroupBreak: Boolean;
  2543.   Summary:    TSummary;
  2544.   DimAllVals: TBuilderDim;
  2545.   vNew:   Variant;
  2546.   BinTable: TBinTable;
  2547.   DimMap: TCubeDims;
  2548.   EAction: TErrorAction;
  2549.  
  2550.   function FromFieldPos(Value: Integer): TBuilderDim;
  2551.   var
  2552.     I: Integer;
  2553.     BDim: TBuilderDim;
  2554.   begin
  2555.     Result := nil;
  2556.     for I := 0 to DimAllList.Count-1 do
  2557.     begin
  2558.       BDim := DimAllList[i];
  2559.       if (BDim.Position = Value) then Result := BDim;
  2560.     end;
  2561.   end;
  2562.  
  2563.   function FromFieldName(Value: string): TBuilderDim;
  2564.   var
  2565.     J: Integer;
  2566.     BDim: TBuilderDim;    
  2567.   begin
  2568.     Result := nil;    
  2569.     for J := 0 to DimAllList.Count-1 do
  2570.     begin
  2571.       BDim := DimAllList[J];
  2572.       if (BDim.FieldName = Value) then Result := BDim;
  2573.     end;
  2574.   end;
  2575.  
  2576.   procedure CleanUp;
  2577.   begin
  2578.     BinTable.CleanUp;
  2579.     BinTable.Close;
  2580.     BinTable.Free;
  2581.   end;
  2582.  
  2583. begin
  2584.   {$IFDEF PROFILE}
  2585.   FDataStore.DataCache.FTicks.Ticks('FetchAndBinValues');
  2586.   {$ENDIF}
  2587.   if FDataStore.DataCache.PreCalculateTotals then
  2588.   begin
  2589.     Summary := FDataStore.DataCache.Summaries[FDataStore.CurrentSummary];
  2590.     for K := 0 to FDataStore.DimensionCount-1 do
  2591.     begin
  2592.       DimAllVals := DimAllList[K];
  2593.       DimAllVals.InitSummary(Summary.DataType);
  2594.     end;
  2595.   end;
  2596.   BinTable := nil;
  2597.   if Assigned(ProgressDlg) then
  2598.   begin
  2599.     ProgressDlg.Max := DataSet.RecordCount;
  2600.     ProgressDlg.Caption := sBinningValues;
  2601.   end;
  2602.   with DataSet do
  2603.   begin
  2604.     { Move to the first record in the data set }
  2605.     First;
  2606.     mCnt := 0;
  2607.     { Create the bin table once }
  2608.     try
  2609.       BinTable := TBinTable.Create(Application);
  2610.       BinTable.Attach(Self);
  2611.     except
  2612.       FDataStore.DataCache.ErrorCode := 180;
  2613.       raise;
  2614.     end;
  2615.     { Put er in edit mode }
  2616.     BinTable.Edit;
  2617.     { If false, scans the whole table at once. }
  2618.     BinTable.GroupBreak := False;
  2619.     DimMap := BinTable.FDimensionMap;
  2620.     while not EOF do
  2621.     begin
  2622.       bGroupBreak := False;
  2623.       { Scan all the fields in the Data set }
  2624.       { assinging each to the bin table }
  2625.       { Turn Group breaks off if the data set is a table ... to scan and sort the whole table }
  2626.       while not bGroupBreak do
  2627.       begin
  2628.         try
  2629.           { Get the working dimension }
  2630.           bGroupBreak := BinTable.FillRecord(DataSet);
  2631.           { Move to the next record }
  2632.           Next;
  2633.         except
  2634.           FDataStore.DataCache.ErrorCode := 150;
  2635.           CleanUp;
  2636.           raise;
  2637.         end;
  2638.         { Update the progress bar }
  2639.         if Assigned(ProgressDlg) then
  2640.         begin
  2641.           if (ProgressDlg.UpdateProgress = -1) then
  2642.           begin
  2643.             CleanUp;
  2644.             raise EUserCanceled.Create(sUserCanceled);
  2645.           end;
  2646.         end;
  2647.       end;
  2648.       if Assigned(ProgressDlg)then
  2649.       begin
  2650.         ProgressDlg.Max := BinTable.RecordCount;
  2651.         ProgressDlg.Caption := sFetchValues;
  2652.       end;
  2653.       { Scan the bin table }
  2654.       BinTable.First;
  2655.       while not BinTable.EOF do
  2656.       begin
  2657.         { Update the progress bar }
  2658.         if Assigned(ProgressDlg) then
  2659.         begin
  2660.           if (ProgressDlg.UpdateProgress = -1) then
  2661.           begin
  2662.             CleanUp;
  2663.             raise EUserCanceled.Create(sUserCanceled);
  2664.           end;
  2665.         end;
  2666.         for I := 0 to BinTable.FieldCount-1 do
  2667.         begin
  2668.           with FDataStore.DataCache do
  2669.           begin
  2670.             if (DimMap[I].active = True) then
  2671.             begin
  2672.               { Get the value from the data set }
  2673.               vNew := BinTable.FieldValues[BinTable.Fields[i].FieldName];
  2674.               { If its a dimension, then attempt to store the value }
  2675.               if DimMap[I].IsDimension then
  2676.               begin
  2677.                 try
  2678.                   { Get the dimensions }
  2679.                   DimAllVals := FromFieldName(BinTable.Fields[i].FieldName);
  2680.                   { Store the value in the builder dim }
  2681.                   DimAllVals[mCnt] := vNew;
  2682.                   { See if we are at a group break for the dimension }
  2683.                   if PreCalculateTotals then
  2684.                   begin
  2685.                     if DimAllVals.MatchLastVal(vNew) then
  2686.                       DimAllVals.GroupBreak := False
  2687.                     else
  2688.                       DimAllVals.GroupBreak := True;
  2689.                     DimAllVals.LastVal := vNew;
  2690.                   end;
  2691.                 except
  2692.                   ErrorCode := 160;
  2693.                   CleanUp;
  2694.                   raise;
  2695.                 end;
  2696.               end;
  2697.               { Store summary data. }
  2698.               if DimMap[I].IsSummary then
  2699.               begin
  2700.                 try
  2701.                   { Get the summary object based on the field position in the data set }
  2702.                   Summary := SummaryFromFieldName(BinTable.Fields[i].FieldName);
  2703.                   { Store the value in the summary object }
  2704.                   Summary[mCnt] := vNew;
  2705.                   { Bin vNew into each dimensions running summary }
  2706.                   if PreCalculateTotals then
  2707.                   begin
  2708.                     for K := 0 to DimensionCount-1 do
  2709.                     begin
  2710.                       DimAllVals := DimAllList[K];
  2711.                       DimAllVals.AddSummary(vNew);
  2712.                     end;
  2713.                   end;
  2714.                 except
  2715.                   on E: ELowCapacityError do
  2716.                   begin
  2717.                     EAction := eaFail;
  2718.                     if not (csDesigning in FDataStore.ComponentState) and
  2719.                     Assigned(FDataStore.FOnCapacityError) then
  2720.                       FDataStore.FOnCapacityError(EAction);
  2721.                     if (EAction = eaFail) then raise;
  2722.                   end
  2723.                   else
  2724.                   begin
  2725.                     ErrorCode := 170;
  2726.                     CleanUp;
  2727.                     raise;
  2728.                   end;
  2729.                 end;
  2730.               end;
  2731.             end;
  2732.           end;
  2733.         end;
  2734.         BinTable.Next;
  2735.         Inc(mCnt);   { inc the count if one of the dims is on a group break }
  2736.       end;
  2737.       BinTable.EmptyTable;
  2738.     end;
  2739.     { Assign the binData back to the stores DimensionMap }
  2740.     for I := 0 to BinTable.DimensionMap.Count-1 do
  2741.     begin
  2742.       if (BinTable.DimensionMap[I].FieldName = FDataStore.FDimensionMap[I].FieldName) and
  2743.       Assigned(BinTable.DimensionMap[I].BinData) then
  2744.       begin
  2745.         FDataStore.FDimensionMap[I].BinData.Clear;
  2746.         FDataStore.FDimensionMap[I].BinData.Assign(TBinData(BinTable.DimensionMap[I].BinData));
  2747.       end;
  2748.     end;
  2749.     CleanUp;
  2750.   end;
  2751.   { Assign format strings }
  2752.   if FDataStore.FDimensionMap.IsDirty then UpdateFormatStrings;
  2753.   {$IFDEF PROFILE}
  2754.   FDataStore.DataCache.FTicks.Ticks('FetchAndBinValues');
  2755.   {$ENDIF}
  2756. end;
  2757.  
  2758. procedure TMultiDimDataLink.CreateSummaryIndex(DimAllList: TList);
  2759. var
  2760.   i, k, iCnt, idx, sIdx, cRange: Integer;
  2761.   SumIndex, rangeCount: TSmallIntArray;
  2762.   Dim, DimAllVals: TDimension;
  2763.   Summary: TSummary;
  2764.   bSparsed, bGrpBreak: Boolean;
  2765.   SavedActiveSummary: Integer;
  2766.   EAction: TErrorAction;
  2767.  
  2768.   procedure CleanUp;
  2769.   begin
  2770.     rangeCount.Free;
  2771.     SumIndex.Free;
  2772.   end;
  2773.  
  2774.   procedure ShowProgress;
  2775.   begin
  2776.     if Assigned(ProgressDlg) then
  2777.     begin
  2778.       if (ProgressDlg.UpdateProgress = -1) then
  2779.       begin
  2780.         CleanUp;
  2781.         raise EUserCanceled.Create(sUserCanceled);
  2782.       end;
  2783.     end;
  2784.   end;
  2785.  
  2786. begin
  2787.   {$IFDEF PROFILE}
  2788.   FDataStore.DataCache.FTicks.Ticks('CreateSummaryIndex');
  2789.   {$ENDIF}
  2790.   with FDataStore do
  2791.   begin
  2792.     try
  2793.       SumIndex  := TSmallIntArray.Create(DimensionCount, 0);
  2794.       { Create the range counter array }
  2795.       rangeCount := TSmallIntArray.Create(DimensionCount, 0);
  2796.     except
  2797.       FDataStore.DataCache.ErrorCode := 200;
  2798.       raise;
  2799.     end;
  2800.     { Determine the range for each dimension }
  2801.     cRange := 1;
  2802.     for i := DimensionCount-1 downto 0 do
  2803.     begin
  2804.       Dim := DataCache.Dimensions[i];
  2805.       Dim.Range := cRange;
  2806.       cRange := cRange * (Dim.MemberCount + 1);
  2807.     end;
  2808.     if (cRange < 0) then
  2809.     begin
  2810.       Cleanup;
  2811.       raise ECacheError.Create(sDataSetTooLarge);
  2812.     end;
  2813.     try
  2814.       EstimateCapacity(CRange);
  2815.       DataCache.FIndexMap.Capacity := cRange;
  2816.     except
  2817.       on E: ELowCapacityError do
  2818.       begin
  2819.         EAction := eaFail;
  2820.         if not (csDesigning in FDataStore.ComponentState) and
  2821.         Assigned(FDataStore.FOnCapacityError) then
  2822.           FDataStore.FOnCapacityError(EAction);
  2823.         if (EAction = eaFail) then
  2824.         begin
  2825.           CleanUp;
  2826.           raise;
  2827.         end;
  2828.       end
  2829.       else
  2830.       begin
  2831.         FDataStore.DataCache.ErrorCode := 210;
  2832.         CleanUp;
  2833.         raise;
  2834.       end;
  2835.     end;
  2836.     DataCache.FIndexMap.AutoSize := True;
  2837.     { Scan each summary }
  2838.     SavedActiveSummary := DataCache.CurrentSummary;
  2839.     for sIdx := 0 to DataCache.SummaryCount-1 do
  2840.     begin
  2841.       bGrpBreak := False;
  2842.       Summary := DataCache.Summaries[sIdx];
  2843.       { Derived summaries ignored }
  2844.       if Summary.IsDerived then Continue;
  2845.       { If we already have an index at this point, then }
  2846.       { assign FIndexInfo and FIndexMap and continue }
  2847.       Summary.FIndexMap := DataCache.FIndexMap;
  2848.       Summary.FIndexInfo := DataCache.FIndexInfo;
  2849.       if DataCache.HasIndex then Continue;
  2850.       if Assigned(ProgressDlg) then
  2851.       begin
  2852.         ProgressDlg.Max := CRange;
  2853.         ProgressDlg.Caption := Format(sCreatingIndexes, [Summary.FieldName]);
  2854.       end;
  2855.       DataCache.CurrentSummary := sIdx;
  2856.       try
  2857.         for i := 0 to DimensionCount-1 do
  2858.           SumIndex[i] := 0;
  2859.         for i := 0 to DimensionCount-1 do
  2860.           rangeCount[i] := 1; { Fill the rangeCount with 1's }
  2861.       except
  2862.         FDataStore.DataCache.ErrorCode := 220;
  2863.         CleanUp;
  2864.         raise;
  2865.       end;
  2866.       { Expand capacity of objects ... to save later reallocs } 
  2867.       try
  2868.         DataCache.FIndexInfo.Capacity := cRange;
  2869.       except
  2870.         on E: ELowCapacityError do
  2871.         begin
  2872.           EAction := eaFail;
  2873.           if not (csDesigning in FDataStore.ComponentState) and
  2874.           Assigned(FDataStore.FOnCapacityError) then
  2875.             FDataStore.FOnCapacityError(EAction);
  2876.           if (EAction = eaFail) then
  2877.           begin
  2878.             CleanUp;
  2879.             raise;
  2880.           end;
  2881.         end
  2882.         else
  2883.         begin
  2884.           FDataStore.DataCache.ErrorCode := 230;
  2885.           CleanUp;
  2886.           raise;
  2887.         end;
  2888.       end;
  2889.       { Generate the summary index }
  2890.       i := 0;
  2891.       iCnt := 0;
  2892.       while (iCnt < CRange-1) do
  2893.       begin
  2894.         { If a summary does not exist at subindex then add the summary index as sparsed }
  2895.         repeat
  2896.           bSparsed := False;
  2897.           for k := 0 to DimensionCount-1 do
  2898.           begin
  2899.             Dim := DataCache.Dimensions[k];
  2900.             DimAllVals := DimAllList[k];
  2901.             idx := Dim.IndexOf(DimAllVals[i]);
  2902.             if (SumIndex[k] <> idx) then
  2903.             begin
  2904.               bSparsed := True;
  2905.               break;
  2906.             end;
  2907.           end;
  2908.           try
  2909.             iCnt := DataCache.AddIndex(SumIndex, bSparsed);
  2910.           except
  2911.             on E: ELowCapacityError do
  2912.             begin
  2913.               EAction := eaFail;
  2914.               if not (csDesigning in FDataStore.ComponentState) and
  2915.               Assigned(FDataStore.FOnCapacityError) then
  2916.                 FDataStore.FOnCapacityError(EAction);
  2917.               if (EAction = eaFail) then
  2918.               begin
  2919.                 CleanUp;
  2920.                 raise;
  2921.               end;
  2922.             end
  2923.             else
  2924.             begin
  2925.               FDataStore.DataCache.ErrorCode := 240;
  2926.               CleanUp;
  2927.               raise;
  2928.             end;
  2929.           end;
  2930.           if (DataCache.IncSummaryIndex(Summary, SumIndex, rangeCount, bGrpBreak) = False) then
  2931.           begin
  2932.             { Make sure that we are subtotaling on non-sparse data. }
  2933.             if DataCache.HasValidSubTotals(Summary, SumIndex) then
  2934.             begin
  2935.               repeat
  2936.                 try
  2937.                   iCnt := DataCache.AddAggIndex(SumIndex, DimAllList);
  2938.                 except
  2939.                   on E: ELowCapacityError do
  2940.                   begin
  2941.                     EAction := eaFail;
  2942.                     if not (csDesigning in FDataStore.ComponentState) and
  2943.                     Assigned(FDataStore.FOnCapacityError) then
  2944.                       FDataStore.FOnCapacityError(EAction);
  2945.                     if (EAction = eaFail) then
  2946.                     begin
  2947.                       CleanUp;
  2948.                       raise;
  2949.                     end;
  2950.                   end
  2951.                   else
  2952.                   begin
  2953.                     FDataStore.DataCache.ErrorCode := 250;
  2954.                     CleanUp;
  2955.                     raise;
  2956.                   end;
  2957.                 end;
  2958.                 ShowProgress;
  2959.               until DataCache.IncSummaryIndex(Summary, SumIndex, rangeCount, bGrpBreak);  { Break out when theres not a sub total }
  2960.             end;
  2961.           end;
  2962.           { Update the progress bar }
  2963.           ShowProgress;
  2964.           if (iCnt = CRange) then Break;
  2965.         until not bSparsed;
  2966.         if (i < Summary.MemberCount-1) then Inc(i);
  2967.       end;
  2968.       DataCache.HasIndex := True;
  2969.       Summary.FIndexMap := DataCache.FIndexMap;
  2970.     end;
  2971.     DataCache.CurrentSummary := SavedActiveSummary;
  2972.     CleanUp;
  2973.   end;
  2974.   {$IFDEF PROFILE}
  2975.   FDataStore.DataCache.FTicks.Ticks('CreateSummaryIndex');
  2976.   {$ENDIF}
  2977. end;
  2978.  
  2979. function TMultiDimDataLink.EstimateCapacity(RangeCnt: Integer): Integer;
  2980. var
  2981.   I, TotalSize, iIndexMap: Integer;
  2982. begin
  2983.   iIndexMap := 0;
  2984.   with FDataStore do
  2985.   begin
  2986.     for I := 0 to DimensionCount-1 do
  2987.     begin
  2988.       Inc(iIndexMap, sizeof(TSmallIntArray));
  2989.     end;
  2990.     TotalSize := (RangeCnt * iIndexMap);
  2991.     TotalSize := TotalSize + GetMemoryUsage;
  2992.   end;
  2993.   Result := TotalSize;
  2994.   if (Result < 0) or (Result > FDataStore.Capacity) then
  2995.     raise ELowCapacityError.Create(sLowCapacityError);
  2996. end;
  2997.  
  2998. function TMultiDimDataLink.AddDimension(DimMap: TCubeDim; Fld: TField): Integer;
  2999. var
  3000.   Dim: TDimension;
  3001.   fldType: TFieldType;
  3002. begin
  3003.   if (DimMap.BinType = binSet) then
  3004.     fldType := DimMap.FBinData.GetBinNameDataType
  3005.   else
  3006.     fldType := Fld.DataType;
  3007.   Dim := TDimension.Create(1, fldType);
  3008.   { Set info from TCubeDim, user configurable settings }
  3009.   Dim.SetFlag(DimMap.DimensionType);
  3010.   { Set info from the TField object }
  3011.   Dim.Position := Fld.Index;
  3012.   Dim.FieldName := Fld.FieldName;
  3013.   Dim.FieldDefinition.Width := Fld.DisplayWidth;
  3014.   Dim.FieldDefinition.FieldType := fldType;
  3015.   Dim.FieldDefinition.Precision := GetPrecision(fld);
  3016.   Dim.FieldDefinition.FieldNo := Fld.FieldNo;
  3017.   { Get any pre-existing display formats }
  3018.   if Assigned(DimMap) and (DimMap.Format <> '') then
  3019.     Dim.FieldDefinition.FormatString := DimMap.Format
  3020.   else
  3021.     Dim.FieldDefinition.FormatString := GetDisplayFormat(Fld);
  3022.   Result := FDataStore.DataCache.AppendDimension(Dim);
  3023. end;
  3024.  
  3025. procedure TMultiDimDataLink.AddSummary(DimMap: TCubeDim; Fld: TField);
  3026. var
  3027.   Summary, derivedSummary: TSummary;
  3028.   derivedIdx: Integer;
  3029. begin
  3030.   { Block string types }
  3031.   if (Assigned(Fld)) and (Fld.DataType = ftString) then
  3032.     raise EUnsupportedTypeError.Create(sStringTypeNoSupported);
  3033.   if (DimMap.DerivedFrom < 0) then
  3034.     Summary := TSummary.Create(DataSet.RecordCount, Fld.DataType)
  3035.   else
  3036.     Summary := TSummary.Create(1, ftFloat);
  3037.   { Set info from TCubeDim, user configurable settings }
  3038.   Summary.SetFlag(DimMap.DimensionType);
  3039.   if (DimMap.DerivedFrom < 0) then
  3040.   begin
  3041.     { Set info from Tfield }
  3042.     Summary.Position := Fld.Index;
  3043.     Summary.FieldName := Fld.FieldName;
  3044.     Summary.CubeDimIndex := DimMap.Index;
  3045.     Summary.FSumMethod := FDataStore.DataCache.GetBaseSummary;
  3046.     { Get formatting info }
  3047.     Summary.FieldDefinition.Width := Fld.DisplayWidth;
  3048.     Summary.FieldDefinition.FieldType := Fld.DataType;
  3049.     Summary.FieldDefinition.Precision := GetPrecision(fld);
  3050.     Summary.FieldDefinition.FieldNo := Fld.FieldNo;
  3051.     if (DimMap.Format <> '') then
  3052.       Summary.FieldDefinition.FormatString := DimMap.Format
  3053.     else
  3054.       Summary.FieldDefinition.FormatString := GetDisplayFormat(Fld);
  3055.   end
  3056.   else
  3057.   begin
  3058.     { Define the agg fields, if we can not then raise error }
  3059.     if not Summary.SetAggregator(DimMap.BaseName, FDataStore.FDimensionMap, DimMap.DimensionType, derivedIdx) then
  3060.     begin
  3061.       Summary.Free;
  3062.       raise ECacheError.Create(sCreateDerivedSummaryError);
  3063.     end;
  3064.     Summary.Position := -1;  { Signifies its a derived summary }
  3065.     Summary.Name := DimMap.FieldName;
  3066.     Summary.FieldName := DimMap.BaseName;
  3067.     Summary.CubeDimIndex := DimMap.Index;
  3068.     { Get formatting info from the derived field }
  3069.     derivedSummary := FDataStore.DataCache.SummaryFromCubeDimIndex(derivedIdx);
  3070.     Summary.FieldDefinition.Width := derivedSummary.FieldDefinition.Width;
  3071.     Summary.FieldDefinition.FieldType := derivedSummary.FieldDefinition.FieldType;
  3072.     Summary.FieldDefinition.Precision := derivedSummary.FieldDefinition.Precision;
  3073.     Summary.FieldDefinition.FormatString := derivedSummary.FieldDefinition.FormatString;
  3074.     Summary.FSumMethod := FDataStore.DataCache.GetAggSummary;
  3075.   end;
  3076.   FDataStore.DataCache.AppendSummary(Summary);
  3077. end;
  3078.  
  3079. procedure TMultiDimDataLink.UpdateFormatStrings;
  3080. var
  3081.   I: Integer;
  3082.   Dim: TDimension;
  3083. begin
  3084.   with FDataStore do
  3085.   begin
  3086.     for I := 0 to DimensionMap.Count-1 do
  3087.     begin
  3088.       if DimensionMap[I].IsDimension then
  3089.       begin
  3090.         Dim := FDataStore.DataCache.DimensionFromFieldName(DataSet.Fields[I].FieldName);
  3091.         if (Dim = nil) then Continue;
  3092.         if (DimensionMap[I].Format <> '') then
  3093.           Dim.FieldDefinition.FormatString := DimensionMap[I].Format;
  3094.         if DimensionMap[I].IsBinData then
  3095.           Dim.FieldDefinition.FormatString := DimensionMap[I].FBinFormat;
  3096.       end;
  3097.     end;
  3098.   end;
  3099. end;
  3100.  
  3101. {
  3102.  ActiveChanged
  3103.  
  3104.  Synopsis :
  3105.    Called from the data set whenever the data sets Active property gets changed, that
  3106.    includes at form startup
  3107.  
  3108.  Parameters :
  3109.  
  3110.  Return value :
  3111. }
  3112.  
  3113. procedure TMultiDimDataLink.ActiveChanged;
  3114. begin
  3115.   FDataStore.SetActive(Self.Active);
  3116. end;
  3117.  
  3118. {
  3119.  LayoutChanged
  3120.  
  3121.  Synopsis :
  3122.     Called from the data set whenever a column changes. Rebuild the cube.
  3123.  
  3124.  Parameters :
  3125.  
  3126.  Return value :
  3127. }
  3128. procedure TMultiDimDataLink.LayoutChanged;
  3129. begin
  3130. end;
  3131.  
  3132.   { TDataCache }
  3133.  
  3134. constructor TDataCache.Create;
  3135. begin
  3136.   inherited Create;
  3137.   FDimensions := nil;
  3138.   FSummaryData := nil;
  3139.   FActiveSummary := 0;
  3140.   Include(FCalcTotals, ctNone);
  3141.   FAggProc := CalcTotals1;
  3142. end;
  3143.  
  3144. destructor TDataCache.Destroy;
  3145. begin
  3146.   FreeCache;
  3147.   inherited Destroy;
  3148. end;
  3149.  
  3150. procedure TDataCache.Init;
  3151. begin
  3152.   {$IFDEF PROFILE}
  3153.   FTicks := TTicks.Create(FProfileLogFile);
  3154.   {$ENDIF}
  3155.   ErrorCode := 0;
  3156.   if not Assigned(FDimensions) then FDimensions := TList.Create;
  3157.   if not Assigned(FSummaryData) then FSummaryData := TList.Create;
  3158.   if not Assigned(FIndexMap) then FIndexMap := TIndexArray.Create;
  3159.   if not Assigned(FIndexInfo) then FIndexInfo := TIndexInfo.Create;
  3160. end;
  3161.  
  3162. procedure TDataCache.FreeCache;
  3163. var
  3164.   Dim: TDimension;
  3165.   Summary: TSummary;
  3166. begin
  3167.   {$IFDEF PROFILE}
  3168.   if Assigned(FTicks) then FTicks.Ticks('FreeCache');
  3169.   {$ENDIF}
  3170.   if Assigned(FDimensions) then
  3171.   begin
  3172.     while (FDimensions.Count > 0) do
  3173.     begin
  3174.       Dim := FDimensions.Last;
  3175.       FDimensions.Remove(Dim);
  3176.       Dim.Free;
  3177.     end;
  3178.     FDimensions.Free;
  3179.     FDimensions := nil;
  3180.   end;
  3181.   if Assigned(FSummaryData) then
  3182.   begin
  3183.     while (FSummaryData.Count > 0) do
  3184.     begin
  3185.       Summary := FSummaryData.Last;
  3186.       FSummaryData.Remove(Summary);
  3187.       Summary.Free;
  3188.     end;
  3189.     FSummaryData.Free;
  3190.     FSummaryData := nil;
  3191.   end;
  3192.   if Assigned(FIndexMap) then
  3193.   begin
  3194.     FIndexMap.Free;
  3195.     FIndexMap := nil;
  3196.     HasIndex := False;
  3197.   end;
  3198.   if Assigned(FIndexInfo) then
  3199.   begin
  3200.     FIndexInfo.Free;
  3201.     FIndexInfo := nil;
  3202.   end;
  3203.   FActiveSummary := 0;
  3204.   {$IFDEF PROFILE}
  3205.   if Assigned(FTicks) then FTicks.Ticks('FreeCache');
  3206.   {$ENDIF}
  3207.   {$IFDEF PROFILE}
  3208.   if Assigned(FTicks) then
  3209.   begin
  3210.     FTicks.Free;
  3211.     FTicks := nil;
  3212.   end;
  3213.   {$ENDIF}
  3214. end;
  3215.  
  3216. function TDataCache.GetDimensionCount: Integer;
  3217. begin
  3218.   if Assigned(FDimensions) then
  3219.     Result := FDimensions.Count
  3220.   else
  3221.     Result := 0;
  3222. end;
  3223.  
  3224. function TDataCache.GetSummaryCount: Integer;
  3225. begin
  3226.   if Assigned(FSummaryData) then
  3227.     Result := FSummaryData.Count
  3228.   else
  3229.     Result := 0;
  3230. end;
  3231.  
  3232. function TDataCache.GetDimension(Index: Integer): TDimension;
  3233. begin
  3234.   if Assigned(FDimensions) then
  3235.     Result := FDimensions[Index]
  3236.   else
  3237.     Result := nil;
  3238. end;
  3239.  
  3240. procedure TDataCache.SetDimension(Index: Integer; Value: TDimension);
  3241. begin
  3242.   FDimensions.Insert(Index, Value);
  3243. end;
  3244.  
  3245. function TDataCache.GetSummary(Index: Integer): TSummary;
  3246. begin
  3247.   if Assigned(FSummaryData) then
  3248.     Result := FSummaryData[Index]
  3249.   else
  3250.     Result := nil;
  3251. end;
  3252.  
  3253. function TDataCache.AppendDimension(Value: TDimension): Integer;
  3254. var
  3255.   I: Integer;
  3256. begin
  3257.   Result := -1;
  3258.   { Dimensions must be sorted by the FieldNo in the physical table }
  3259.   for I := 0 to FDimensions.Count-1 do
  3260.   begin
  3261.     if (Value.Position > TDimension(FDimensions[I]).Position) then
  3262.     begin
  3263.       Continue;
  3264.     end
  3265.     else if (Value.Position < TDimension(FDimensions[I]).Position) then
  3266.     begin
  3267.       Result := FDimensions.Add(Value);
  3268.       FDimensions.Exchange(Result, I);
  3269.       Result := I;
  3270.       break;
  3271.     end;
  3272.   end;
  3273.   if (Result = -1) then Result := FDimensions.Add(Value);
  3274. end;
  3275.  
  3276. function TDataCache.AppendSummary(Value: TSummary): Integer;
  3277. var
  3278.   I: Integer;
  3279. begin
  3280.   Result := -1;
  3281.   if (Value.Position = -1) then
  3282.   begin
  3283.     Result := FSummaryData.Add(Value);
  3284.     Exit;
  3285.   end;
  3286.   { summaries must be sorted by the FieldNo in the physical table }
  3287.   for I := 0 to FSummaryData.Count-1 do
  3288.   begin
  3289.     if (Value.Position > TDimension(FSummaryData[I]).Position) then
  3290.     begin
  3291.       Continue;
  3292.     end
  3293.     else if (Value.Position < TDimension(FSummaryData[I]).Position) then
  3294.     begin
  3295.       Result := FSummaryData.Add(Value);
  3296.       FSummaryData.Exchange(Result, I);
  3297.       Result := I;
  3298.       break;
  3299.     end;
  3300.   end;
  3301.   if (Result = -1) then Result := FSummaryData.Add(Value);
  3302. end;
  3303.  
  3304. function TDataCache.IsDimension(Position: Integer): Boolean;
  3305. var
  3306.   i: Integer;
  3307.   Dim: TDimension;
  3308.   foundIt: Boolean;
  3309. begin
  3310.   foundIt := False;
  3311.   for i := 0 to FDimensions.Count-1 do
  3312.   begin
  3313.     Dim := GetDimension(i);
  3314.     if (Dim.Position = Position) then foundIt := True;
  3315.   end;
  3316.   Result := foundIt;
  3317. end;
  3318.  
  3319. function TDataCache.IsSummary(Position: Integer): Boolean;
  3320. var
  3321.   i: Integer;
  3322.   Summary: TSummary;
  3323.   foundIt: Boolean;
  3324. begin
  3325.   foundIt := False;
  3326.   for i := 0 to FSummaryData.Count-1 do
  3327.   begin
  3328.     Summary := GetSummary(i);
  3329.     if (Summary.Position = Position) then foundIt := True;
  3330.   end;
  3331.   Result := foundIt;
  3332. end;
  3333.  
  3334. function TDataCache.SummaryFromPosition(Position: Integer): TSummary;
  3335. var
  3336.   i: Integer;
  3337.   Summary: TSummary;
  3338. begin
  3339.   Result := nil;
  3340.   for i := 0 to FSummaryData.Count-1 do
  3341.   begin
  3342.     Summary := GetSummary(i);
  3343.     if (Summary.Position = Position) then Result := Summary;
  3344.   end;
  3345. end;
  3346.  
  3347. function TDataCache.SummaryFromFieldName(FldName: string): TSummary;
  3348. var
  3349.   i: Integer;
  3350.   Summary: TSummary;
  3351. begin
  3352.   Result := nil;
  3353.   for i := 0 to FSummaryData.Count-1 do
  3354.   begin
  3355.     Summary := GetSummary(i);
  3356.     if (Summary.FieldName = FldName) then Result := Summary;
  3357.   end;
  3358. end;
  3359.  
  3360. function TDataCache.SummaryFromCubeDimIndex(Index: Integer): TSummary;
  3361. var
  3362.   i: Integer;
  3363.   Summary: TSummary;
  3364. begin
  3365.   Result := nil;
  3366.   for i := 0 to FSummaryData.Count-1 do
  3367.   begin
  3368.     Summary := GetSummary(i);
  3369.     if (Summary.CubeDimIndex = Index) then Result := Summary;
  3370.   end;
  3371. end;
  3372.  
  3373. function TDataCache.GetSummaryName(ISum: Integer): String;
  3374. var
  3375.   Summary: TSummary;
  3376. begin
  3377.   if Assigned(FSummaryData) then
  3378.   begin
  3379.     Summary := FSummaryData[ISum];
  3380.     Result := Summary.Name;
  3381.   end
  3382.   else
  3383.     Result := '';
  3384. end;
  3385.  
  3386. function TDataCache.GetDimensionName(DimIndex: Integer): String;
  3387. var
  3388.   Dim: TDimension;
  3389. begin
  3390.   if Assigned(FDimensions) then
  3391.   begin
  3392.     Dim := FDimensions[DimIndex];
  3393.     Result := Dim.DimensionName;
  3394.   end
  3395.   else
  3396.     Result := '';
  3397. end;
  3398.  
  3399. function TDataCache.GetDimensionMember(DimIndex, MemberIndex: Integer): String;
  3400. var
  3401.   Dim: TDimension;
  3402.   V: Variant;
  3403. begin
  3404.   Result := '';
  3405.   if Assigned(FDimensions) then
  3406.   begin
  3407.     Dim := FDimensions[DimIndex];
  3408.     if Dim.IsBlank(MemberIndex) then Exit;
  3409.     V := Dim[MemberIndex];
  3410.     Result := V;
  3411.     if (VarType(V) <> varString) then
  3412.       Result := Dim.FieldDefinition.FormatVariantToStr(V);
  3413.   end;
  3414. end;
  3415.  
  3416. function TDataCache.GetDimensionMemberAsVariant(DimIndex, MemberIndex: Integer): Variant;
  3417. var
  3418.   Dim: TDimension;
  3419.   V: Variant;
  3420. begin
  3421.   if Assigned(FDimensions) then
  3422.   begin
  3423.     Dim := FDimensions[DimIndex];
  3424.     if Dim.IsBlank(MemberIndex) then Exit;
  3425.     V := Dim[MemberIndex];
  3426.     if (VarType(V) <> varString) then
  3427.       Dim.FieldDefinition.FormatVariantToStr(V);
  3428.   end;
  3429.   Result := V;
  3430. end;
  3431.  
  3432. function TDataCache.GetDimensionMemberCount(DimIndex: Integer): Integer;
  3433. var
  3434.   Dim: TDimension;
  3435. begin
  3436.   if Assigned(FDimensions) then
  3437.   begin
  3438.     Dim := FDimensions[DimIndex];
  3439.     Result := Dim.MemberCount;
  3440.   end
  3441.   else
  3442.     Result := 0;
  3443. end;
  3444.  
  3445. function TDataCache.HasSubTotals(SumIndex: TSmallIntArray): Boolean;
  3446. var
  3447.   i: Integer;
  3448. begin
  3449.   Result := False;
  3450.   for i := 0 to SumIndex.Count-1 do
  3451.   begin
  3452.     if (SumIndex[i] = SubTotal) then
  3453.     begin
  3454.       Result := True;
  3455.       break;
  3456.     end;
  3457.   end;
  3458. end;
  3459.  
  3460. function TDataCache.HasValidSubTotals(Summary: TSummary ; SumIndex: TSmallIntArray): Boolean;
  3461. var
  3462.   i, j, iCount: Integer;
  3463.   Dim: TDimension;
  3464. begin
  3465.   Result := False;
  3466.   for i := 0 to SumIndex.Count-1 do
  3467.   begin
  3468.     if (SumIndex[i] = SubTotal) then
  3469.     begin
  3470.       Dim := Dimensions[i];
  3471.       iCount := (IndexCount-1) - (Dim.Range * (Dim.MemberCount-1));
  3472.       if (iCount < 0) then iCount := 0;
  3473.       for j := Summary.FIndexInfo.Count-1 downto iCount do
  3474.       begin
  3475.         { Exit on the first non-sparsed index }
  3476.         if not Summary.FIndexInfo.IsSparse(j) then
  3477.         begin
  3478.           Result := True;
  3479.           Exit;
  3480.         end;
  3481.       end;
  3482.     end;
  3483.   end;
  3484. end;
  3485.  
  3486. procedure TDataCache.GetScope(var OffsetIdx, AggIdx, AggRange: Integer; SumIndex: TSmallIntArray);
  3487. var
  3488.   i, lastDim, AggCnt: Integer;
  3489.   Dim: TDimension;
  3490.   bContigousIdx, bIdx: Boolean;
  3491. begin
  3492.   AggCnt := 0;
  3493.   AggRange := 0;
  3494.   AggIdx := 1;    { Used by agg indexes }
  3495.   OffsetIdx := 0;    { Used by non-agg indexes }
  3496.   bContigousIdx := False;
  3497.   bIdx := True;
  3498.   lastDim := DimensionCount-1;
  3499.   for i := lastDim downto 0 do
  3500.   begin
  3501.     Dim := Dimensions[i];
  3502.     if (SumIndex[i] <> SubTotal) then
  3503.     begin
  3504.       bIdx := False;
  3505.       AggIdx := AggIdx + (Dim.Range * SumIndex[i]);
  3506.       OffsetIdx := OffsetIdx + (Dim.Range * SumIndex[i]);
  3507.     end
  3508.     else
  3509.     begin
  3510.       Inc(AggCnt);
  3511.       if (bIdx = False) then
  3512.         bContigousIdx := False
  3513.       else
  3514.         bContigousIdx := True;
  3515.       if (i > 0) then AggRange := Dimensions[i-1].Range-1;
  3516.       if (i = lastDim) then
  3517.         AggIdx := AggIdx * (Dim.MemberCount + 1)
  3518.       else
  3519.         AggIdx := AggIdx + (Dim.Range * Dim.MemberCount);
  3520.     end;
  3521.   end;
  3522.   if (AggCnt > 0) then
  3523.   begin
  3524.     OffsetIdx := -1;
  3525.     Dec(AggIdx);
  3526.     if (bContigousIdx and (AggCnt <> DimensionCount)) then
  3527.       FAggProc := CalcTotals2
  3528.     else
  3529.       FAggProc := CalcTotals1;
  3530.   end;
  3531. end;
  3532.  
  3533. function TDataCache.IncSummaryIndex(Summary: TSummary; SumIndex, rangeCount: TSmallIntArray; var bGroupBreak: Boolean): Boolean;
  3534. var
  3535.   Dim: TDimension;
  3536.   dmIdx, sumLimit,
  3537.   i, range: Integer;
  3538. begin
  3539.   bGroupBreak := False;
  3540.   { Scan the summary index, from the dimension with the most detail to the dimension with the least }
  3541.   sumLimit := SumIndex.Count-1;
  3542.   for i := sumLimit downto 0 do
  3543.   begin
  3544.     Dim := FDimensions[i];
  3545.     { Get the index to the dimensions data member }
  3546.     dmIdx := SumIndex[i];
  3547.     { Get the range (group) where all data members are the same }
  3548.     range := Dim.Range;
  3549.     { Try incrementing the index }
  3550.     if (rangeCount[i] >= range) or (range = 1) then
  3551.     begin
  3552.       bGroupBreak := True;
  3553.       Inc(dmIdx);
  3554.       rangeCount[i] := 1;
  3555.       if (range = 1) then
  3556.       begin
  3557.         if dmIdx >= Dim.MemberCount then dmIdx := SubTotal;
  3558.       end
  3559.       else
  3560.       begin
  3561.         if (dmIdx >= Dim.MemberCount) then dmIdx := SubTotal;
  3562.       end;
  3563.     end
  3564.     else
  3565.       rangeCount[i] := Succ(rangeCount[i]);
  3566.     SumIndex[i] := dmIdx;
  3567.   end;
  3568.   Result := not HasSubTotals(SumIndex);
  3569. end;
  3570.  
  3571. function TDataCache.GetAggSummary(SumIndex: TSmallIntArray; Summary: TSummary; var Value: Variant): Boolean;
  3572. var
  3573.   sum1, sum2: TSummary;
  3574.   val1, val2: Variant;
  3575. begin
  3576.   { For each field, get the summary value }
  3577.   sum1 := SummaryFromCubeDimIndex(Summary.AggDefinition.FSummaryIdx[0]);
  3578.   Result := GetBaseSummary(SumIndex, sum1, val1);
  3579.   if (Result = False) then Exit;
  3580.   { For each field, get the summary value }
  3581.   sum2 := SummaryFromCubeDimIndex(Summary.AggDefinition.FSummaryIdx[1]);
  3582.   Result := GetBaseSummary(SumIndex, sum2, val2);
  3583.   if (Result = False) then Exit;
  3584.   Value := Summary.AggDefinition.AggProc(val1, val2);
  3585. end;
  3586.  
  3587. function TDataCache.GetBaseSummary(SumIndex: TSmallIntArray; Summary: TSummary; var Value: Variant): Boolean;
  3588. var
  3589.   offsetIndex, aggIndex, iOffSet, aggRange: Integer;
  3590. begin
  3591.   Result := False;
  3592.   GetScope(offsetIndex, aggIndex, aggRange, SumIndex);
  3593.   if (offsetIndex = SubTotal) then
  3594.     Result := FAggProc(aggIndex, aggRange, Summary, SumIndex, Value)
  3595.   else
  3596.   begin
  3597.     iOffset := Summary.FIndexInfo.FOffset[offsetIndex];
  3598.     if not Summary.FIndexInfo.IsSparse(offsetIndex) then
  3599.     begin
  3600.       Value := Summary[iOffSet];
  3601.       Result := True;
  3602.     end;
  3603.   end;
  3604. end;
  3605.  
  3606. function TDataCache.GetSummaryAsString(SumIndex: TSmallIntArray): String;
  3607. var
  3608.   Summary: TSummary;
  3609.   V: Variant;
  3610.   bValue: Boolean;
  3611. begin
  3612.   {$IFDEF PROFILE}
  3613.   FTicks.TicksSmallIntArray('GetSummaryAsString', SumIndex);
  3614.   {$ENDIF}
  3615.   Result := '';
  3616.   if not Assigned(FSummaryData) then Exit;
  3617.   Summary := FSummaryData[CurrentSummary];
  3618.   bValue := Summary.SumMethod(SumIndex, Summary, V);
  3619.   if bValue then Result := Summary.FieldDefinition.FormatVariantToStr(V);
  3620.   {$IFDEF PROFILE}
  3621.   FTicks.TicksSmallIntArray('GetSummaryAsString', SumIndex);
  3622.   {$ENDIF}
  3623. end;
  3624.  
  3625. function TDataCache.GetSummaryAsVariant(SumIndex: TSmallIntArray): Variant;
  3626. var
  3627.   Summary: TSummary;
  3628.   V: Variant;
  3629.   bValue: Boolean;
  3630. begin
  3631.   if not Assigned(FSummaryData) then Exit;
  3632.   Summary := FSummaryData[CurrentSummary];
  3633.   Result := VarAsType(0, Summary.DataType);
  3634.   bValue := Summary.SumMethod(SumIndex, Summary, V);
  3635.   if bValue then Result := V;
  3636. end;
  3637.  
  3638. function TDataCache.IsIndexSparse(SumIndex: TSmallIntArray): Boolean;
  3639. var
  3640.   Summary: TSummary;
  3641.   V: Variant;
  3642.   bValue: Boolean;
  3643. begin
  3644.   Summary := FSummaryData[CurrentSummary];
  3645.   bValue := Summary.SumMethod(SumIndex, Summary, V);
  3646.   Result := not bValue;
  3647. end;
  3648. {
  3649.  GetDomain
  3650.  
  3651.  Synopsis :
  3652.  GetDomain is called once for Rows and Columns.
  3653.  
  3654.  Parameters :
  3655.             DimensionIds [In] The array of dimension ID's
  3656.             Coord     [In]
  3657.             ATotals   [In] Turn On/Off the sum of rows or columns
  3658.             Domain    [Out] The lookup array used by by the client
  3659.  
  3660.  Return value : The # of columns or rows Contained in the slice
  3661. }
  3662. function TDataCache.GetDomain(DimensionIDs: TIntArray; nDims: Integer; ATotals: Boolean; Domain: TTwoDimArray): Integer;
  3663. var
  3664.   I,
  3665.   Index,                      { A row or column # depending on the context }
  3666.   DimID,                      { The dimension ID }
  3667.   IDim,                       { The row/col dimension index, 0 is the first dim, 1 is the second ... }
  3668.   DMember,                    { The dimension member }
  3669.   LastDMember,                { The number for the last dimension member }
  3670.   MaxDim,
  3671.   Range: Integer;
  3672.   bSparse, bNewIndex: Boolean;
  3673.   Dim: TDimension;
  3674.   SumIndex: TSmallIntArray;
  3675.   savedCursor: TCursor;
  3676.  
  3677.   procedure InitIndex;
  3678.   var
  3679.     j: Integer;
  3680.   begin
  3681.     SumIndex := TSmallIntArray.Create(DimensionCount, 0);
  3682.     for j:= 0 to DimensionCount-1 do
  3683.       SumIndex[j] := SubTotal;
  3684.   end;
  3685.  
  3686.   function GetRange: Integer;
  3687.   var
  3688.     cRange, K: Integer;
  3689.     DimR: TDimension;
  3690.   begin
  3691.     { Determine the range for each dimension }
  3692.     cRange := 1;
  3693.     for K := DimensionIDs.Count-1 downto 0 do
  3694.     begin
  3695.       DimR := FDimensions[DimensionIds[K]];
  3696.       cRange := cRange * (DimR.MemberCount + 1);
  3697.     end;
  3698.     Result := CRange;
  3699.   end;
  3700.  
  3701. begin
  3702.   Index := 0;
  3703.   savedCursor := 0;
  3704.   {$IFDEF PROFILE}
  3705.   FTicks.TicksIntArray('BuildLookups', DimensionIDs);
  3706.   {$ENDIF}
  3707.   if (DimensionIDs.Count > 0) then
  3708.   begin
  3709.     try
  3710.       savedCursor := screen.Cursor;
  3711.       Screen.Cursor := crHourglass;
  3712.       { Set the size of the lookup }
  3713.       Assert(Assigned(Domain));
  3714.       Range := GetRange;
  3715.       Domain.SetSize(DimensionIds.Count, Range);
  3716.       { Get the ID for the dimension from a row or col array }
  3717.       IDim := 0;
  3718.       DimID := DimensionIds[IDim];       { Get the first dimension ID }
  3719.       { Get the dimension range, from 0 to n.Count }
  3720.       Dim := FDimensions[DimID];
  3721.       DMember := 0;
  3722.       LastDMember := Dim.MemberCount;
  3723.       MaxDim := DimensionIDs.Count - 1;  { The dimension count for this row or column }
  3724.       bNewIndex := False;
  3725.       bSparse  := False;
  3726.       { Check for summaries with all blank values }
  3727.       if Sparsing then Sparsing := not IsBlankSummary;
  3728.       if Sparsing then InitIndex;
  3729.       repeat
  3730.       { Scan all the members for the dimension, from 0 to n.Count-1 }
  3731.         while (DMember < LastDMember) do
  3732.         begin
  3733.           if Sparsing then
  3734.           begin
  3735.             { Assign a data point to the active dimension. }
  3736.             SumIndex[DimID] := DMember;
  3737.             bSparse := IsIndexSparse(SumIndex);
  3738.           end;
  3739.           { If found a non sparsed value then assign the member to the lookup }
  3740.           if not bSparse then
  3741.           begin
  3742.             if bNewIndex then
  3743.             begin
  3744.               bNewIndex := False;
  3745.               Inc(Index);
  3746.               for I:= 0 to IDim-1 do
  3747.                 Domain[I,Index] := Domain[I,Index-1];
  3748.             end;
  3749.             Domain[IDim,Index] := DMember;
  3750.           end;
  3751.           { Move to a new dimension or data member }
  3752.           if (IDim < MaxDim) then
  3753.           begin
  3754.             { Increment to the next dimension, and get its member range }
  3755.             if not bSparse then
  3756.             begin
  3757.               Inc(IDim);
  3758.               DimID := DimensionIds[IDim];
  3759.               Dim := FDimensions[DimID];
  3760.               DMember := 0;
  3761.               LastDMember := Dim.MemberCount;
  3762.             end
  3763.             else
  3764.             begin
  3765.               Inc(DMember);
  3766.               Continue;
  3767.             end;
  3768.           end
  3769.           else
  3770.           begin
  3771.            { Increment to the next dimension member }
  3772.             Inc(DMember);
  3773.             if not bSparse then bNewIndex := True;
  3774.           end;
  3775.         end;  { scaning the dimension members }
  3776.         { Assign sub-totals }
  3777.         if Sparsing then SumIndex[DimID] := SubTotal;
  3778.         if ATotals then
  3779.         begin
  3780.           Inc(Index);
  3781.           for I := 0 to IDim-1 do
  3782.             Domain[I,Index] := Domain[I,Index-1];
  3783.           for I := IDim to MaxDim do
  3784.             Domain[I,Index] := SubTotal;
  3785.         end;
  3786.         if (IDim = 0) then break;
  3787.         { move to the previous dimension }
  3788.         Dec(IDim);
  3789.         DimID := DimensionIDs[IDim];
  3790.         Dim := FDimensions[DimID];
  3791.         LastDMember := Dim.MemberCount;
  3792.         { Get the current member for this dim }
  3793.         DMember := Domain[IDim,Index];
  3794.         Inc(DMember);
  3795.         bNewIndex := True;
  3796.       until False;
  3797.     finally
  3798.       if Sparsing and (Assigned(SumIndex)) then SumIndex.Free;
  3799.       Screen.Cursor := savedCursor;
  3800.     end;
  3801.   end;
  3802.   Inc(Index);
  3803.   Result := Index;
  3804.   {$IFDEF PROFILE}
  3805.   FTicks.TicksIntArray('BuildLookups', DimensionIDs);
  3806.   {$ENDIF}
  3807. end;
  3808.  
  3809. procedure TDataCache.SetActiveSummary(Index: Integer);
  3810. var
  3811.   Sum: TSummary;
  3812. begin
  3813.   if (Index <> FActiveSummary) then
  3814.   begin
  3815.     Assert(Index <= SummaryCount ,'Error in summary selection');  { Do not localize }
  3816.     { Clear subtotals }
  3817.     Sum := FSummaryData[FActiveSummary];
  3818.     Sum.ClearTotals;
  3819.     FActiveSummary := Index;
  3820.     ClearIndexInfo;
  3821.   end;
  3822. end;
  3823.  
  3824. function CalcThreadProc(Cache: TDataCache): Integer;
  3825. var
  3826.   Summary: TSummary;
  3827.   SumIndex: TSmallIntArray;
  3828.   Cnt, I: Integer;
  3829.   V: Variant;
  3830. begin
  3831.   Result := 1;
  3832.   try
  3833.     Summary := Cache.FSummaryData[Cache.CurrentSummary];
  3834.     Summary.FIndexInfo.AddAggs := True;
  3835.     Cnt := Cache.FIndexMap.Count;
  3836.     for I := 0 to Cnt-1 do
  3837.     begin
  3838.       // Get the index value for the dimension
  3839.       SumIndex := Cache.FIndexMap[I];
  3840.       Summary.SumMethod(SumIndex, Summary, V);
  3841.     end;
  3842.     Summary.FIndexInfo.AddAggs := False;
  3843.   finally
  3844.     EndThread(Result);
  3845.   end;
  3846. end;
  3847.  
  3848. procedure TDataCache.CalcSubTotals;
  3849. var
  3850.   Handle, ThreadID: DWORD;
  3851. begin
  3852.   Handle := BeginThread(nil, 0, @CalcThreadProc, Pointer(Self), 0, ThreadID);
  3853.   if (Handle <> 0) then CloseHandle(Handle);
  3854. end;
  3855.  
  3856. procedure TDataCache.CreateTable(Const Filename: String);
  3857. var
  3858.   I,k, Cnt: Integer;
  3859.   tbl: TBinTable;
  3860.   Summary: TSummary;
  3861.   SumIndex: TSmallIntArray;
  3862.   FieldName: string;
  3863.   Value: Variant;
  3864. begin
  3865.   tbl := nil;
  3866.   try
  3867.     tbl := TBinTable.Create(Application);
  3868.     tbl.CreateIndexTable(Self);
  3869.     tbl.Save(Filename);
  3870.     tbl.Edit;
  3871.     Summary := FSummaryData[CurrentSummary];
  3872.     Cnt := FIndexMap.Count;
  3873.     for I := 0 to Cnt-1 do
  3874.     begin
  3875.       tbl.Append;
  3876.       { Get the position }
  3877.       tbl.FieldValues['Position'] := I;  { Do not localize }
  3878.       { Get the index value for the dimension }
  3879.       SumIndex := FIndexMap[I];
  3880.       for K := 0 to DimensionCount-1 do
  3881.       begin
  3882.         FieldName := GetDimensionName(K);
  3883.         Value := SumIndex[K];
  3884.         tbl.FieldValues[FieldName] := Value;
  3885.       end;
  3886.       { Get the sparse flag }
  3887.       Value := Summary.FIndexInfo.IsSparse(I);
  3888.       tbl.FieldValues['Sparse'] := Value; { Do not localize }
  3889.       { Get the Summary value }
  3890.       Value := GetSummaryAsVariant(SumIndex);
  3891.       if not (VarIsEmpty(Value)) or (Value <> 0) then
  3892.       begin
  3893.         VarCast(Value, Value, varDouble);
  3894.         tbl.FieldValues[GetSummaryName(CurrentSummary)] := Value;
  3895.       end;
  3896.       { Get the offset }
  3897.       Value := Summary.FIndexInfo.FOffset[I];
  3898.       tbl.FieldValues['Offset'] := Value;   { Do not localize }
  3899.       tbl.Post;
  3900.     end;
  3901.   finally
  3902.     if Assigned(tbl) then tbl.Close;
  3903.     tbl.Free;
  3904.   end;
  3905. end;
  3906.  
  3907. function TDataCache.GetIndexCount: Integer;
  3908. begin
  3909.   Result := FIndexMap.Count;
  3910. end;
  3911.  
  3912. function TDataCache.AddAggIndex(SumIndex: TSmallIntArray; BuilderDims: TList):Integer;
  3913. var
  3914.   I, DimCnt, iAggOffset: Integer;
  3915.   newIndex: TSmallIntArray;
  3916.   Summary: TSummary;
  3917.   BDim: TBuilderDim;
  3918.   Value: Variant;
  3919. begin
  3920.   Summary := Summaries[FActiveSummary];
  3921.   VarClear(Value);
  3922.   BDim := nil;
  3923.   DimCnt := 0;
  3924.   { Create the index }
  3925.   newIndex := TSmallIntArray.Create(SumIndex.Count, 0);
  3926.   for I := 0 to SumIndex.Count-1 do
  3927.   begin
  3928.     newIndex[I] := SumIndex[I];
  3929.     if PreCalculateTotals then
  3930.     begin
  3931.       if (SumIndex[I] <> SubTotal) then
  3932.       begin
  3933.         Inc(DimCnt);
  3934.         BDim := BuilderDims[I];
  3935.         if (BDim.SumCount > 0) and (DimCnt = 1) then
  3936.           Value := BDim.GetSummary(GetDimensionMemberAsVariant(I, SumIndex[I]));
  3937.       end;
  3938.     end;
  3939.   end;
  3940.   { Count indexes with subtotals }
  3941.   Inc(Summary.FIndexInfo.FSubTotalCnt);
  3942.   { Add the Index map only once }
  3943.   if not HasIndex then
  3944.     FIndexMap.Add(newIndex)
  3945.   else
  3946.     newIndex.Free;
  3947.   { Try to add the agg'd value }
  3948.   iAggOffset := SparseUnknown;
  3949.   if Assigned(BDim) and (BDim.SumCount > 0) and (DimCnt = 1) then
  3950.   begin
  3951.     if not VarIsEmpty(Value) then
  3952.       iAggOffset := Summary.AddSubTotal(Value)
  3953.     else
  3954.       iAggOffset := SparseAgg;
  3955.   end;
  3956.   { Create the index info object }
  3957.   Result := Summary.AddIndexInfo(True, False, iAggOffset);
  3958. end;
  3959.  
  3960. function TDataCache.AddIndex(SumIndex: TSmallIntArray; bSparse: Boolean):Integer;
  3961. var
  3962.   I: Integer;
  3963.   newIndex: TSmallIntArray;
  3964.   Summary: TSummary;
  3965. begin
  3966.   Summary := Summaries[FActiveSummary];
  3967.   { Create the index }
  3968.   newIndex := TSmallIntArray.Create(SumIndex.Count, 0);
  3969.   for I := 0 to SumIndex.Count-1 do
  3970.   begin
  3971.     newIndex[I] := SumIndex[I];
  3972.   end;
  3973.   { count sparsed indexes }
  3974.   if bSparse then Inc(FIndexInfo.FSparseCnt);
  3975.   { Add the Index map }
  3976.   if not HasIndex then
  3977.     FIndexMap.Add(newIndex)
  3978.   else
  3979.     newIndex.Free;
  3980.   Result := Summary.AddIndexInfo(False, bSparse, 0);
  3981. end;
  3982.  
  3983. function TDataCache.GetMemoryUsage: Integer;
  3984. var
  3985.   I: Integer;
  3986.  
  3987.   function Max(X, Y: Integer): Integer;
  3988.   begin
  3989.     Result := Y;
  3990.     if (X > Y) then Result := X;
  3991.   end;
  3992.  
  3993. begin
  3994.   Result := 0;
  3995.   { Get dimension memory usage }
  3996.   if Assigned(FDimensions) then
  3997.     for I := 0 to DimensionCount - 1 do
  3998.       Result := Result + Dimensions[I].MemoryUsage;
  3999.   { get summary memory usage }
  4000.   if Assigned(FSummaryData) then
  4001.     for I := 0 to SummaryCount - 1 do
  4002.     begin
  4003.       Result := Result + Summaries[I].MemoryUsage;
  4004.     end;
  4005.   { IndexMap }
  4006.   if Assigned(FIndexMap) then
  4007.     Result := Result + FIndexMap.MemoryUsage;
  4008.   Result := Max(Result, AllocMemSize);
  4009. end;
  4010.  
  4011. function TDataCache.GetSuccess: Boolean;
  4012. begin
  4013.   Result := csSuccess In FState;
  4014. end;
  4015.  
  4016. procedure TDataCache.SetSuccess(Value: Boolean);
  4017. begin
  4018.   if Value then
  4019.     Include(FState, csSuccess)
  4020.   else
  4021.     Exclude(FState, csSuccess);
  4022. end;
  4023.  
  4024. function TDataCache.GetPreCalcTotals: Boolean;
  4025. begin
  4026.   Result := ctPreCalc in FCalcTotals;
  4027. end;
  4028.  
  4029. procedure TDataCache.SetPreCalcTotals(Value: Boolean);
  4030. begin
  4031.   if Value then
  4032.     Include(FCalcTotals, ctPreCalc)
  4033.   else
  4034.     Exclude(FCalcTotals, ctPreCalc);
  4035. end;
  4036.  
  4037. function TDataCache.GetSparsing: Boolean;
  4038. begin
  4039.   Result := lsSparsing in FLookupState;
  4040. end;
  4041.  
  4042. procedure TDataCache.SetSparsing(Value: Boolean);
  4043. begin
  4044.   if Value then
  4045.     Include(FLookupState, lsSparsing)
  4046.   else
  4047.     Exclude(FLookupState, lsSparsing);
  4048. end;
  4049.  
  4050. function TDataCache.GetHasIndex: Boolean;
  4051. begin
  4052.   Result := csHasIndex in FState;
  4053. end;
  4054.  
  4055. procedure TDataCache.SetHasIndex(Value: Boolean);
  4056. begin
  4057.   if Value then
  4058.     Include(FState, csHasIndex)
  4059.   else
  4060.     Exclude(FState, csHasIndex);
  4061. end;
  4062.  
  4063. function TDataCache.DimensionFromFieldName(FldName: string): TDimension;
  4064. var
  4065.   I: Integer;
  4066.   Dim: TDimension;
  4067. begin
  4068.   Result := nil;
  4069.   if Assigned(FDimensions) then
  4070.   begin
  4071.     for I := 0 to FDimensions.Count-1 do
  4072.     begin
  4073.       Dim := FDimensions[I];
  4074.       if (Dim.FieldName = FldName) then Result := Dim;
  4075.     end;
  4076.   end;
  4077. end;
  4078.  
  4079. procedure TDataCache.ClearIndexInfo;
  4080. var
  4081.   Cnt, I: Integer;
  4082. begin
  4083.   { Scan the index, change all SubTotal indexes to sparse unknown }
  4084.   Cnt   := FIndexMap.Count;
  4085.   for I := 0 to Cnt-1 do
  4086.   begin
  4087.     { Get the index value for the dimension }
  4088.     if HasSubTotals(FIndexMap[I]) then
  4089.       FIndexInfo.AddOffset(I, sparseUnknown);
  4090.   end;
  4091. end;
  4092.  
  4093. function  TDataCache.IsBlankSummary: Boolean;
  4094. var
  4095.   Sum: TSummary;
  4096. begin
  4097.   Sum := Summaries[FActiveSummary];
  4098.   Result := Sum.MemberCount = Sum.BlankCount;
  4099. end;
  4100.  
  4101.   {  TSummary }
  4102.  
  4103. function AggAverage(Val1, Val2: Variant): Variant;
  4104. begin
  4105.   try
  4106.     Result := Val1 { count } / Val2;  { summary }
  4107.   except
  4108.     on EDivByZero do Result := 0;
  4109.     else
  4110.       raise;
  4111.   end;
  4112. end;
  4113.  
  4114.  
  4115. constructor TSummary.Create(Items: Cardinal; DataType: TFieldType);
  4116. begin
  4117.   inherited Create(Items, FieldTypeToVarType(DataType));
  4118.   FTotals := TThreadCustomArray.Create(1, FieldTypeToVarType(DataType));
  4119.   FFieldDef := TFieldDefinition.Create;
  4120.   FAggDef := TAggDefinition.Create;
  4121.   FIndexInfo := nil;
  4122. end;
  4123.  
  4124. destructor TSummary.Destroy;
  4125. begin
  4126.   FPosition := 0;
  4127.   if Assigned(FTotals) then FTotals.Free;
  4128.   FTotals := nil;
  4129.   if Assigned(FFieldDef) then FFieldDef.Free;
  4130.   FFieldDef := nil;
  4131.   if Assigned(FAggDef) then FAggDef.Free;
  4132.   FAggDef := nil;
  4133.   inherited Destroy;
  4134. end;
  4135.  
  4136. procedure TSummary.SetFieldType(Value: TFieldType);
  4137. begin
  4138.   FFieldDef.FieldType := Value;
  4139. end;
  4140.  
  4141. function TSummary.GetFieldType: TFieldType;
  4142. begin
  4143.   Result := FFieldDef.FieldType;
  4144. end;
  4145.  
  4146. procedure TSummary.SetPosition(Value: Integer);
  4147. begin
  4148.   FPosition := Value;
  4149. end;
  4150.  
  4151. procedure TSummary.SetFlag(aFlag: TDimFlags);
  4152. begin
  4153.    Include(FFLags, aFlag);
  4154. end;
  4155.  
  4156. procedure TSummary.AddSum(var SumIndex: TSmallIntArray; vNew: Variant);
  4157. begin
  4158.   SetItem(MemberCount, vNew);
  4159. end;
  4160.  
  4161. function TSummary.AddSubTotal(Value: Variant): Integer;
  4162. begin
  4163.   Result := FTotals.Add(Value);
  4164. end;
  4165.  
  4166. function TSummary.AddIndexInfo(BTotal, bSparse: Boolean; iAggOffset: Integer): Integer;
  4167. var
  4168.   pIndexInfo: PIndexInfoRec;
  4169. begin
  4170.   pIndexInfo := nil;
  4171.   try
  4172.     New(pIndexInfo);
  4173.     pIndexInfo^.SparseCnt := FIndexInfo.FSparseCnt;
  4174.     pIndexInfo^.SubTotalCnt := FIndexInfo.FSubTotalCnt;
  4175.     { Add the flags }
  4176.     if bTotal then
  4177.     begin
  4178.       pIndexInfo^.Flags := [idxSubTotals];
  4179.       pIndexInfo^.AggOffset := iAggOffset;
  4180.     end
  4181.     else
  4182.       pIndexInfo^.Flags := [idxNormal];
  4183.     if bSparse then pIndexInfo^.Flags := pIndexInfo^.Flags + [idxSparsed];
  4184.     Result := FIndexInfo.Add(pIndexInfo);
  4185.   finally
  4186.     Dispose(pIndexInfo);
  4187.   end;
  4188. end;
  4189.  
  4190. function TSummary.HasFlag(aFlag: TDimFlags): Boolean;
  4191. begin
  4192.    Result := aFlag in FFlags;
  4193. end;
  4194.  
  4195. procedure TSummary.SetName(Value: String);
  4196. begin
  4197.   FFieldDef.DisplayName := Value;
  4198. end;
  4199.  
  4200. function TSummary.GetName: string;
  4201. begin
  4202.   Result := FieldName;
  4203. end;
  4204.  
  4205. function TSummary.IsSparse(Index: Integer): Boolean;
  4206. begin
  4207.   Result := FIndexInfo.IsSparse(Index);
  4208. end;
  4209.  
  4210. function TSummary.MemoryUsage: Integer;
  4211. begin
  4212.   Result := 0;
  4213.   if Assigned(FIndexInfo) then
  4214.     Result := Result + (FIndexInfo.FOffset.Capacity * FIndexInfo.FOffset.ItemSize);
  4215.   Result := Result + FTotals.MemoryUsage;
  4216.   Result := Result + inherited MemoryUsage;
  4217. end;
  4218.  
  4219. procedure TSummary.UpdateIndexInfo(Index: Integer; Value: Variant);
  4220. var
  4221.   iOffset: Integer;
  4222. begin
  4223.   if (Value <> 0) then
  4224.   begin
  4225.     if (FIndexInfo.AddAggs = True) then
  4226.     begin
  4227.       iOffset := AddSubtotal(Value);
  4228.       FIndexInfo.AddOffset(Index, iOffset);
  4229.     end
  4230.     else
  4231.       FIndexInfo.AddOffset(Index, NonSparseAgg);
  4232.   end
  4233.   else
  4234.     FIndexInfo.AddOffset(Index, SparseAgg);
  4235. end;
  4236.  
  4237. function TSummary.SetAggregator(aName: string; DimMap: TCubeDims; dimType: TDimFlags; var dIdx: Integer): Boolean;
  4238. var
  4239.   SumIndex, CountIndex: Integer;
  4240.   I: Integer;
  4241. begin
  4242.   SumIndex := -1;
  4243.   CountIndex := -1;
  4244.   dIdx := -1;
  4245.   Result := False;
  4246.   { Find the count index }
  4247.   if (CountIndex < 0) then
  4248.   begin
  4249.     for I := 0 to DimMap.Count-1 do
  4250.     begin
  4251.       if (DimMap[I].DimensionType = dimCount) then
  4252.       begin
  4253.         if (aName = DimMap[I].BaseName) then
  4254.         begin
  4255.           CountIndex := I;      { look for a count in the list which matches }
  4256.         end
  4257.         else if (sCountStar = AnsiUpperCase(DimMap[I].Name)) then
  4258.         begin
  4259.           CountIndex := I;      { but give preference to a count(*) }
  4260.           break;
  4261.         end;
  4262.       end;
  4263.     end;
  4264.   end;
  4265.   { Find the summary index }
  4266.   if (SumIndex < 0) then
  4267.   begin
  4268.     for I := 0 to DimMap.Count-1 do
  4269.     begin
  4270.       if (aName = DimMap[I].BaseName) then
  4271.       begin
  4272.         if (DimMap[I].DimensionType = dimSum) then
  4273.         begin
  4274.           SumIndex := I;
  4275.           break;
  4276.         end;
  4277.       end;
  4278.     end;
  4279.   end;
  4280.   if (CountIndex = -1) or (SumIndex = -1) then Exit;
  4281.   if (dimType = dimAverage) then
  4282.   begin
  4283.     FAggDef.FAggProc := AggAverage;
  4284.     FAggDef.FSummaryIdx[0] := SumIndex;
  4285.     FAggDef.FSummaryIdx[1] := CountIndex;
  4286.     dIdx := SumIndex;
  4287.   end;
  4288.   Result := True;
  4289. end;
  4290.  
  4291. function TSummary.GetDerived: Boolean;
  4292. begin
  4293.   Result := (FPosition = -1);
  4294. end;
  4295.  
  4296. procedure TSummary.ClearTotals;
  4297. begin
  4298.   if Assigned(FTotals) then FTotals.Free;
  4299.   FTotals := TThreadCustomArray.Create(1, FieldTypeToVarType(FieldDefinition.FieldType));
  4300. end;
  4301.  
  4302.   { TDimension }
  4303.  
  4304. constructor TDimension.Create(Items: Cardinal; DataType: TFieldType);
  4305. begin
  4306.   inherited Create(Items, FieldTypeToVarType(DataType));
  4307.   FPosition := 0;
  4308.   FFieldDef := TFieldDefinition.Create;
  4309. end;
  4310.  
  4311. destructor TDimension.Destroy;
  4312. begin
  4313.   FFieldDef.Free;
  4314.   FPosition := 0;
  4315.   inherited Destroy;
  4316. end;
  4317.  
  4318. procedure TDimension.SetFieldType(Value: TFieldType);
  4319. begin
  4320.   FFieldDef.FieldType := Value;
  4321. end;
  4322.  
  4323. function TDimension.GetFieldType: TFieldType;
  4324. begin
  4325.   Result := FFieldDef.FieldType;
  4326. end;
  4327.  
  4328. procedure TDimension.SetPosition(Value: Integer);
  4329. begin
  4330.   FPosition := Value;
  4331. end;
  4332.  
  4333. procedure TDimension.SetName(Value: String);
  4334. begin
  4335.   FFieldDef.DisplayName := Value;
  4336. end;
  4337.  
  4338. function TDimension.GetName: String;
  4339. begin
  4340.   Result := FFieldDef.DisplayName;
  4341. end;
  4342.  
  4343. procedure TDimension.SetFlag(aFlag: TDimFlags);
  4344. begin
  4345.    Include(FFLags, aFlag);
  4346. end;
  4347.  
  4348. function TDimension.HasFlag(aFlag: TDimFlags): Boolean;
  4349. Begin
  4350.    Result := aFlag in FFlags;
  4351. End;
  4352.  
  4353. procedure TDimension.ClearFlag(aFlag: TDimFlags);
  4354. Begin
  4355.    Exclude(FFLags, aFlag);
  4356. End;
  4357.  
  4358. procedure TDimension.SetRangeCounting(bRange: Boolean);
  4359. begin
  4360.   if bRange then
  4361.     FRange := MemberCount
  4362.   else
  4363.     FRange := MemberCount - FRange;
  4364. end;
  4365.  
  4366. procedure TDimension.AssignSorted(Dim: TDimension; bUnique: Boolean);
  4367. begin
  4368.   Assign(TCustomArray(Dim), True, bUnique);
  4369. end;
  4370.  
  4371. function TDimension.IsString: Boolean;
  4372. begin
  4373.   Result := (FFieldDef.FieldType = ftString);
  4374. end;
  4375.  
  4376. procedure TDimension.SetRange(Value: Integer);
  4377. begin
  4378.   FRange := Value;
  4379. end;
  4380.  
  4381.   { TFieldDefinition }
  4382.  
  4383. constructor TFieldDefinition.Create;
  4384. begin
  4385.   inherited Create;
  4386.   FFormatType := fxNone;
  4387. end;
  4388.  
  4389. function TFieldDefinition.FormatVariantToStr(Value: Variant): string;
  4390. begin
  4391.   case FFormatType of
  4392.     fxFloat:
  4393.     begin
  4394.       if (FFormatString <> '') then
  4395.         Result := FormatFloat(FFormatString, Value)
  4396.       else
  4397.         Result := FloatToStrF(Value, ffGeneral, FPrecision, 2);
  4398.     end;
  4399.     fxCurrency:
  4400.     begin
  4401.       if (FFormatString <> '') then
  4402.         Result := FormatFloat(FFormatString, Value)
  4403.       else
  4404.         Result := FloatToStrF(Value, ffCurrency, FPrecision, 2);
  4405.     end;
  4406.     fxDateTime:
  4407.     begin
  4408.       if (FFormatString <> '') then
  4409.         Result := FormatDateTime(FFormatString, Value)
  4410.       else
  4411.         Result := DateTimeToStr(Value);
  4412.     end;
  4413.     fxDate:
  4414.     begin
  4415.       if (FFormatString <> '') then
  4416.         Result := FormatDateTime(FFormatString, Value)
  4417.       else
  4418.         Result := DateToStr(Value);
  4419.     end;
  4420.     fxTime:
  4421.     begin
  4422.       if (FFormatString <> '') then
  4423.         Result := FormatDateTime(FFormatString, Value)
  4424.       else
  4425.         Result := TimeToStr(Value);
  4426.     end;
  4427.     fxBoolean:
  4428.     begin
  4429.       VarCast(Value, Value, varBoolean);
  4430.       if (Value = True) then
  4431.         Result := sTrue
  4432.       else
  4433.         Result := sFalse;
  4434.     end;
  4435.     else
  4436.       Result := VarToStr(Value);
  4437.    end;
  4438. end;
  4439.  
  4440. procedure TFieldDefinition.SetFieldType(FType: TFieldType);
  4441. const
  4442.   TypeMap: array[ftUnknown..ftAutoInc] of TFormatType = (
  4443.     fxNone, fxString, fxInteger, fxInteger, fxInteger, fxBoolean,
  4444.     fxFloat, fxCurrency, fxCurrency, fxDate, fxTime, fxDateTime,
  4445.     fxNone, fxNone, fxInteger);
  4446.  
  4447. begin
  4448.   if (FFieldType <> FType) then
  4449.   begin
  4450.     FFieldType  := FType;
  4451.     if (FType <= ftAutoInc) then
  4452.       FFormatType := TypeMap[FType]
  4453.     else
  4454.       FFormatType := fxNone;
  4455.   end;
  4456. end;
  4457.  
  4458. procedure TFieldDefinition.SetName(Value: String);
  4459. begin
  4460.   FName := Value;
  4461. end;
  4462.  
  4463.   { TBuilderDim }
  4464.  
  4465. constructor TBuilderDim.Create(Items: Cardinal; DataType: TFieldType);
  4466. begin
  4467.   inherited Create(Items, DataType);
  4468.   FGroupBreak := False;
  4469.   FActiveIndex := 0;
  4470.   FValueList := TStringArray.Create(0,0);
  4471. end;
  4472.  
  4473. destructor TBuilderDim.Destroy;
  4474. begin
  4475.   FSummary.Free;
  4476.   FSummary := nil;
  4477.   FValueList.Free;
  4478.   FValueList := nil;
  4479.   inherited destroy;
  4480. end;
  4481.  
  4482. procedure TBuilderDim.InitSummary(DataType: Integer);
  4483. begin
  4484.   FSummary := TCustomArray.Create(1, DataType);
  4485.   FSummaryDataType := DataType;
  4486. end;
  4487.  
  4488. procedure TBuilderDim.Add(Value: Variant);
  4489. begin
  4490.   inherited items[MemberCount] := Value;
  4491. end;
  4492.  
  4493. procedure TBuilderDim.AddSummary(Value: Variant);
  4494. var
  4495.   vSum: Variant;
  4496. begin
  4497.   vSum := FSummary[FActiveIndex];
  4498.   if (TVarData(Value).VType <> varNull) then
  4499.     FSummary[FActiveIndex] := vSum + Value;
  4500. end;
  4501.  
  4502. function TBuilderDim.MatchLastVal(Value: Variant): Boolean;
  4503. begin
  4504.   Result := True;
  4505.   if not VarIsEmpty(LastVal) then Result := (Value = LastVal);
  4506. end;
  4507.  
  4508. procedure TBuilderDim.SetLastVal(Value: Variant);
  4509. var
  4510.   Idx: Integer;
  4511.   bFind: Boolean;
  4512.  
  4513.   function VarToCubeStr(Value: Variant): string;
  4514.   begin
  4515.     case TVarData(Value).VType of
  4516.       varEmpty,
  4517.       varNull:
  4518.       begin
  4519.         if (DataType <> varString) then
  4520.           Result := '0'
  4521.         else
  4522.           Result := '';
  4523.       end;
  4524.       else
  4525.         Result := VarToStr(Value);
  4526.     end;
  4527.   end;
  4528.  
  4529. begin
  4530.   FLastVal := Value;
  4531.   bFind := False;
  4532.   for Idx := 0 to FValueList.Count-1 do
  4533.     if (FValueList[Idx] = VarToCubeStr(Value)) then
  4534.     begin
  4535.       bFind := True;
  4536.       break;
  4537.     end;
  4538.     if bFind then
  4539.       FActiveIndex := Idx
  4540.     else
  4541.     begin
  4542.       FActiveIndex := FValueList.Add(VarToCubeStr(Value));
  4543.       FSummary[FActiveIndex] := VarAsType(0, FSummaryDataType);
  4544.     end;
  4545. end;
  4546.  
  4547. function TBuilderDim.GetLastVal: Variant;
  4548. begin
  4549.   Result := FLastVal;
  4550. end;
  4551.  
  4552. function TBuilderDim.GetSummary(Value: Variant): Variant;
  4553. var
  4554.   Idx: Integer;
  4555.   str: string;
  4556. begin
  4557.   if VarIsEmpty(Value) then
  4558.     str := ''
  4559.   else
  4560.     str := VarToStr(Value);
  4561.   for Idx := 0 to FValueList.Count-1 do
  4562.   begin
  4563.     if FValueList[Idx] = str then
  4564.       break;
  4565.   end;
  4566.   Result := FSummary[Idx];
  4567. end;
  4568.  
  4569. function TBuilderDim.GetSumCount: Integer;
  4570. begin
  4571.   Result := FSummary.MemberCount;
  4572. end;
  4573.  
  4574.   { DataCube Collection Definition }
  4575.  
  4576. constructor TCubeDims.Create(FOwner: TPersistent; ItemClass: TCubeDimClass);
  4577. begin
  4578.   inherited Create(FOwner, ItemClass);
  4579. end;
  4580.  
  4581. function TCubeDims.GetOwner: TPersistent;
  4582. begin
  4583.   Result := inherited GetOwner;
  4584. end;
  4585.  
  4586. function TCubeDims.GetCubeDim(Index: Integer): TCubeDim;
  4587. begin
  4588.   Result := TCubeDim(inherited Items[Index]);
  4589. end;
  4590.  
  4591. procedure TCubeDims.SetCubeDim(Index: Integer; Value: TCubeDim);
  4592. begin
  4593.   Items[Index].Assign(Value);
  4594. end;
  4595.  
  4596. function TCubeDims.Add: TCubeDim;
  4597. begin
  4598.   Result := TCubeDim(inherited Add);
  4599. end;
  4600.  
  4601. procedure TCubeDims.Assign(Source: TPersistent);
  4602. begin
  4603.   inherited;
  4604. end;
  4605.  
  4606. function TCubeDims.GetDirtyFlag: Boolean;
  4607. var
  4608.   I: Integer;
  4609. begin
  4610.   Result := False;
  4611.   for I := 0 to Count-1 do
  4612.     if Items[I].FDirty then
  4613.     begin
  4614.       Items[I].FDirty := False;
  4615.       Result := True;
  4616.       break;
  4617.     end;
  4618. end;
  4619.  
  4620.   { TCubeDim }
  4621.  
  4622. constructor TCubeDim.Create(Collection: TCollection);
  4623. begin
  4624.   inherited Create(Collection);
  4625.   FBinType := binNone;
  4626.   FDirty := False;
  4627.   FTransform := nil;
  4628.   FBinData := nil;
  4629.   FValues := -1;
  4630.   bWasActive := false;
  4631. end;
  4632.  
  4633. destructor TCubeDim.Destroy;
  4634. begin
  4635.   if Assigned(FBinData) then FBinData.Destroy;
  4636.   inherited Destroy;
  4637. end;
  4638.  
  4639. procedure TCubeDim.Assign(Value: TPersistent);
  4640. begin
  4641.   inherited;
  4642.   FBinType := TCubeDim(Value).FBinType;
  4643.   FStartDate := TCubeDim(Value).FStartDate;
  4644.   FTransform := TCubeDim(Value).FTransform;
  4645.   FBinFormat := TCubeDim(Value).FBinFormat;
  4646.   FStartValue := TCubeDim(Value).FStartValue;
  4647.   FValues := TCubeDim(Value).FValues;
  4648.   bWasActive := TCubeDim(Value).bWasActive;
  4649.   if Assigned(TCubeDim(Value).FBinData) then
  4650.   begin
  4651.     FBinData := TBinData.Create;
  4652.     FBinData.Assign(TCubeDim(Value).FBinData);
  4653.   end;
  4654. end;
  4655.  
  4656. procedure TCubeDim.InitializeRange;
  4657. var
  4658.   sDate, sNow: TDateTime;
  4659.   Year, Month, Day: Word;
  4660. begin
  4661.   if (FieldType in [ftDate, ftDateTime]) then
  4662.   begin
  4663.     BinType := binYear;
  4664.     sNow := Now;
  4665.     DecodeDate(sNow, Year, Month, Day);
  4666.     sDate := EncodeDate(Year, 1, 1);
  4667.     StartDate := TDate(sDate);
  4668.   end;
  4669. end;
  4670.  
  4671. function TCubeDim.GetLoaded: Boolean;
  4672. begin
  4673.   Result := Active;
  4674. end;
  4675.  
  4676. procedure TCubeDim.SetLoaded(Value: Boolean);
  4677. begin
  4678.   if TCubeDims(Owner).GetOwner is TCustomDataStore then
  4679.   begin
  4680.     if (TCustomDataStore(TCubeDims(Owner).GetOwner).DimensionMap = TCubeDims(Owner)) then
  4681.       raise Exception.CreateRes(@SDimMapActiveError);
  4682.   end;
  4683.   Active := Value;
  4684. end;
  4685.  
  4686. procedure TCubeDim.NotifyCollection(aType: TCDNotifyType);
  4687. begin
  4688.   FDirty := True;
  4689.   inherited NotifyCollection(aType);
  4690. end;
  4691.  
  4692. procedure TCubeDim.DataSetTransform(var Value: Variant; CubeDim: TCubeDim);
  4693. var
  4694.   I, K, cnt, nameCnt: Integer;
  4695.   binData: TBinData;
  4696.   custAr: TCustomArray;
  4697.   bName: string;
  4698. begin
  4699.   binData := CubeDim.FBinData;
  4700.   if (binData = nil) then Exit;
  4701.   nameCnt := binData.NameList.Count;
  4702.   for I := 0 to nameCnt-1 do
  4703.   begin
  4704.     bName := binData.NameList[I];
  4705.     custAr := binData.ValueList[I];
  4706.     { Try to guard against Variant type mismatch }
  4707.     if (custAr.DataType <> TVarData(Value).VType) then
  4708.       Value := custAr.ConvertVar(Value);
  4709.     cnt := custAr.MemberCount;
  4710.     for K := 0 to cnt-1 do
  4711.     begin
  4712.       if custAr[K] = Value then
  4713.       begin
  4714.         Value := bName;
  4715.         exit;
  4716.       end;
  4717.     end;
  4718.   end;
  4719.   binData.AddBinValue(binData.OtherBinName, Value);
  4720.   Value := binData.OtherBinName;
  4721. end;
  4722.  
  4723. procedure TCubeDim.YearTransform(var Value: Variant; CubeDim: TCubeDim);
  4724. var
  4725.   Present: TDateTime;
  4726.   Year, Month, Day: Word;
  4727.   Y, M, D: Word;
  4728.   sDate: TDateTime;
  4729.   DoFiscalYear: Boolean;
  4730. begin
  4731.   if (VarType(Value) <> varDate) then Exit;
  4732.   DoFiscalYear := False;
  4733.   sDate := CubeDim.StartDate;
  4734.   if (sDate <> 0) then
  4735.   begin
  4736.     DecodeDate(sDate, Y, M, D);
  4737.     if (M <> 1) or (D <> 1) then DoFiscalYear := True;
  4738.   end;
  4739.   Present := Value;
  4740.   DecodeDate(Present, Year, Month, Day);
  4741.   if DoFiscalYear then
  4742.   begin
  4743.     if (Month = M) then
  4744.     begin
  4745.       if (Day >= D) then Inc(Year);
  4746.     end
  4747.     else if (Month > M) then Inc(Year);
  4748.   end;
  4749.   Month := 1;
  4750.   Day := 1;
  4751.   Value := EncodeDate(Year, Month, Day);
  4752. end;
  4753.  
  4754. procedure TCubeDim.MonthTransform(var Value: Variant; CubeDim: TCubeDim);
  4755. var
  4756.   Present: TDateTime;
  4757.   Year, Month, Day: Word;
  4758.   Y, M, D: Word;
  4759.   sDate: TDateTime;
  4760.   DoFiscalYear: Boolean;
  4761. begin
  4762.   if (VarType(Value) <> varDate) then Exit;
  4763.   DoFiscalYear := False;
  4764.   sDate := CubeDim.StartDate;
  4765.   if (sDate <> 0) then
  4766.   begin
  4767.     DecodeDate(sDate, Y, M, D);
  4768.     if (M <> 1) or (D <> 1) then DoFiscalYear := True;
  4769.   end;
  4770.   Present := Value;
  4771.   DecodeDate(Present, Year, Month, Day);
  4772.   if DoFiscalYear then
  4773.   begin
  4774.     if (Month = M) then
  4775.     begin
  4776.       if (Day >= D) then Inc(Year);
  4777.     end
  4778.     else if (Month > M) then Inc(Year);
  4779.   end;
  4780.   Day := 1;
  4781.   Value := EncodeDate(Year, Month, Day);
  4782. end;
  4783.  
  4784. procedure TCubeDim.QuarterTransform(var Value: Variant; CubeDim: TCubeDim);
  4785. var
  4786.   Present: TDateTime;
  4787.   Year, Month, Day: Word;
  4788.  
  4789.   procedure GetQuarterRange(var Mon, Yr: Word);
  4790.   var
  4791.     I: Integer;
  4792.     Q, K, YQ, MQ, DQ: Word;
  4793.     sDate: TDateTime;
  4794.   begin
  4795.     sDate := CubeDim.StartDate;
  4796.     if (sDate = 0) then
  4797.       MQ := 1
  4798.     else
  4799.       DecodeDate(sDate, YQ, MQ, DQ);
  4800.     Q := 1;
  4801.     K := MQ;
  4802.     repeat
  4803.       for I := 1 to 3 do
  4804.       begin
  4805.         if (Mon = K) then
  4806.         begin
  4807.           if (Mon >= MQ) then Inc(Yr);
  4808.           Mon := Q;
  4809.           Exit;
  4810.         end;
  4811.         Inc(K);
  4812.       end;
  4813.       if (K >= 12) then K := 1;
  4814.       Inc(Q);
  4815.     until (Q > 4);
  4816.     if (Mon >= MQ) then Inc(Yr);
  4817.     Mon := MQ;
  4818.   end;
  4819.   
  4820. begin
  4821.   if (VarType(Value) <> varDate) then Exit;
  4822.   Present := Value;
  4823.   DecodeDate(Present, Year, Month, Day);
  4824.   Day := 1;
  4825.   GetQuarterRange(Month, Year);
  4826.   Value := EncodeDate(Year, Month, Day);
  4827. end;
  4828.  
  4829. function TCubeDim.AssignBinTypeTransform(Bins: TBinType): TCubeDimTransformEvent;
  4830. begin
  4831.   if (bins = binYear) then
  4832.     Result := YearTransform
  4833.   else if (bins = binMonth) then
  4834.     Result := MonthTransform
  4835.   else if (bins = binQuarter) then
  4836.     Result := QuarterTransform
  4837.   else
  4838.     Result := nil;
  4839. end;
  4840.  
  4841. function TCubeDim.AssignBinTypeFormat(Bins: TBinType): string;
  4842. begin
  4843.   if (bins = binYear) then
  4844.     Result := 'yyyy'
  4845.   else if (bins = binMonth) then
  4846.     Result := 'mmm, yyyy'
  4847.   else if (bins = binQuarter) then
  4848.     Result := '"Q"m, yyyy'
  4849.   else
  4850.     Result := '';
  4851. end;
  4852.  
  4853. procedure TCubeDim.SetBin(Value: TBinType);
  4854. begin
  4855.   if (FBinType <> Value) then
  4856.   begin
  4857.     case Value of
  4858.       binYear,
  4859.       binMonth,
  4860.       binQuarter:
  4861.       begin
  4862.         if not IsDateField(FieldType) then
  4863.           raise ECacheError.CreateRes(@sBinTypeMismatch);
  4864.         FTransform := AssignBinTypeTransform(Value);
  4865.         FBinFormat := AssignBinTypeFormat(Value);
  4866.       end;
  4867.       binSet:
  4868.       begin
  4869.         FTransform := DataSetTransform;
  4870.         FBinData := TBinData.Create;
  4871.       end;
  4872.       binCustom:
  4873.       else
  4874.       begin
  4875.         FTransform := nil;
  4876.         FBinFormat := '';
  4877.       end;
  4878.     end;
  4879.     if (Value <> binSet) then
  4880.     begin
  4881.       FBinData.free;
  4882.       FBinData := nil;
  4883.     end;
  4884.     FBinType := Value;
  4885.   end;
  4886. end;
  4887.  
  4888. function TCubeDim.GetBin: TBinType;
  4889. begin
  4890.   Result := FBinType
  4891. end;
  4892.  
  4893. procedure TCubeDim.SetDate(Value: TDate);
  4894. begin
  4895.   FStartDate := Value;
  4896.   FStartValue := DateToStr(Value);
  4897. end;
  4898.  
  4899. procedure TCubeDim.SetStart(Value: string);
  4900. var
  4901.   aVariant: Variant;
  4902. begin
  4903.   FStartValue := Value;
  4904.   if (Value <> '') and (BinType = binSet) then
  4905.   begin
  4906.     VarCast(aVariant, Value, FieldTypeToVarType(FieldType));
  4907.     BinType := binNone;
  4908.     BinType := binSet;
  4909.     BinData.AddBin('SingleValue', varType(aVariant));
  4910.     BinData.AddIBinValue(0, aVariant);
  4911.   end
  4912.   else if (BinType in [BinYear, BinQuarter, BinMonth]) then
  4913.   begin
  4914.     SetDate(StrToDate(Value));
  4915.   end;
  4916. end;
  4917.  
  4918. procedure TCubeDim.DefineProperties(Filer: TFiler);
  4919. begin
  4920.   inherited;
  4921.   Filer.DefineProperty('Active', ReadActive, WriteActive, true);
  4922.   Filer.DefineProperty('DateBin', ReadDateBin, nil, false);
  4923.   Filer.DefineProperty('StartDate', ReadStartDate, nil, false);
  4924.   Filer.DefineProperty('StartValue', ReadStartValue, WriteStartValue, StartValue <> '');
  4925. end;
  4926.  
  4927. procedure TCubeDim.ReadDateBin(Reader: TReader);
  4928. var
  4929.   temp: string;
  4930. begin
  4931.   temp := Reader.ReadIdent;
  4932.   if (temp = 'binNone') then
  4933.     binType := binNone
  4934.   else if (temp = 'binYear') then
  4935.     binType := binYear
  4936.   else if (temp = 'binQuarter') then
  4937.     binType := binQuarter
  4938.   else if (temp = 'binMonth') then
  4939.     binType := binMonth
  4940.   else if (temp = 'binSet') then
  4941.     binType := binSet
  4942.   else if (temp = 'binCustom') then
  4943.     binType := binCustom;
  4944. end;
  4945.  
  4946. procedure TCubeDim.ReadStartDate(Reader: TReader);
  4947. begin
  4948.   SetDate(Reader.ReadFloat);
  4949. end;
  4950.  
  4951. procedure TCubeDim.ReadStartValue(Reader: TReader);
  4952. var
  4953.   vType: TValueType;
  4954. begin
  4955.   vType := Reader.NextValue;
  4956.   case vType of
  4957.     vaExtended: StartValue := DateToStr(Reader.ReadFloat);
  4958.     vaInt32: StartValue := DateToStr(Reader.ReadFloat);
  4959.     vaString: StartValue := Reader.ReadString;
  4960.   end;
  4961. end;
  4962.  
  4963. procedure TCubeDim.WriteStartValue (Writer: TWriter);
  4964. begin
  4965.   if FieldType in [ftDate, ftDateTime] then
  4966.   begin
  4967.     Writer.WriteFloat(strtoDate(StartValue));
  4968.   end
  4969.   else
  4970.     Writer.WriteString(StartValue);
  4971. end;
  4972.  
  4973. procedure TCubeDim.ReadActive(Reader: TReader);
  4974. begin
  4975.   Active := Reader.ReadBoolean;
  4976. end;
  4977.  
  4978. procedure TCubeDim.WriteActive (Writer: TWriter);
  4979. begin
  4980.   Writer.WriteBoolean(Active);
  4981. end;
  4982.  
  4983. function TCubeDim.IsBinData: Boolean;
  4984. begin
  4985.   Result := not (FBinType = binNone);
  4986. end;
  4987.  
  4988. procedure TCubeDim.DoTransform(var Value: Variant);
  4989. begin
  4990.   if Assigned(FTransform) then FTransform(Value, self);
  4991. end;
  4992.  
  4993. function TCubeDim.GetBinValues(Value: Variant): Variant;
  4994. var
  4995.   Present: TDateTime;
  4996.   Year, Month, Day: Word;
  4997. begin
  4998.   { Process dates }
  4999.   if (FBinType = binYear) or (FBinType = binMonth) or (FBinType = binQuarter) then
  5000.   begin
  5001.     if (VarType(Value) <> varDate) then
  5002.     begin
  5003.       Result := 0;
  5004.       exit;
  5005.     end;
  5006.     Result := VarArrayCreate([0, 1], varVariant);
  5007.     Result[0] := Value;
  5008.     Present := Value;
  5009.     DecodeDate(Present, Year, Month, Day);
  5010.     case FBinType of
  5011.       binYear:    Year := Year + 1;
  5012.       binQuarter: Month := Month + 3;
  5013.       binMonth: Month := Month + 1;
  5014.       else;
  5015.     end;
  5016.     Result[1] := EncodeDate(Year, Month, Day);
  5017.   end
  5018.   else if (binType = binSet) and assigned(FBinData) then
  5019.   begin
  5020.     Result := FBinData.GetBinValues(FormatVariant(Value,''));
  5021.   end
  5022.   else
  5023.     Result := 0;
  5024. end;
  5025.  
  5026.   { TIndexInfo }
  5027.  
  5028. constructor TIndexInfo.Create;
  5029. begin
  5030.   inherited Create;
  5031.   FSparseCnt := 0;
  5032.   FSubTotalCnt := 0;
  5033.   FCount := 0;
  5034.   FExtInfo := False;
  5035.   FAddAggs := False;
  5036.   InitializeCriticalSection(FLock);
  5037.   FOffset := TIntArray.Create(1, 0);
  5038. end;
  5039.  
  5040. destructor TIndexInfo.Destroy;
  5041. begin
  5042.   LockIndex;
  5043.   try
  5044.     FOffset.Free;
  5045.     FOffset := nil;
  5046.     inherited destroy;
  5047.   finally
  5048.     UnlockIndex;
  5049.     DeleteCriticalSection(FLock);
  5050.   end;
  5051. end;
  5052.  
  5053. function TIndexInfo.Add(pIdxRec: PIndexInfoRec): Integer;
  5054. var
  5055.   iOffset: Integer;
  5056. begin
  5057.   LockIndex;
  5058.   try
  5059.     if (idxSparsed in pIdxRec^.Flags) then
  5060.       iOffset := SparseSum
  5061.     else if (idxSubTotals in pIdxRec^.Flags) then
  5062.       iOffset := pIdxRec^.AggOffset
  5063.     else
  5064.       iOffset := FCount - (pIdxRec^.SparseCnt + pIdxRec^.SubTotalCnt);
  5065.     AddOffset(FCount, iOffset);
  5066.     Inc(FCount);
  5067.     Result := FCount;
  5068.   finally
  5069.     UnlockIndex;
  5070.   end;
  5071. end;
  5072.  
  5073. function TIndexInfo.IsSparse(Index: Integer): Boolean;
  5074. begin
  5075.   Result := (FOffset[Index] = SparseSum);
  5076. end;
  5077.  
  5078. procedure TIndexInfo.SetCapacity(Value: Integer);
  5079. begin
  5080.   LockIndex;
  5081.   try
  5082.     FOffset.Capacity := Value;
  5083.   finally
  5084.     UnlockIndex;
  5085.   end;
  5086. end;
  5087.  
  5088. function TIndexInfo.GetCapacity: Integer;
  5089. begin
  5090.   Result := FOffset.Capacity;
  5091. end;
  5092.  
  5093. function TIndexInfo.IsSparseAgg(Index: Integer): Boolean;
  5094. begin
  5095.   Result := (FOffset[Index] = SparseAgg);
  5096. end;
  5097.  
  5098. procedure TIndexInfo.AddOffset(Index, IdxType: Integer);
  5099. begin
  5100.   LockIndex;
  5101.   try
  5102.     FOffSet[Index] := idxType;
  5103.   finally
  5104.     UnlockIndex;
  5105.   end;
  5106. end;
  5107.  
  5108. function TIndexInfo.LockIndex: TIntArray;
  5109. begin
  5110.   EnterCriticalSection(FLock);
  5111.   Result := TIntArray(FOffSet);
  5112. end;
  5113.  
  5114. procedure TIndexInfo.UnlockIndex;
  5115. begin
  5116.   LeaveCriticalSection(FLock);
  5117. end;
  5118.  
  5119. end.
  5120.