cxdatastorage.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 2,304 行 · 第 1/5 页

  end;

  { TcxLookupList }

  TcxLookupListItem = record
    KeyValue: Variant;
    DisplayText: string;
  end;
  PcxLookupListItem = ^TcxLookupListItem;

  TcxLookupList = class
  private
    FItems: TList;
    function GetCount: Integer;
    function GetItem(Index: Integer): PcxLookupListItem;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    function Find(const AKeyValue: Variant; var AIndex: Integer): Boolean;
    procedure Insert(AIndex: Integer; const AKeyValue: Variant; const ADisplayText: string);
    property Count: Integer read GetCount;
    property Items[Index: Integer]: PcxLookupListItem read GetItem; default;
  end;

  { TcxValueTypeClassList }

  TcxValueTypeClassList = class
  private
    FItems: TList;
    function GetCount: Integer;
    function GetItem(Index: Integer): TcxValueTypeClass;
  public
    constructor Create;
    destructor Destroy; override;
    function ItemByCaption(const ACaption: string): TcxValueTypeClass;
    procedure RegisterItem(AValueTypeClass: TcxValueTypeClass);
    procedure UnregisterItem(AValueTypeClass: TcxValueTypeClass);
    property Count: Integer read GetCount;
    property Items[Index: Integer]: TcxValueTypeClass read GetItem; default;
  end;

function cxValueTypeClassList: TcxValueTypeClassList;

function IsDateTimeValueTypeClass(AValueTypeClass: TcxValueTypeClass): Boolean;

implementation

uses
  cxVariants;

const
  RecordFlagSize = SizeOf(Byte);
  ValueFlagSize  = SizeOf(Byte);
  PointerSize    = SizeOf(Pointer);
  RecordIDSize   = SizeOf(Integer);
  // RecordFlag Bit Masks
  RecordFlag_Busy = $01;

var
  FValueTypeClassList: TcxValueTypeClassList;

function cxValueTypeClassList: TcxValueTypeClassList;
begin
  if FValueTypeClassList = nil then
    FValueTypeClassList := TcxValueTypeClassList.Create;
  Result := FValueTypeClassList;
end;

function IsDateTimeValueTypeClass(AValueTypeClass: TcxValueTypeClass): Boolean;
begin
  Result := (AValueTypeClass = TcxDateTimeValueType)
    {$IFDEF DELPHI6}{$IFNDEF NONDB} or (AValueTypeClass = TcxSQLTimeStampValueType){$ENDIF}{$ENDIF};
end;

function IncPChar(P: PChar; AOffset: Integer): PChar;
begin
  Result := P + AOffset;
end;

{ TcxValueType }

class function TcxValueType.Caption: string;
var
  I: Integer;
begin
  Result := ClassName;
  if Result <> '' then
  begin
    if Copy(Result, 1, 3) = 'Tcx' then
      Delete(Result, 1, 3);
    I := Pos('ValueType', Result);
    if I <> 0 then
      Delete(Result, I, Length('ValueType'));
  end;
end;

class function TcxValueType.CompareValues(P1, P2: Pointer): Integer;
begin
  Result := VarCompare(GetDataValue(P1), GetDataValue(P2));
end;

class function TcxValueType.GetValue(PBuffer: PChar): Variant;
begin
  Result := GetDataValue(PBuffer);
end;

class function TcxValueType.GetVarType: Integer;
begin
  Result := varVariant;
end;

class function TcxValueType.IsValueValid(var Value: Variant): Boolean;
var
  V: Variant;
begin
  if VarIsNull(Value) or (GetVarType = varVariant) then  // not Empty?
    Result := True
  else
  begin
    Result := False;
    try
      //!!! B92835 - Bug in TFMTBcdVariantType.Cast: dest (string variant for example) is not cleared before usage
      VarCast({Value}V, Value, GetVarType);
      Value := V;
      Result := True;
    except
      on E: EVariantError do;
    end;
  end;
end;

class function TcxValueType.IsString: Boolean;
begin
  Result := False;
end;

class procedure TcxValueType.PrepareValueBuffer(var PBuffer: PChar);
begin
end;

class function TcxValueType.Compare(P1, P2: Pointer): Integer;
begin
  Result := CompareValues(P1, P2);
