propstorageeh.pas

最新的 DBGRIDEH4.0

begin
  if not (csDesigning in ComponentState) then
    RestoreEvents;
  FreeAndNil(FStoredProps);
  inherited Destroy;
end;

procedure TPropStorageEh.Loaded;
var
  Loading: Boolean;
begin
  Loading := csLoading in ComponentState;
  inherited Loaded;
  if not (csDesigning in ComponentState) then
  begin
    if Loading then SetEvents;
  end;
end;

function TPropStorageEh.GetForm: TForm;
begin
  if Owner is TCustomForm
    then Result := TForm(Owner as TCustomForm)
    else Result := nil;
end;

procedure TPropStorageEh.SetEvents;
begin
  if Owner is TCustomForm then
  begin
    with TForm(Form) do
    begin
      FSaveFormShow := OnShow;
      OnShow := FormShow;
      FSaveFormCloseQuery := OnCloseQuery;
      OnCloseQuery := FormCloseQuery;
      FSaveFormDestroy := OnDestroy;
      OnDestroy := FormDestroy;
    end;
  end;
end;

procedure TPropStorageEh.RestoreEvents;
begin
  if (Owner <> nil) and (Owner is TCustomForm) then
    with TForm(Form) do
    begin
      OnShow := FSaveFormShow;
      OnCloseQuery := FSaveFormCloseQuery;
      OnDestroy := FSaveFormDestroy;
    end;
end;

procedure TPropStorageEh.FormShow(Sender: TObject);
begin
  if Active then
    try
      LoadProperties;
    except
      if IsRaiseReadErrorEh then
        Application.HandleException(Self);
    end;
  if Assigned(FSaveFormShow) then
    FSaveFormShow(Sender);
end;

procedure TPropStorageEh.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  if Assigned(FSaveFormCloseQuery) then
    FSaveFormCloseQuery(Sender, CanClose);
  if CanClose and Active and (Owner is TCustomForm) and Form.HandleAllocated then
    try
      SaveProperties;
    except
      Application.HandleException(Self);
    end;
end;

procedure TPropStorageEh.FormDestroy(Sender: TObject);
begin
  if Active and not FSaved then
  begin
    FDestroying := True;
    try
      SaveProperties;
    except
      Application.HandleException(Self);
    end;
    FDestroying := False;
  end;
  if Assigned(FSaveFormDestroy) then
    FSaveFormDestroy(Sender);
end;

function TPropStorageEh.GetSection: String;
begin
  Result := FSection;
  if (Result = '') and not (csDesigning in ComponentState) then
    Result := GetDefaultSection(Owner);
end;

procedure TPropStorageEh.SetSection(const Value: String);
begin
  FSection := Value;
end;

procedure TPropStorageEh.Save;
begin
  if Assigned(FOnSavePlacement) then FOnSavePlacement(Self);
end;

procedure TPropStorageEh.SetStorageManager(const Value: TPropStorageManagerEh);
begin
  if FStorageManager <> Value then
  begin
    FStorageManager := Value;
    if Value <> nil then Value.FreeNotification(Self);
  end;
end;

procedure TPropStorageEh.SetStoredProps(const Value: TPropertyNamesEh);
begin
  FStoredProps.Assign(Value);
end;

procedure TPropStorageEh.WritePropValues(Stream: TStream);
var
  pw: TPropWriterEh;
begin
  pw := TPropWriterEh.Create(Stream, 1024);
  pw.OnWriteOwnerProps := WriteCustomProps;
  try
    pw.WriteOwnerProperties(Owner, StoredProps);
  finally
    pw.Free;
  end;
end;

procedure TPropStorageEh.ReadPropValues(Stream: TStream);
var
  pr: TPropReaderEh;
begin
  pr := TPropReaderEh.Create(Stream, 1024);
  pr.OnReadOwnerProp := ReadProp;
  try
    pr.ReadOwnerProperties(Owner);
  finally
    pr.Free;
  end;
end;

procedure TPropStorageEh.LoadProperties;
begin
  if Assigned(BeforeLoadProps) then
    BeforeLoadProps(Self);
  FSaved := False;
  if StorageManager <> nil then
    StorageManager.ReadProperties(Self)
  else if DefaultPropStorageManager <> nil then
    DefaultPropStorageManager.ReadProperties(Self);
  if Assigned(AfterLoadProps) then
    AfterLoadProps(Self);
