cxstorage.pas

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

        SetPropertyValueByInterface;
    end
    else
      SetPropertyValueByInterface;
  end;
end;

procedure TcxStorage.SetStoredObject(AObject: TObject);
begin
  FStoredObject := AObject;
end;

function TcxStorage.TestClassProperty(const AName: string;
  AObject: TObject): Boolean;
begin
  if Assigned(FOnTestClassProperty) then
    Result := FOnTestClassProperty(AName, AObject)
  else
    Result := True;
end;

{ TcxCustomReader }

constructor TcxCustomReader.Create(const AStorageName: string);
begin
  inherited Create;
  StorageName := AStorageName;
end;

procedure TcxCustomReader.ReadChildren(const AObjectName, AClassName: string;
  AChildrenNames, AChildrenClassNames: TStrings);
begin
end;

procedure TcxCustomReader.ReadProperties(const AObjectName, AClassName: string; AProperties: TStrings);
begin
end;

function TcxCustomReader.ReadProperty(const AObjectName, AClassName, AName: string): Variant;
begin
  Result := Null;
end;

{ TcxCustomWriter }

constructor TcxCustomWriter.Create(const AStorageName: string; AReCreate: Boolean);
begin
  inherited Create;
  FStorageName := AStorageName;
  FReCreate := AReCreate;
end;

procedure TcxCustomWriter.BeginWriteObject(const AObjectName, AClassName: string);
begin
end;

procedure TcxCustomWriter.EndWriteObject(const AObjectName, AClassName: string);
begin
end;

procedure TcxCustomWriter.WriteProperty(const AObjectName, AClassName, AName: string; AValue: Variant);
begin
end;

{ TcxStreamReader }

constructor TcxStreamReader.Create(const AStorageName: string);
begin
  inherited Create(AStorageName);

  FReader := nil;
  FRootObject := nil;
  FCurrentObjectFullName := '';
end;

destructor TcxStreamReader.Destroy;
begin
  FReader.Free;
  FRootObject.Free;

  inherited Destroy;
end;

procedure TcxStreamReader.Read;
begin
  FRootObject.Free;
  FRootObject := TcxStreamObjectData.Create('', '');

  if (FStorageStream <> nil) and (FReader.Position < FStorageStream.Size) then
    FRootObject.Read(FReader);
end;

procedure TcxStreamReader.ReadChildren(const AObjectName, AClassName: string;
  AChildrenNames, AChildrenClassNames: TStrings);
var
  I: Integer;
  AObject: TcxStreamObjectData;
begin
  AObject := GetObject(AObjectName);
  if AObject <> nil then
  begin
    for I := 0 to AObject.ChildCount - 1 do
    begin
      AChildrenNames.Add(AObject.Children[I].Name);
      AChildrenClassNames.Add(AObject.Children[I].ClassName_);
    end;
  end;
end;

procedure TcxStreamReader.ReadProperties(const AObjectName, AClassName: string; AProperties: TStrings);
var
  AObject: TcxStreamObjectData;
  I: Integer;
begin
  AObject := GetObject(AObjectName);
  if AObject <> nil then
  begin
    for I := 0 to AObject.PropertyCount - 1 do
      AProperties.Add(AObject.Properties[I].Name);
  end;
end;

function TcxStreamReader.ReadProperty(const AObjectName, AClassName, AName: string): Variant;
var
  AProperty: TcxStreamPropertyData;
begin
  AProperty := GetProperty(GetObject(AObjectName), AName);
  if AProperty <> nil then
    Result := AProperty.Value
  else
    Result := Null;
end;

procedure TcxStreamReader.SetStream(AStream: TStream);
begin
  if FStorageStream <> AStream then
  begin
    FStorageStream := AStream;
    FReader.Free;
    FReader := TReader.Create(AStream, cxBufferSize);
  end;
end;

function TcxStreamReader.GetObject(const AObjectFullName: string): TcxStreamObjectData;
var
  AObjectName: string;
  AParents: TStringList;
