aprstore.pas

来自「delphi编程控件」· PAS 代码 · 共 993 行 · 第 1/2 页

    LastNumber := Pos('<', StsC[LinePosF]);
    St := Copy(StsC[LinePosF], 1, LastNumber - 1);
    if(FirstLevelFlag) then
      StsCollection.Add(St);
    St1 := Copy(StsC[LinePosF], LastNumber + 1, Pos('(', StsC[LinePosF]) - LastNumber - 1);
    LastNumber := LinePosF;
    StsF.Add(GetSpaces(SpaceNumber) + St + ' = <');
    Inc(SpaceNumber, 2);
    while (LastNumber < StsC.Count) And (Pos('<', StsC[LastNumber]) > 0)
    And (St = Copy(StsC[LinePosF], 1, Pos('<', StsC[LastNumber]) - 1)) do
      Inc(LastNumber);
    while (LinePosF < LastNumber) do begin
      StsF.Add(GetSpaces(SpaceNumber) + St1);
      St2 := Copy(StsC[LinePosF], 1, Pos('>', StsC[LinePosF]));
      i := LinePosF;
      while (i < LastNumber) And
      (St2 = Copy(StsC[i], 1, Pos('>', StsC[i]))) do begin
        StsC[i] := Copy(StsC[i], Pos('>', StsC[i]) + 2, MaxStringLength);
        Inc(i);
      end;
      while (LinePosF < i) do begin
        St := GetFullPropName;
        if(Pos('<', St) > 0) then
          RestoreCollection(SpaceNumber + 2, False)
        else
          if(Pos('(', St) > 0) then
            RestoreArray(SpaceNumber + 2)
          else
            if(Pos('{', St) > 0) then
              RestoreBinary(SpaceNumber + 2)
            else RestoreOrd(SpaceNumber + 2);
      end;
      if(LinePosF < LastNumber) then
        StsF.Add(GetSpaces(SpaceNumber) + EndObjectDecSt);
    end;
    StsF.Add(GetSpaces(SpaceNumber) + EndCollectionDecSt);
  end;

  procedure RestoreProp(SpaceNumber : Integer);
  Var
    St : String;
  begin
    St := GetFullPropName;
    if(Pos('<', St) > 0) then
      RestoreCollection(SpaceNumber, True)
    else
      if(Pos('(', St) > 0) then
        RestoreArray(SpaceNumber)
      else
        if(Pos('{', St) > 0) then
          RestoreBinary(SpaceNumber)
        else RestoreOrd(SpaceNumber);
  end;

Var
  i : Integer;
  PropInfo : PPropInfo;
  colObj : TPersistent;
  St, St1 : String;
begin
  FSaved := False;
  a := TMemoryStream.Create;
  b := TMemoryStream.Create;
  Sts := TStringList.Create;
  StsC := TStringList.Create;
  StsF := TStringList.Create;
  StsCollection := TStringList.Create;

  if Not FUseRegistry then
    RestoreFromIniFile(Sts)
  else RestoreFromRegistry(Sts);

  LinePos := 0;
  if Assigned(FOnBeforeRestore) then
    FOnBeforeRestore(self);
  CompNameSt := '';
  while LinePos < Sts.Count do begin
    CompNameSt := FindNextCompName;
    LinePosF := LinePos;
    FindNextCompName;
    StsC.Clear;
    StsF.Clear;
    StsCollection.Clear;
    Cmp := Owner.FindComponent(CompNameSt);
    if(Cmp = Nil) And (CompNameSt = Owner.Name) then
      Cmp := Owner;
    if(Cmp <> Nil) then begin
      i := Length(CompNameSt) + 2;
      while LinePosF < LinePos do begin
        if(Trim(Sts[LinePosF]) <> '') then
          StsC.Add(Copy(Sts[LinePosF], i, MaxStringLength));
        Inc(LinePosF);
      end;
      StsF.Add(BeginObjectDecSt + ' ' + cmp.Name + ': ' + cmp.ClassName);
      LinePosF := 0;
      while LinePosF < StsC.Count do
        RestoreProp(2);

      StsF.Add(EndObjectDecSt);

      for i := 0 to StsCollection.Count - 1 do begin
        St := StsCollection[i];
        colObj := cmp;
        while(Pos('.', St) > 0) do begin
          St1 := Copy(St, 1, Pos('.', St) - 1);
          St := Copy(St, Pos('.', St) + 1, 1000);
          PropInfo := GetPropInfo(colObj.ClassInfo, St1);
          colobj := TPersistent(GetOrdProp(colObj, PropInfo));            
        end;

        PropInfo := GetPropInfo(colObj.ClassInfo, St);
        Collection := TCollection(GetOrdProp(colObj, PropInfo));
        if(Collection <> Nil) then begin
          Collection.Clear;
        end;
      end;
      a.Clear;
      b.Clear;
      StsF.SaveToStream(b);
      b.Position := 0;
      ObjectTextToResource(b, a);
      a.Position := 0;
      ReadComponent(Cmp);
    end;
  end;

  if Assigned(FOnAfterRestore) then
    FOnAfterRestore(self);

  Sts.Free;
  StsC.Free;
  StsF.Free;
  StsCollection.Free;
  a.Free;
  b.Free;
