base_sys.pas

来自「Delphi脚本控件」· PAS 代码 · 共 3,083 行 · 第 1/5 页

constructor TPaxIDRec.Create(ID, N, Pos: Integer);
begin
  Self.ID := ID;
  Self.N := N;
  Self.Pos := Pos;
end;

function TPaxIDRecList.GetRecord(I: Integer): TPaxIDRec;
begin
  result := TPaxIDRec(Objects[I]);
end;

procedure TDefaultParameterRec.SaveToStream(S: TStream);
begin
  SaveInteger(SubID, S);
  SaveInteger(ID, S);
  SaveVariant(Value, S);
end;

procedure TDefaultParameterRec.LoadFromStream(S: TStream);
begin
  SubID := LoadInteger(S);
  ID := LoadInteger(S);
  Value := LoadVariant(S);
end;

destructor TDefaultParameterList.Destroy;
var
  I: Integer;
begin
  for I:=0 to Count - 1 do
    Records[I].Free;
  inherited;
end;

function TDefaultParameterList.GetRecord(I: Integer): TDefaultParameterRec;
begin
  result := TDefaultParameterRec(Items[I]);
end;

procedure TDefaultParameterList.AddParameter(SubID, ID: Integer; const Value: Variant);
var
  R: TDefaultParameterRec;
begin
  R := TDefaultParameterRec.Create;
  R.SubID := SubID;
  R.ID := ID;
  R.Value := Value;
  Add(R);
end;

function TDefaultParameterList.FindFirst(SubID: Integer): Integer;
var
  I: Integer;
begin
  for I:=0 to Count - 1 do
    if Records[I].SubID = SubID then
    begin
      result := I;
      Exit;
    end;
  result := -1;
end;

function TDefaultParameterList.FindNext(I, SubID: Integer): Integer;
begin
  result := -1;
  if I < Count - 1 then
  begin
    Inc(I);
    if Records[I].SubID = SubID then
      result := I;
  end;
end;

procedure TDefaultParameterList.SaveToStream(S: TStream);
var
  R: TDefaultParameterRec;
  I: Integer;
begin
  SaveInteger(Count, S);
  for I:=0 to Count - 1 do
  begin
    R := GetRecord(I);
    R.SaveToStream(S);
  end;
end;

procedure TDefaultParameterList.LoadFromStream(S: TStream);
var
  I, K: Integer;
  R: TDefaultParameterRec;
begin
  for I:=0 to Count - 1 do
    Records[I].Free;
  Clear;
  K := LoadInteger(S);
  for I:=0 to K - 1 do
  begin
    R := TDefaultParameterRec.Create;
    R.LoadFromStream(S);
    Add(R);
  end;
end;

function IsDigits(const S: String): Boolean;
var
  I: Integer;
begin
  result := true;
  for I:=1 to Length(S) do
    if not (S[I] in ['0'..'9']) then
    begin
      result := False;
      Exit;
    end;
end;

function CreateAlias(P: PVariant): Variant;
begin
  TVarData(result).VType := varAlias;
  TVarData(result).VInteger := Integer(P);
end;

function IsAlias(P: PVariant): Boolean;
begin
  result := VarType(P^) = varAlias;
end;

function GetTerminal(P: PVariant): PVariant;
begin
  result := P;
  while VarType(result^) = varAlias do
    result := PVariant(TVarData(result^).VInteger);
end;

constructor TPAXVariantStack.Create;
begin
  SetLength(A, FirstStackSize);
  L := Length(A) - 1;

  Card := 0;
end;

destructor TPAXVariantStack.Destroy;
begin
  Clear;
  inherited;
end;

procedure TPAXVariantStack.Clear;
begin
  while Card > 0 do
    Pop;
end;

function TPAXVariantStack.Push(const V: Variant): PVariant;
begin
  if Card = L then
  begin
    SetLength(A, Card + DeltaStackSize);
    L := Length(A) - 1;
  end;

  Inc(Card);
  A[Card] := V;
  result := @A[Card];
end;

function TPAXVariantStack.Top: Variant;
begin
  result := A[Card];
end;

procedure TPAXVariantStack.Pop;
begin
  VarClear(A[Card]);
  Dec(Card);
end;

function GetPAXType(const V: Variant): Integer;
begin
  case VarType(V) of
    varInteger: result := typeINTEGER;
    varDouble: result := typeDOUBLE;
    varString: result := typeSTRING;
    varBoolean: result := typeBOOLEAN;
  else
    result := typeVARIANT;
  end;
end;

function CompareIntegers(P1, P2: Pointer): Integer;
begin
  if Integer(P1) > Integer(P2) then
    result := 1
  else if Integer(P1) = Integer(P2) then
    result := 0
  else
    result := -1;
