cxstorage.pas

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

var
  AInt: Integer;
  I: Integer;
begin
  AInt := Integer(ASet);
  if ASize < SizeOf(Integer) then
    AInt := AInt and (1 shl (ASize * 8) - 1);
  Result := '';
  for I := 0 to SizeOf(Integer) * 8 - 1 do
  begin
    if AInt and 1 <> 0 then
    begin
      if I > High(AEnumNames) then
        raise EPropertyConvertError.Create('');
      if Result <> '' then
        Result := Result + ',';
      Result := Result + AEnumNames[I];
    end;
    AInt := AInt shr 1;
  end;
  Result := '[' + Result + ']';
end;

procedure StringToSet(AString: string; var ASet; ASize: Integer; AEnumNames: array of string);

  function FindEnum(const AStr: string): Integer;
  var
    I: Integer;
    AUpperCaseStr: string;
  begin
    Result := -1;
    AUpperCaseStr := UpperCase(AStr);
    for I := 0 to High(AEnumNames) do
      if AUpperCaseStr = UpperCase(AEnumNames[I]) then
      begin
        Result := I;
        Break;
      end;
  end;

var
  AInt: Integer;

  procedure AddBit(const AStr: string);
  var
    AIndex: Integer;
  begin
    AIndex := FindEnum(AStr);
    if AIndex <> -1 then
    begin
      AIndex := 1 shl AIndex;
      AInt := AInt or AIndex;
    end;
  end;

var
  I: Integer;
  AEnumString: string;
begin
  if (AString <> '') and (AString[1] = '[') and (AString[Length(AString)] = ']') then
  begin
    AInt := 0;
    AEnumString := '';
    Delete(AString, 1, 1);
    Delete(AString, Length(AString), 1);
    for I := 1 to Length(AString) do
    begin
      if AString[I] = ',' then
      begin
        AddBit(AEnumString);
        AEnumString := '';
      end
      else
        AEnumString := AEnumString + AString[I];
    end;
    if AEnumString <> '' then
      AddBit(AEnumString);
    Move(AInt, ASet, ASize);
  end
  else
    raise EPropertyConvertError.Create('');
end;

{$IFNDEF DELPHI5}
function SetSetProp(APropInfo: PPropInfo; const AValue: string): Integer;
type
  TIntegerSet = set of 0..SizeOf(Integer) * 8 - 1;