end;

procedure TPropStorageEh.SaveProperties;
begin
  if Assigned(BeforeSaveProps) then
    BeforeSaveProps(Self);
  if StorageManager <> nil then
  begin
    StorageManager.WriteProperties(Self);
    FSaved := True;
  end else if DefaultPropStorageManager <> nil then
  begin
    DefaultPropStorageManager.WriteProperties(Self);
    FSaved := True;
  end;
  if Assigned(AfterSaveProps) then
    AfterSaveProps(Self);
end;

procedure TPropStorageEh.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FStorageManager) then
    StorageManager := nil;
end;

procedure TPropStorageEh.WriteCustomProps(Writer: TPropWriterEh);
begin
  if Assigned(OnWriteCustomProps) then
    OnWriteCustomProps(Self, Writer);
end;

procedure TPropStorageEh.ReadProp(Reader: TPropReaderEh; PropName: String;
  var Processed: Boolean);
begin
  if Assigned(OnReadProp) then
    OnReadProp(Self, Reader, PropName, Processed);
end;

{ TPropertyNamesEh }

function TPropertyNamesEh.CheckPropertyPath(Path: String): Boolean;
var
  Token: String;
  CurObject: TComponent;
begin
  CurObject := Root;
  Result := False;
  Token := GetNextPointSeparatedToken(Path);
  while True do
  begin
    if Token = '' then
      raise Exception.Create('Invalide property path: "' + Path + '"');
    if UpperCase(Token) = '<P>' then
    begin
      Result := CheckObjectPropertyPath(CurObject, Copy(Path, Length('<P>') + 2, Length(Path)));
      Exit;
    end;
    if (CurObject is TComponent)
      then CurObject := FindChildComponent(CurObject, Root, Token, True)
      else CurObject := nil;
    if CurObject = nil then Exit;
{$IFDEF CIL}
    Borland.Delphi.System.Delete(Path, 1, Length(Token) + 1);
{$ELSE}
    System.Delete(Path, 1, Length(Token) + 1);
{$ENDIF}
    Token := GetNextPointSeparatedToken(Path);
  end;
end;

function TPropertyNamesEh.CheckObjectPropertyPath(Instance: TObject; PropPath: String): Boolean;
var
  PropInfo: PPropInfo;
  PropName: String;
  dpl: TStringList;
//  ci: TCollectionItem;
  c: TCollection;
  i: Integer;
  ciList: TList;
  InterceptorClass: TReadPropertyInterceptorClass;

  function IsSpecCollectionPropName(PropName: String): Boolean;
  begin
    Result := (Instance is TCollection) and
              ( (UpperCase(PropName) = UpperCase('<ForAllItems>'))
                or
                (UpperCase(Copy(PropName, 1, 5)) = UpperCase('<Item') )
              );
  end;

begin
  ciList := TList.Create;
  try
    Result := False;
    while True do
    begin
      PropName := GetNextPointSeparatedToken(PropPath);
{$IFDEF CIL}
      Borland.Delphi.System.Delete(PropPath, 1, Length(PropName) + 1);
{$ELSE}
      System.Delete(PropPath, 1, Length(PropName) + 1);
{$ENDIF}

      if IsSpecCollectionPropName(PropName) then
      begin
        c := TCollection(Instance);
        if NlsUpperCase(PropName) = UpperCase('<ForAllItems>') then
        begin
          Result := True;
          Exit;