end;

procedure TAutoPropertiesStore.SaveProperties;
Var
  Sts, StsF : TStringList;
  LinePos, FSpaceNumber : Integer;
  cmp : TComponent;
  FullPropName : String;

  function GetSpaceNumber : Integer;
  begin
    Result := 0;
    while Sts[LinePos][Result + 1] = ' ' do Inc(Result);
  end;

  function GetPropName : String;
  Var
    gpni, gpni1  : Integer;
  begin
    Result := TrimLeft(Sts[LinePos]);
    gpni := Pos('.', result);
    gpni1 := Pos('=', result);    
    if(gpni < 1) Or (gpni > gpni1) then
      gpni := Pos(' ', result);
    Result := Copy(Result, 1, gpni -1)
  end;

  function GetFullPropName : String;
  begin
    Result := Trim(Copy(Sts[LinePos], 1, Pos('=', Sts[LinePos]) - 1));
  end;

  function FindNextCompName : String;
  begin
    Result := '';
    while((LinePos < Sts.Count) And (Pos(BeginObjectDecSt, Sts[LinePos]) < 1)) do
      Inc(LinePos);
    if(LinePos < Sts.Count) then begin
      Result := Copy(Sts[LinePos],
      Pos(BeginObjectDecSt, Sts[LinePos]) + BeginObjectDecL + 1, MaxStringLength);
      Result := Copy(Result, 1, Pos(':', Result) - 1);
    end;
  end;

  procedure SaveOrdProp(ASts : TStrings);
  Var
    St, StProp : String;
    i : Integer;
  begin
    St := Trim(Sts[LinePos]);
    StProp := GetPropName;
    i := Pos('=', St);
    St := Copy(St, 1, i - 2) + '=' + Copy(St, i + 2, MaxStringLength);
    ASts.Add(FullPropName + St);
    Inc(LinePos);
    St := Trim(St);
    if(St[Length(St)] = '=')  then begin
      ASts[ASts.Count - 1] := ASts[ASts.Count - 1] + '@';
      St := Sts[LinePos];
      St := Trim(St);
      i := 1;
      while (St <> '') And (St[1] = '''') do begin
        ASts.Add(FullPropName + '@' + StProp + IntToStr(i) + '=' + St);
        Inc(LinePos);
        Inc(i);        
        if(LinePos < Sts.Count) then begin
          St := Sts[LinePos];
          St := Trim(St);
        end else St := '';
      end;
    end;
  end;

  procedure SaveArray(ASts : TStrings);
  Var
    St, St1 : String;
    Flag : Boolean;
    Index : Integer;
  begin
    St := FullPropName + GetFullPropName + '(';
    Inc(LinePos);
    FLag := True;
    Index := 0;
    while Flag do begin
      St1 := TrimLeft(Sts[LinePos]);
      if (Length(St1) > 0) And (St1[Length(St1)] = ')') then begin
        St1 := Copy(St1, 1, Length(St1) - 1);
        Flag := False;
      end;
      ASts.Add(St + IntToStr(Index) + ')' + '=' + St1);
      Inc(LinePos);
      Inc(Index);
    end;
  end;

  procedure SaveBinary(ASts : TStrings);
  Var
    St, St1, St2 : String;
    BSts : TStringList;
    Flag : Boolean;
    cmp1 : TComponent;
  begin
    BSts := TStringList.Create;
    St := FullPropName + GetFullPropName;
    cmp1 := cmp;
    St2 := '';
    while cmp1.Owner <> Nil do begin
      St2 := cmp1.Name  + '.' +  St2;
      cmp1 := cmp1.Owner;
    end;
    St2 := St2 + St;
    ASts.Add(St + '{}=' + St2);
    Inc(LinePos);
    FLag := True;
    while Flag do begin
      St1 := TrimLeft(Sts[LinePos]);
      if(St1[Length(St1)] = '}') then begin
        St1 := Copy(St1, 1, Length(St1) - 1);
        Flag := False;
      end;
      BSts.Add(St1);
      Inc(LinePos);
    end;
    SaveBinaryToBinFile(St2, BSts);
    BSts.Free;
  end;

  procedure SaveCollection(ASts : TStrings; ASt : String);
  Var
    St, St1, St2 : String;
    ch : Char;
    Index : Integer;
  begin
    St := ASt + GetFullPropName;
    Inc(LinePos);
    St1 := Trim(Sts[LinePos]);
    Inc(LinePos);
    Index := 0;
    FullPropName := St + '<' + St1 + '(' + IntToStr(Index) + ')>.';
    St2 := Trim(Sts[LinePos]);
    while St2 <> EndCollectionDecSt do begin
      if(St2 = St1) then
        Inc(LinePos)
      else
        if(St2 = EndObjectDecSt) then begin
          Inc(LinePos);
          Inc(Index);
          FullPropName :=  St + '<' + St1 + '(' + IntToStr(Index) + ')>.';
        end
        else begin
          ch := Sts[LinePos][Length(Sts[LinePos])];
          if(ch = '(') then //Array
             SaveArray(ASts)
          else
            if(ch = '{') then //Binary
               SaveBinary(ASts)
            else
              if(ch = '<')  then //Collection
                SaveCollection(ASts, St + '<' + St1 + '(' + IntToStr(Index) + ')>.')
              else  SaveOrdProp(ASts);
        end;
      St2 := Trim(Sts[LinePos]);
    end;
    FullPropName :=  ASt;
    Inc(LinePos);
  end;

  procedure GetPropValue(ASts : TStrings);
  Var
    ch : Char;
  begin
    FullPropName := '';

    if(ASts = Nil) then begin
      while (FSpaceNumber < GetSpaceNumber) do
        Inc(LinePos);
      Inc(LinePos);        
      exit;
    end;

    if(ASts <> Nil) then begin
      ASts.Clear;
      ch := Sts[LinePos][Length(Sts[LinePos])];
      if(ch = '(') then begin //Array
        SaveArray(ASts);
        exit;
      end;
      if(ch = '<')  then begin //Collection
        SaveCollection(ASts, '');
        exit;
      end;
      if(ch = '{') then begin//Binary
        SaveBinary(ASts);
        exit;
      end;
      SaveOrdProp(ASts);
    end;
  end;

Var
  a, b : TMemoryStream;
  i, j : Integer;
  St : String;
  StsV, DStoredProp : TStringList;
  objStore : TAutoObjectStore;
  pInfo : PPropInfo;
begin
  if(self.Owner = Nil) or (Items.Count = 0) then exit;

  if Assigned(FOnBeforeSave) then FOnBeforeSave(self);

  a := TMemoryStream.Create;
  b := TMemoryStream.Create;
  a.WriteComponentRes(self.Owner.ClassName, self.Owner);
  a.Position := 0;
  ObjectResourceToText(a, b);
  b.Position := 0;
  Sts := TStringList.Create;
  StsF := TStringList.Create;
  StsV := TStringList.Create;
  DStoredProp := TStringList.Create;
  Sts.LoadFromStream(b);
  LinePos := 0;
  while LinePos < Sts.Count do begin
    St := FindNextCompName;
    if (St <> '') then begin
      cmp := self.Owner.FindComponent(St);
      if(Cmp = Nil) And (St = self.Owner.Name) then
        Cmp := Owner;
      if (cmp <> Nil) then
        i := Items.IndexOfComponent(cmp)
      else i := -1;
      if(i > -1) then begin
        objStore := Items[i];
        i := LinePos;
        Inc(LinePos);
        FindNextCompName;
        j := LinePos;
        LinePos := i + 1;
        FSpaceNumber := GetSpaceNumber;
        DStoredProp.Clear;
        while LinePos < j do begin
           St := GetPropName;
           if(objStore.FStoredProp.IndexOf(St) > -1) then begin
             GetPropValue(StsV);
             DStoredProp.Add(St);
             for i := 0 to StsV.Count - 1 do
               StsF.Add(cmp.Name + '.' + StsV[i]);
           end else GetPropValue(Nil);
        end;
        for i := 0 to objStore.FStoredProp.Count - 1 do
          if(DStoredProp.IndexOf(objStore.FStoredProp[i])  = -1) then begin
            pInfo := GetPropInfo(cmp.ClassInfo, objStore.FStoredProp[i]);
            if (pInfo <> Nil) And (pInfo^.PropType^.Kind = tkEnumeration) then
              StsF.Add(cmp.Name + '.' + objStore.FStoredProp[i] + '=' +
                       GetEnumName(pInfo^.PropType{$IFDEF DELPHI3_0}^{$ENDIF}, (GetOrdProp(cmp, pInfo))));
          end;
      end else Inc(LinePos);
    end else Inc(LinePos);
  end;
  DStoredProp.Free;
  Sts.Free;
  StsV.Free;
  a.Free;
  b.Free;
  if Not FUseRegistry then
    SaveToIniFile(StsF)
  else SaveToRegistry(StsF);
  StsF.Free;
  FSaved := True;

  if Assigned(FOnAfterSave) then FOnAfterSave(self);

end;

procedure TAutoPropertiesStore.RestoreFromIniFile(ASts : TStrings);
Var
  inf : TIniFile;
begin
  inf := TIniFile.Create(IniFileName);
  inf.ReadSectionValues(IniSection, ASts);
  inf.Free;
end;

procedure TAutoPropertiesStore.RestoreFromRegistry(ASts : TStrings);
Var
  inf : TRegIniFile;
begin
  inf := TRegIniFile.Create(IniFileName);
  inf.ReadSectionValues(IniSection, ASts);
  inf.Free;
end;


procedure TAutoPropertiesStore.RestoreBinaryFromBinFile(AName : String; ASts : TStrings);
Var
  inf : TIniFile;
  i : Integer;
begin
  inf := TIniFile.Create(BinaryFileName);
  inf.ReadSectionValues(AName, ASts);
  for i := 0 to ASts.Count - 1 do
    ASts[i] := Copy(ASts[i], Pos('=',ASts[i]) + 1, MaxStringLength);
  inf.Free;
end;

procedure TAutoPropertiesStore.SaveToIniFile(ASts : TStrings);
Var
  inf : TIniFile;
  i, j : Integer;
  St : String;
begin
  inf := TIniFile.Create(IniFileName);
  inf.EraseSection(IniSection);
  for i := 0 to ASts.Count - 1 do begin
    j := Pos('=',ASts[i]);
    if(j > 0) then begin
      St := Copy(ASts[i], j + 1, MaxStringLength);
      if(St <> '') And (St[1] = '''') then
        St := '''' + St + '''';
      inf.WriteString(IniSection, Copy(ASts[i], 1, j - 1) , St);
    end;
  end;
  inf.Free;  
end;

procedure TAutoPropertiesStore.SaveToRegistry(ASts : TStrings);
Var
  inf : TRegIniFile;
  i, j : Integer;
  St : String;
begin
  inf := TRegIniFile.Create(IniFileName);
  inf.EraseSection(IniSection);
  for i := 0 to ASts.Count - 1 do begin
    j := Pos('=',ASts[i]);
    if(j > 0) then begin
      St := Copy(ASts[i], j + 1, MaxStringLength);
      inf.WriteString(IniSection, Copy(ASts[i], 1, j - 1) , St);
    end;
  end;
  inf.Free;
end;


procedure TAutoPropertiesStore.SaveBinaryToBinFile(AName : String; ASts : TStrings);
Var
  inf : TIniFile;
  i : Integer;
begin
  inf := TIniFile.Create(BinaryFileName);
  inf.EraseSection(AName);
  for i := 0 to ASts.Count - 1 do
    inf.WriteString(AName, 'I' + IntToStr(i) , ASts[i]);
  inf.Free;
end;



end.