begin
  if AObjectFullName = FCurrentObjectFullName then
    Result := FCurrentObject
  else
  begin
    AParents := TStringList.Create;
    try
      ExtractObjectFullName(AObjectFullName, AParents, AObjectName);
      Result := InternalGetObject(AObjectName, AParents);
      if Result <> nil then
      begin
        FCurrentObjectFullName := AObjectFullName;
        FCurrentObject := Result;
      end;
    finally
      AParents.Free;
    end;
  end;
end;

function TcxStreamReader.GetProperty(AObject: TcxStreamObjectData; const AName: string): TcxStreamPropertyData;
var
  I: Integer;
begin
  Result := nil;

  for I := 0 to AObject.PropertyCount - 1 do
    if AObject.Properties[I].Name = AName then
    begin
      Result := AObject.Properties[I];
      Break;
    end;
end;

function TcxStreamReader.InternalGetObject(const AObjectName: string; AParents: TStrings): TcxStreamObjectData;
var
  I, J: Integer;
  AObject: TcxStreamObjectData;
begin
  AParents.Add(AObjectName);
  AObject := FRootObject;
  for I := 1 to AParents.Count - 1 do
  begin
    for J := 0 to AObject.ChildCount - 1 do
    begin
      if AParents[I] = AObject.Children[J].Name then
      begin
        AObject := AObject.Children[J];
        Break;
      end;
    end;
  end;

  if AObject.Name = AObjectName then
    Result := AObject
  else
    Result := nil;
end;

{ TcxStreamWriter }

constructor TcxStreamWriter.Create(const AStorageName: string; AReCreate: Boolean);
begin
  inherited Create(AStorageName, AReCreate);

  FWriter := nil;
  FRootObject := nil;
  FCurrentObject := nil;
end;

destructor TcxStreamWriter.Destroy;
begin
  FWriter.Free;
  FRootObject.Free;
  inherited Destroy;
end;

procedure TcxStreamWriter.BeginWriteObject(const AObjectName, AClassName: string);
var
  AName: string;
  AParents: TStringList;
begin
  AParents := TStringList.Create;
  try
    ExtractObjectFullName(AObjectName, AParents, AName);
    CreateObject(AName, AClassName, AParents);
  finally
    AParents.Free;
  end;
end;

procedure TcxStreamWriter.SetStream(AStream: TStream);
begin
  FWriter.Free;
  FWriter := TWriter.Create(AStream, cxBufferSize);
end;

procedure TcxStreamWriter.Write;
begin
  if FRootObject <> nil then
    FRootObject.Write(FWriter);
  FRootObject.Free;
  FRootObject := nil;
  FCurrentObject := nil;
end;

procedure TcxStreamWriter.WriteProperty(const AObjectName, AClassName, AName: string; AValue: Variant);
begin
  if FCurrentObject <> nil then
    FCurrentObject.AddProperty(TcxStreamPropertyData.Create(AName, AValue));
end;

procedure TcxStreamWriter.CreateObject(const AObjectName, AClassName: string; AParents: TStrings);
var
  I, J: Integer;
  AObject: TcxStreamObjectData;
  ANewObject: TcxStreamObjectData;
begin
  if (FRootObject = nil) and (FCurrentObject = nil) then
  begin
    if AParents.Count = 0 then
    begin
      FRootObject := TcxStreamObjectData.Create(AObjectName, AClassName);
      FCurrentObject := FRootObject;
    end;
  end
  else
  begin
    AObject := FRootObject;
    for I := 1 to AParents.Count - 1 do
    begin
      for J := 0 to AObject.ChildCount - 1 do
      begin
        if AParents[I] = AObject.Children[J].Name then
        begin
          AObject := AObject.Children[J];
          Break;
        end;
      end;
    end;
    ANewObject := TcxStreamObjectData.Create(AObjectName, AClassName);
    FCurrentObject := ANewObject;
    AObject.AddChild(ANewObject);
  end;
end;

{ TcxRegistryReader }

constructor TcxRegistryReader.Create(const AStorageName: string);
begin
  inherited Create(AStorageName);

  FRegistry := TRegistry.Create(KEY_READ);
  if not FRegistry.OpenKey(GenRegistryPath(AStorageName), False) then
  //  raise ERegistryException.CreateFmt(cxGetResourceString(@scxCantOpenRegistryKey), [AStorageName]);