end;

procedure SortList(L: TList; CompareItems: TCompareItems; I1, I2: Integer);
var
  P: Pointer;
  I, J: Integer;
  Done: Boolean;
begin
  for I:=I1 to I2 - 1 do
  begin
    Done := true;
    for J:=I2 downto I + 1 do
      if CompareItems(L[J], L[J-1]) < 0 then
      begin
        P := L[J];
        L[J] := L[J-1];
        L[J-1] := P;
        Done := false;
      end;
    if Done then
      Exit;
  end;
end;

procedure SaveVariant(const Value: Variant; S: TStream);
var
  VType: Integer;
begin
  VType := VarType(Value);
  SaveInteger(VType, S);
  case VType of
    varString:
      SaveString(Value, S);
    else
      S.WriteBuffer(Value, SizeOf(Variant));
  end;
end;

function LoadVariant(S: TStream): Variant;
var
  VType: Integer;
begin
  VType := LoadInteger(S);
  case VType of
    varString:
      result := LoadString(S);
    else
      S.ReadBuffer(result, SizeOf(Variant));
  end;
end;

procedure SaveInteger(Value: Integer; S: TStream);
begin
  S.WriteBuffer(Value, SizeOf(Integer));
end;

function LoadInteger(S: TStream): Integer;
begin
  S.ReadBuffer(result, SizeOf(Integer));
end;

procedure SaveString(const Value: String; S: TStream);
var
  W: TWriter;
begin
  W := TWriter.Create(S, 1024);
  W.WriteString(Value);
  W.Free;
end;

function LoadString(S: TStream): String;
var
  R: TReader;
begin
  R := TReader.Create(S, 1024);
  result := R.ReadString;
  R.Free;
end;

constructor TPAXVarList.Create;
begin
  fItems := TList.Create;
end;

destructor TPAXVarList.Destroy;
var
  I: Integer;
begin
  for I:=0 to fItems.Count - 1 do
    FreeMem(fItems[I], _SizeVariant);
  fItems.Free;

  inherited;
end;

procedure TPAXVarList.Delete(Index: Integer);
var
  P: PVariant;
begin
  P := GetAddress(Index);
  FreeMem(P, _SizeVariant);
  fItems.Delete(Index - 1);
end;

function TPAXVarList.Add(const Value: Variant): Integer;
var
  P: Pointer;
begin
  P := AllocMem(_SizeVariant);
  result := fItems.Add(P);
  Variant(P^) := Value;
end;

function TPAXVarList.Get(Index: Integer): Variant;
begin
  result := GetAddress(Index)^;
end;

function TPAXVarList.IndexOf(const Value: Variant): Integer;
var
  I: Integer;
  P: PVariant;
begin
  for I:=1 to fItems.Count do
  begin
    P := GetAddress(I);
    if P^ = Value then
    begin
      result := I;
      Exit;
    end;
  end;
  result := -1;
end;

function TPAXVarList.GetAddress(Index: Integer): PVariant;
var
  P: Pointer;
begin
  while fItems.Count < Index do
  begin
    P := AllocMem(_SizeVariant);
    fItems.Add(P);
  end;
  result := fItems[Index - 1];
end;

function TPAXVarList.GetCount: Integer;
begin
  result := fItems.Count;
end;

function TPAXParamList.HasAddress(P: Pointer): Boolean;
var
  I: Integer;
begin
  for I:=0 to L.Count - 1 do
    if L.Objects[I] = P then
    begin
      result := true;
      Exit;
    end;
  result := false;
end;

constructor TPAXParamList.Create;
begin
  inherited;
  L := TStringList.Create;
end;

destructor TPAXParamList.Destroy;
var
  I: Integer;
  P: Pointer;
begin
  for I:=0 to L.Count - 1 do
  begin
    P := L.Objects[I];
    FreeMem(P, SizeOf(Variant));
  end;
  L.Free;
  inherited;
end;

function TPAXParamList.GetAddress(const ParamName: String): Pointer;
var
  I: Integer;
begin
  I := L.IndexOf(ParamName);
  if I = -1 then
    result := nil
  else
    result := L.Objects[I];
end;

function TPAXParamList.GetParam(const ParamName: String): Variant;
var
  P: Pointer;
begin
  P := GetAddress(ParamName);
  if P = nil then
    result := Undefined
  else
    result := Variant(P^);
end;

procedure TPAXParamList.SetParam(const ParamName: String; const Value: Variant);
var
  P: Pointer;