end;

class procedure TcxValueType.FreeBuffer(PBuffer: PChar);
begin
end;

class procedure TcxValueType.FreeTextBuffer(PBuffer: PChar);
var
  P: PStringValue;
begin
  P := PPointer(PBuffer)^;
  if P <> nil then
    Dispose(P);
end;

class function TcxValueType.GetDataSize: Integer;
begin
  Result := 0;
end;

class function TcxValueType.GetDataValue(PBuffer: PChar): Variant;
begin
  Result := Null;
end;

class function TcxValueType.GetDefaultDisplayText(PBuffer: PChar): string;
begin
  try
    Result := VarToStr(GetDataValue(PBuffer));
  except
    on EVariantError do
      Result := '';
  end;
end;

class function TcxValueType.GetDisplayText(PBuffer: PChar): string;
var
  P: PStringValue;
begin
  P := PPointer(PBuffer)^;
  if P <> nil then
    Result := P^
  else
    Result := '';
end;

class procedure TcxValueType.ReadDataValue(PBuffer: PChar; AStream: TStream);
begin
  SetDataValue(PBuffer, ReadVariantFunc(AStream));
end;

class procedure TcxValueType.ReadDisplayText(PBuffer: PChar; AStream: TStream);
begin
  SetDisplayText(PBuffer, ReadStringFunc(AStream));
end;

class procedure TcxValueType.SetDataValue(PBuffer: PChar; const Value: Variant);
begin
end;

class procedure TcxValueType.SetDisplayText(PBuffer: PChar; const DisplayText: string);
var
  P: PStringValue;
begin
  P := PPointer(PBuffer)^;
  if P = nil then
  begin
    New(P);
    PPointer(PBuffer)^ := P;
  end;
  P^ := DisplayText;
end;

class procedure TcxValueType.WriteDataValue(PBuffer: PChar; AStream: TStream);
begin
  WriteVariantProc(AStream, GetDataValue(PBuffer));
end;

class procedure TcxValueType.WriteDisplayText(PBuffer: PChar; AStream: TStream);
begin
  WriteStringProc(AStream, GetDisplayText(PBuffer));
end;

{ TcxStringValueType }

class function TcxStringValueType.CompareValues(P1, P2: Pointer): Integer;
var
  S1, S2: string;
begin
  if Assigned(P1) then
  begin
    if Assigned(P2) then
    begin
      S1 := PStringValue(P1)^;
      S2 := PStringValue(P2)^;
      if S1 = S2 then
        Result := 0
      else
        if S1 < S2 then
          Result := -1
        else
          Result := 1;
    end
    else
      Result := 1;
  end
  else
  begin
    if Assigned(P2) then
      Result := -1
    else
      Result := 0;
  end;
end;

class function TcxStringValueType.GetValue(PBuffer: PChar): Variant;
begin
  Result := GetDataValue(@PBuffer);
end;

class function TcxStringValueType.GetVarType: Integer;
begin
  Result := varString;
end;

class function TcxStringValueType.IsString: Boolean;
begin
  Result := True;
end;

class procedure TcxStringValueType.PrepareValueBuffer(var PBuffer: PChar);
begin
  PBuffer := PPointer(PBuffer)^;
end;

class function TcxStringValueType.Compare(P1, P2: Pointer): Integer;
begin
  Result := CompareValues(PPointer(P1)^, PPointer(P2)^);
end;

class procedure TcxStringValueType.FreeBuffer(PBuffer: PChar);
begin
  Dispose(PStringValue(PPointer(PBuffer)^));
end;

class function TcxStringValueType.GetDataSize: Integer;
begin
  Result := SizeOf(PStringValue);
end;

class function TcxStringValueType.GetDataValue(PBuffer: PChar): Variant;
var
  P: PStringValue;
begin
  P := PPointer(PBuffer)^;
  if P <> nil then
    Result := P^
  else
    Result := inherited GetDataValue(PBuffer);
end;

class procedure TcxStringValueType.ReadDataValue(PBuffer: PChar; AStream: TStream);
begin
  SetDataValue(PBuffer, ReadStringFunc(AStream));
end;