end;

destructor TcxRegistryReader.Destroy;
begin
  FRegistry.Free;

  inherited Destroy;
end;

procedure TcxRegistryReader.ReadChildren(const AObjectName, AClassName: string;
  AChildrenNames, AChildrenClassNames: TStrings);
var
  I: Integer;
  APath: string;
begin
  FRegistry.GetKeyNames(AChildrenNames);
  for I := 0 to AChildrenNames.Count - 1 do
    if AChildrenNames[I] = '[ClassName]' then
    begin
      AChildrenNames.Delete(I);
      Break;
    end;

  APath := FRegistry.CurrentPath;
  for I := 0 to AChildrenNames.Count - 1 do
  begin
    FRegistry.OpenKey(AChildrenNames[I] + '\[ClassName]', False);
    AChildrenClassNames.Add(FRegistry.ReadString('ClassName'));
    FRegistry.CloseKey;
    FRegistry.OpenKey(APath, False);
  end;
end;

procedure TcxRegistryReader.ReadProperties(const AObjectName, AClassName: string; AProperties: TStrings);
var
  AName: string;
  AParents: TStringList;
  ANewPath: string;
  I: Integer;
begin
  AParents := TStringList.Create;
  try
    ExtractObjectFullName(AObjectName, AParents, AName);
    ANewPath := GenRegistryPath(StorageName);
    for I := 0 to AParents.Count - 1 do
      ANewPath := ANewPath + '\' + AParents[I];
    if FRegistry.OpenKey(ANewPath + '\' + AName, False) then
      FRegistry.GetValueNames(AProperties);
  finally
    AParents.Free;
  end;
end;

function TcxRegistryReader.ReadProperty(const AObjectName, AClassName, AName: string): Variant;
var
  AValue: string;
  ARealValue: Double;
  ACode: Integer;
begin
  case FRegistry.GetDataType(AName) of
    rdString, rdExpandString:
    begin
      AValue := FRegistry.ReadString(AName);

      if IsStringValue(AValue) then
      begin
        Result := AValue;
        Exit;
      end;

      Val(AValue, ARealValue, ACode);
      if ACode = 0 then
        Result := ARealValue
      else
        Result := DateTimeOrStr(AValue);
    end;
    rdInteger:
      Result := FRegistry.ReadInteger(AName);
    rdBinary:
      Result := FRegistry.ReadFloat(AName);
    else
      Result := Null;
  end;
end;

{ TcxRegistryWriter }

constructor TcxRegistryWriter.Create(const AStorageName: string; AReCreate: Boolean);
begin
  inherited Create(AStorageName, AReCreate);

  FRegistry := TRegistry.Create;

  if FReCreate then
  begin
    if AStorageName <> '' then
      FRegistry.DeleteKey(GenRegistryPath(AStorageName));
    FRootKeyCreated := False;
  end;

  FRootKeyCreated := FRegistry.KeyExists(GenRegistryPath(AStorageName));
  FRootKeyOpened := False;
end;

destructor TcxRegistryWriter.Destroy;
begin
  FRegistry.Free;

  inherited Destroy;
end;

procedure TcxRegistryWriter.BeginWriteObject(const AObjectName, AClassName: string);
var
  AParents: TStringList;
  AName, APath: string;
  AResult: Boolean;
begin
  CreateRootKey;   
  AParents := TStringList.Create;
  try
    ExtractObjectFullName(AObjectName, AParents, AName);
    AResult := FRegistry.CreateKey(AName) and FRegistry.OpenKey(AName, False);
    APath := FRegistry.CurrentPath;
    if AResult then
    begin
      AResult := FRegistry.CreateKey('[ClassName]') and FRegistry.OpenKey('[ClassName]', False);
      if AResult then
      begin
        FRegistry.WriteString('ClassName', AClassName);
        FRegistry.CloseKey;
      end;
    end;
    AResult := AResult and FRegistry.OpenKey(APath, False);
    if not AResult then
      raise ERegistryException.CreateFmt(scxErrorStoreObject, [AObjectName]);
  finally
    AParents.Free;
  end;
end;