begin
  P := GetAddress(ParamName);
  if P = nil then
  begin
    P := AllocMem(SizeOf(Variant));
    L.AddObject(ParamName, P);
  end;
  Variant(P^) := Value;
end;

function HashNumber(const S: String): Integer;
var
  I, J: Integer;
  UpS: String;
begin
  if Length(S) = 0 then
  begin
    result := -1;
    Exit;
  end;

  UpS := UpperCase(S);

  I := 0;
  for J:=1 to Length(UpS) do
  begin
    I := I shl 1;
    I := I xor ord(UpS[J]);
  end;
  if I < 0 then I := - I;
  result := I mod MaxHash;
end;

constructor TPAXHashArray.Create;
var
  I: Integer;
begin
  for I:=0 to MaxHash do
    A[I] := TList.Create;
end;

procedure TPAXHashArray.Clear;
var
  I: Integer;
begin
  for I:=0 to MaxHash do
    A[I].Clear;
end;

destructor TPAXHashArray.Destroy;
var
  I: Integer;
begin
  for I:=0 to MaxHash do
    A[I].Free;
end;

procedure TPAXHashArray.AddName(const Name: String; NameIndex, _HashNumber: Integer);
begin
  with A[_HashNumber] do
    if IndexOf(Pointer(NameIndex)) = -1 then
       Add(Pointer(NameIndex));
end;

constructor TPAXHashTable.Create;
var
  I: Integer;
begin
  for I:=0 to MaxHash do
  begin
    Keys[I] := TList.Create;
    Values[I] := TList.Create;
  end;
end;

procedure TPAXHashTable.Clear;
var
  I: Integer;
begin
  for I:=0 to MaxHash do
  begin
    Keys[I].Clear;
    Values[I].Clear;
  end;
end;

destructor TPAXHashTable.Destroy;
var
  I: Integer;
begin
  for I:=0 to MaxHash do
  begin
    Keys[I].Free;
    Values[I].Free;
  end;
end;

procedure TPAXHashTable.Add(Key: Integer; Value: Integer);
var
  H: Integer;
begin
  H := Abs(Key) mod MaxHash;
  Keys[H].Add(Pointer(Key));
  Values[H].Add(Pointer(Value));
end;

function TPAXHashTable.FindValue(Key: Integer; var found: Boolean): Integer;
var
  H: Integer;
begin
  H := Abs(Key) mod MaxHash;
  result := Keys[H].IndexOf(Pointer(Key));
  if result >= 0 then
  begin
    found := true;
    result := Integer(Values[H][result]);
  end
  else
    found := false;
end;

procedure TPAXHashTable.DeleteValue(Value: Integer);
var
  I, Idx: Integer;
begin
  for I:=0 to MaxHash do
  begin
    Idx := Values[I].IndexOf(Pointer(Value));
    if Idx >= 0 then
    begin
      Keys[I].Delete(Idx);
      Values[I].Delete(Idx);
    end;
  end;
end;


function SetToVariantArray(Val: Integer; pti: PTypeInfo): Variant;
var
  S: TIntegerSet;
  TypeInfo: PTypeInfo;
  I: Integer;
  L: TStringList;
begin
  L := TStringList.Create;
  try
    Integer(S) := Val;
{$ifdef fp}
    TypeInfo := GetTypeData(pti)^.CompType;
{$else}
    TypeInfo := GetTypeData(pti)^.CompType^;
{$endif}
    for I := 0 to SizeOf(Integer) * 8 - 1 do
      if I in S then
        L.Add(GetEnumName(TypeInfo, I));
    result := VarArrayCreate([0, L.Count - 1], varVariant);
    for I:=0 to L.Count - 1 do
      result[I] := L[I];
  finally
    L.Free;
  end;
end;

constructor TPAXIniFile.Create(const FileName: String);
begin
  Self.FileName := FileName;
  L := TStringList.Create;
  if FileExists(FileName) then
    L.LoadFromFile(FileName)
  else
    L.SaveToFile(FileName);
end;

destructor TPAXIniFile.Destroy;
var
  A: Integer;
begin
{$IFDEF LINUX}
  L.SaveToFile(FileName);
{$ELSE}
  A := FileGetAttr(FileName);
  if A and faReadOnly = 0 then
    L.SaveToFile(FileName);
{$ENDIF}
  L.Free;
end;

function TPAXIniFile.IndexOf(const Key: String): Integer;
var
  I, P: Integer;
  S: String;
begin
  result := -1;
  for I:=0 to L.Count - 1 do
  begin
    P := Pos('=', L[I]);
    if P >= 0 then
    begin
      S := Copy(L[I], 1, P - 1);
      if S = Key then
      begin
        result := I;
        Exit;
      end;
    end;
  end;