class procedure TcxStringValueType.SetDataValue(PBuffer: PChar; const Value: Variant);
begin
  SetDisplayText(PBuffer, Value);
end;

class procedure TcxStringValueType.WriteDataValue(PBuffer: PChar; AStream: TStream);
begin
  WriteStringProc(AStream, GetDisplayText(PBuffer));
end;

{ TcxWideStringValueType }

class function TcxWideStringValueType.CompareValues(P1, P2: Pointer): Integer;
var
  WS1, WS2: WideString;
begin
  if Assigned(P1) then
  begin
    if Assigned(P2) then
    begin
      WS1 := PWideStringValue(P1)^;
      WS2 := PWideStringValue(P2)^;
      if WS1 = WS2 then
        Result := 0
      else
        if WS1 < WS2 then
          Result := -1
        else
          Result := 1;
    end
    else
      Result := 1;
  end
  else
  begin
    if Assigned(P2) then
      Result := -1
    else
      Result := 0;
  end;
end;

class function TcxWideStringValueType.GetValue(PBuffer: PChar): Variant;
begin
  Result := GetDataValue(@PBuffer);
end;

class function TcxWideStringValueType.GetVarType: Integer;
begin
  Result := varOleStr;
end;

class function TcxWideStringValueType.IsString: Boolean;
begin
  Result := True;
end;

class procedure TcxWideStringValueType.PrepareValueBuffer(var PBuffer: PChar);
begin
  PBuffer := PPointer(PBuffer)^;
end;

class function TcxWideStringValueType.Compare(P1, P2: Pointer): Integer;
begin
  Result := CompareValues(PPointer(P1)^, PPointer(P2)^);
end;

class procedure TcxWideStringValueType.FreeBuffer(PBuffer: PChar);
begin
  Dispose(PWideStringValue(PPointer(PBuffer)^));
end;

class function TcxWideStringValueType.GetDataSize: Integer;
begin
  Result := SizeOf(PWideStringValue);
end;

class function TcxWideStringValueType.GetDataValue(PBuffer: PChar): Variant;
var
  P: PWideStringValue;
begin
  P := PPointer(PBuffer)^;
  if P <> nil then
    Result := P^
  else
    Result := inherited GetDataValue(PBuffer);
end;

class procedure TcxWideStringValueType.ReadDataValue(PBuffer: PChar; AStream: TStream);
begin
  SetDataValue(PBuffer, ReadWideStringFunc(AStream));
end;

class procedure TcxWideStringValueType.SetDataValue(PBuffer: PChar; const Value: Variant);
var
  P: PWideStringValue;
begin
  P := PPointer(PBuffer)^;
  if P = nil then
  begin
    New(P);
    PPointer(PBuffer)^ := P;
  end;
  P^ := Value;
end;

class procedure TcxWideStringValueType.WriteDataValue(PBuffer: PChar; AStream: TStream);
begin
  WriteWideStringProc(AStream, VarToStr(GetDataValue(PBuffer)));
end;

{ TcxSmallintValueType }

class function TcxSmallintValueType.CompareValues(P1, P2: Pointer): Integer;
begin
  Result := PSmallInt(P1)^ - PSmallInt(P2)^;
end;

class function TcxSmallintValueType.GetVarType: Integer;
begin
  Result := varSmallint;
end;

class function TcxSmallintValueType.GetDataSize: Integer;
begin
  Result := SizeOf(SmallInt);
end;

class function TcxSmallintValueType.GetDataValue(PBuffer: PChar): Variant;
begin
  Result := PSmallInt(PBuffer)^;
end;

class procedure TcxSmallintValueType.ReadDataValue(PBuffer: PChar; AStream: TStream);
begin
  SetDataValue(PBuffer, ReadSmallIntFunc(AStream));
end;

class procedure TcxSmallintValueType.SetDataValue(PBuffer: PChar; const Value: Variant);
begin
  PSmallInt(PBuffer)^ := Value;
end;

class procedure TcxSmallintValueType.WriteDataValue(PBuffer: PChar; AStream: TStream);
begin
  WriteSmallIntProc(AStream, SmallInt(GetDataValue(PBuffer)));
end;

{ TcxIntegerValueType }

class function TcxIntegerValueType.CompareValues(P1, P2: Pointer): Integer;