//        Some TCollectionItem does not allows to create with Collection = nil and get AV.
//        So does not check path after <ForAllItems>
//          ci := c.ItemClass.Create(nil);
//          Instance := ci;
//          ciList.Add(ci);
        end else if (Copy(PropName, 1, 5) = '<Item') then
        begin
          i := StrToInt(Copy(Copy(PropName, 1, Length(PropName)-1), 6, 100));
          if i < c.Count then
            Instance := c.Items[i];
        end;
        if PropPath = '' then
        begin
          Result := True;
          Exit;
        end;
        Continue;
      end;

      InterceptorClass := GetInterceptorForTarget(Instance.ClassType);
      if InterceptorClass <> nil then
      begin
        PropInfo := GetPropInfo(InterceptorClass.ClassInfo, PropName);
        if PropInfo = nil then
          PropInfo := GetPropInfo(Instance.ClassInfo, PropName);
      end else
        PropInfo := GetPropInfo(Instance.ClassInfo, PropName);
      if PropInfo = nil then
        if Instance is TPersistent then
        begin
          dpl := TStringList.Create;
          try
{$IFDEF EH_LIB_6}
            dpl.CaseSensitive := False;
{$ENDIF}
            GetDefinePropertyList(TPersistent(Instance), dpl);
            if dpl.IndexOf(PropName) = -1 then
              Exit;
          finally
            dpl.Free;
          end;
        end;
      if PropPath = '' then
      begin
        Result := True;
        Exit;
      end;
{$IFDEF CIL}
      if PropInfo.PropType.Kind = tkClass then
      begin
        Instance := GetObjectProp(Instance, PropInfo);
        if Instance = nil then
          Exit;
      end;
{$ELSE}
      if PropInfo^.PropType^.Kind = tkClass then
      begin
        Instance := TObject(GetOrdProp(Instance, PropInfo));
        if Instance = nil then
          Exit;
      end;
{$ENDIF}
    end;
  finally
    for i := 0 to ciList.Count - 1 do
      TCollectionItem(ciList[i]).Free;
    ciList.Free;
  end;
end;

procedure TPropertyNamesEh.CheckPropertyNames;
var
  i: Integer;
begin
  for i := Count - 1 downto 0 do
    if not CheckPropertyPath(Strings[i]) then
      Delete(i);
end;

function TPropertyNamesEh.CompareStrings(const S1, S2: string): Integer;
  function CompareStr(S1, S2: string): Integer;
  var
    Token1, Token2: String;
  begin
    Result := 0;
    if (S1 = '') and (S2 = '') then Exit;
    Token1 := GetNextPointSeparatedToken(S1);
    Token2 := GetNextPointSeparatedToken(S2);
 { TODO : Compare collection ____Item[i]: i as number }
    if (UpperCase(Token1) = '<P>') and (UpperCase(Token2) <> '<P>') then
      Result := -1
    else if (UpperCase(Token1) <> '<P>') and (UpperCase(Token2) = '<P>') then
      Result := 1
    else if (Copy(Token1, 1, 1) = '<') and
       (Copy(Token2, 1, 1) <> '<')
    then
      Result := 1
    else if (Copy(Token2, 1, 1) = '<') and
            (Copy(Token1, 1, 1) <> '<')
    then
      Result := -1
    else
    begin
      Result := NlsCompareText(Token1, Token2);
      if Result = 0 then
      begin
{$IFDEF CIL}
        Borland.Delphi.System.Delete(S1, 1, Length(Token1)+1);
        Borland.Delphi.System.Delete(S2, 1, Length(Token1)+1);
{$ELSE}
        System.Delete(S1, 1, Length(Token1)+1);
        System.Delete(S2, 1, Length(Token1)+1);
{$ENDIF}
        Result := CompareStr(S1, S2);
      end;
    end;
  end;
begin
  Result := CompareStr(S1, S2);
end;

procedure TPropertyNamesEh.SetRoot(const Value: TComponent);
begin
  FRoot := Value;
  CheckPropertyNames;
end;

function TPropertyNamesEh.Add(const S: string): Integer;
var
  i: Integer;
begin
  Result := -1;
  if (Root <> nil) and not (csLoading in Root.ComponentState) and not CheckPropertyPath(S)
  then
    Exit;
  for i := 0 to Count - 1 do
    if CompareStrings(Strings[i], S) = 0 then
      Exit
    else if CompareStrings(Strings[i], S) > 0 then
    begin
      Insert(i, S);
      Result := i;
      Exit;
    end;
  inherited Add(S);
end;

initialization
{$IFDEF EH_LIB_VCL}
  RegisterIntegerConsts(TypeInfo(HKEY), IdentToRegistryKey, RegistryKeyToIdent);
{$ENDIF}
finalization
  FreeAndNil(FDefaultStorageManager);
end.