var
  P: PChar;
  AEnumName: string;
  AEnumValue: Longint;
  AEnumInfo: PTypeInfo;

  function NextWord(var P: PChar): string;
  var
    I: Integer;
  begin
    I := 0;
    while not (P[I] in [',', ' ', #0, ']']) do
      Inc(I);
    SetString(Result, P, I);
    while P[I] in [',', ' ', ']'] do
      Inc(I);
    Inc(P, I);
  end;

begin
  Result := 0;
  if AValue = '' then
    Exit;
  P := PChar(AValue);
  while P^ in ['[', ' '] do
    Inc(P);
  AEnumInfo := GetTypeData(APropInfo^.PropType^)^.CompType^;
  AEnumName := NextWord(P);
  while AEnumName <> '' do
  begin
    if AEnumInfo^.Kind = tkInteger then
      AEnumValue := StrToInt(AEnumName)
    else
      AEnumValue := GetEnumValue(AEnumInfo, AEnumName);
    if AEnumValue < 0 then
      raise EPropertyConvertError.CreateFmt(cxGetResourceString(@scxInvalidPropertyElement), [AEnumName]);
    Include(TIntegerSet(Result), AEnumValue);
    AEnumName := NextWord(P);
  end;
end;

function GetObjectProp(AObject: TObject; APropInfo: PPropInfo): TObject;
begin
  Result := TObject(GetOrdProp(AObject, APropInfo));
end;

procedure SetObjectProp(AObject: TObject; APropInfo: PPropInfo; AValue: TObject);
begin
  if AValue is GetObjectPropClass(AObject, APropInfo) then
    SetOrdProp(AObject, APropInfo, Integer(AValue));
end;

function GetObjectPropClass(AObject: TObject; APropInfo: PPropInfo): TClass;
var
  ATypeData: PTypeData;
begin
  ATypeData := GetTypeData(APropInfo^.PropType^);
  if ATypeData = nil then
    raise EPropertyError.Create('');
  Result := ATypeData^.ClassType;
end;
{$ENDIF}

function GenRegistryPath(const ARoot: string): string;
begin
  Result := ARoot;
  if Length(Result) > 0 then
    if Result[1] <> '\' then
      Result := '\' + Result;
end;

function DateTimeOrStr(AValue: string): Variant;
var
  ADateTimeValue: TDateTime;
begin
  {$IFDEF DELPHI6}
  if TryStrToDateTime(AValue, ADateTimeValue) then
    Result := ADateTimeValue
  else
    Result := AValue;
  {$ELSE}
  try
    ADateTimeValue := StrToDateTime(AValue);
    Result := ADateTimeValue;
  except
    on EConvertError do
      Result := AValue;
  end;
  {$ENDIF}
end;

procedure ExtractObjectFullName(const AObjectFullName: string; AParents: TStrings; var AObjectName: string);
var
  I: Integer;
  AName: string;
begin
  if AParents <> nil then
  begin
    AObjectName := '';
    AName := '';
    for I := 1 to Length(AObjectFullName) do
    begin
      if AObjectFullName[I] = '/' then
      begin
        AParents.Add(AName);
        AName := '';
      end
      else
        AName := AName + AObjectFullName[I];
    end;
    AObjectName := AName;
  end;
end;

function CorrectStringValue(AValue: string): string;
begin
  Result := '"' + AValue + '"';
end;

function IsStringValue(var AValue: string): Boolean;
begin
  Result := False;
  if (Length(AValue) >= 2) and (AValue[1] = '"') and (AValue[Length(AValue)] = '"') then
  begin
    Delete(AValue, 1, 1);
    Delete(AValue, Length(AValue), 1);
    Result := True;
  end;
end;

{ TcxStorage }

constructor TcxStorage.Create(const AStorageName: string; AStorageStream: TStream);
begin
  inherited Create;
  FStorageName := AStorageName;
  FStream := AStorageStream;
  FReCreate := True;
end;

constructor TcxStorage.Create(const AStorageName: string);
begin
  Create(AStorageName, nil);
end;

constructor TcxStorage.Create(AStream: TStream);
begin
  Create('', AStream);
end;

procedure TcxStorage.RestoreFrom(AObject: TObject; AReaderClass: TcxCustomReaderClass);
var
  AReader: TcxCustomReader;
begin
  SetStoredObject(AObject);
  AReader := AReaderClass.Create(FStorageName);
  try
    InternalRestoreFrom(AReader);
  finally
    AReader.Free;
  end;
end;

procedure TcxStorage.RestoreWithExistingReader(AObject: TObject; AReader: TcxCustomReader);
begin
  if AReader <> nil then
  begin
    SetStoredObject(AObject);
    if AReader is TcxStreamReader then
      TcxStreamReader(AReader).Read;
    InternalRestoreFrom(AReader);
  end;
end;

procedure TcxStorage.RestoreFromIni(AObject: TObject);
begin
  if not FileExists(FStorageName) then
    Exit;
  RestoreFrom(AObject, TcxIniFileReader);
end;

procedure TcxStorage.RestoreFromRegistry(AObject: TObject);
begin
  RestoreFrom(AObject, TcxRegistryReader);
end;

procedure TcxStorage.RestoreFromStream(AObject: TObject);
var
  AReader: TcxStreamReader;
begin
  if (FStream = nil) or (FStream.Size = 0) then
    Exit;

  SetStoredObject(AObject);
  AReader := TcxStreamReader.Create(FStorageName);
  AReader.SetStream(FStream);
  try
    AReader.Read;
    InternalRestoreFrom(AReader);
  finally
    AReader.Free;
  end;
end;

procedure TcxStorage.StoreTo(AObject: TObject; AWriterClass: TcxCustomWriterClass);
var
  AWriter: TcxCustomWriter;
begin
  SetStoredObject(AObject);
  AWriter := AWriterClass.Create(FStorageName, ReCreate);
  try
    InternalStoreTo(AWriter);
  finally
    AWriter.Free;
  end;
end;

procedure TcxStorage.StoreWithExistingWriter(AObject: TObject; AWriter: TcxCustomWriter);
begin
  if AWriter <> nil then
  begin
    SetStoredObject(AObject);
    InternalStoreTo(AWriter);
    if AWriter is TcxStreamWriter then
      TcxStreamWriter(AWriter).Write;
  end;
end;

procedure TcxStorage.StoreToIni(AObject: TObject);
begin
  StoreTo(AObject, TcxIniFileWriter);
end;

procedure TcxStorage.StoreToRegistry(AObject: TObject);
begin
  StoreTo(AObject, TcxRegistryWriter);
end;

procedure TcxStorage.StoreToStream(AObject: TObject);
var
  AWriter: TcxStreamWriter;
begin
  if FStream = nil then
    Exit;
  SetStoredObject(AObject);

  AWriter := TcxStreamWriter.Create(FStorageName);
  AWriter.SetStream(FStream);
  try
    InternalStoreTo(AWriter);
    AWriter.Write;
  finally
    AWriter.Free;
  end;
end;

function TcxStorage.CreateChild(const AObjectName, AClassName: string): TObject;
var
  AInterface: IcxStoredParent;
begin
  Result := nil;
  if Supports(FStoredObject, IcxStoredParent, AInterface) then
    Result := AInterface.CreateChild(AObjectName, AClassName);
  if Result = nil then
  begin
    if FStoredObject is TCollection then
      Result := (FStoredObject as TCollection).Add
  end;
end;

procedure TcxStorage.CreateChildrenNames(AChildren: TStringList);
var
  I: Integer;
begin
  for I := 0 to AChildren.Count - 1 do
    if AChildren[I] = '' then
      AChildren[I] := GetObjectName(AChildren.Objects[I]);
end;

procedure TcxStorage.DeleteChild(const AObjectName: string; AObject: TObject);
var
  AInterface: IcxStoredParent;
begin
  if Supports(FStoredObject, IcxStoredParent, AInterface) then
    AInterface.DeleteChild(AObjectName, AObject)
  else
    if FStoredObject is TCollection then
      AObject.Free;
end;

procedure TcxStorage.GetAllPublishedClassProperties(AProperties: TStrings);
var
  APropList: PPropList;
  ATypeInfo: PTypeInfo;
  ATypeData: PTypeData;
  I: Integer;
begin
  ATypeInfo := FStoredObject.ClassInfo;
  if ATypeInfo = nil then
    Exit;
  ATypeData := GetTypeData(ATypeInfo);

  if ATypeData.PropCount > 0 then
  begin
    GetMem(APropList, SizeOf(PPropInfo) * ATypeData.PropCount);
    try
      GetPropInfos(ATypeInfo, APropList);
      for I := 0 to ATypeData.PropCount - 1 do
        if APropList[I].PropType^.Kind = tkClass then
          AProperties.Add(APropList[I].Name);
    finally
      FreeMem(APropList, SizeOf(PPropInfo) * ATypeData.PropCount);
    end;
  end;
end;

procedure TcxStorage.GetAllPublishedProperties(AProperties: TStrings);
var
  APropList: PPropList;
  ATypeInfo: PTypeInfo;
  ATypeData: PTypeData;
  I: Integer;
begin
  ATypeInfo := FStoredObject.ClassInfo;
  if ATypeInfo = nil then
    Exit;
  ATypeData := GetTypeData(ATypeInfo);

  if ATypeData.PropCount > 0 then
  begin
    GetMem(APropList, SizeOf(PPropInfo) * ATypeData.PropCount);
    try
      GetPropInfos(ATypeInfo, APropList);
      for I := 0 to ATypeData.PropCount - 1 do
        if APropList[I].PropType^.Kind <> tkMethod then
          AProperties.Add(APropList[I].Name);
    finally
      FreeMem(APropList, SizeOf(PPropInfo) * ATypeData.PropCount);
    end;
  end;
end;

procedure TcxStorage.GetChildren(AChildren: TStringList);
var
  AInterface: IcxStoredParent;
  I: Integer;
  AClassProperties: TStringList;
  AClassProperty: TObject;
begin
  if Supports(FStoredObject, IcxStoredParent, AInterface) then
    AInterface.GetChildren(AChildren);
  if smSavePublishedClassProperties in GetStorageModes then
  begin
    AClassProperties := TStringList.Create;
    try
      if (FStoredObject is TCollection) and