base_sys.pas

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

end;

function TPAXIniFile.GetValue(const Key: String): String;
var
  I: Integer;
begin
  result := '';
  I := IndexOf(Key);
  if I >= 0 then
    result := Trim(Copy(L[I], Pos('=', L[I]) + 1, Length(L[I])));
end;

procedure TPAXIniFile.SetValue(const Key, Value: String);
var
  I: Integer;
begin
  I := IndexOf(Key);
  if I >= 0 then
    L[I] := Key + '=' + Value
  else
    L.Add(Key + '=' + Value);
end;

procedure SetBit(var Value: Integer; const Bit: Integer);
begin
  Value := Value or (1 shl Bit);
end;

function TestBit(const Value: Integer; const Bit: Integer): Boolean;
begin
  Result := (Value and (1 shl Bit)) <> 0;
end;

procedure ClearBit(var Value: Integer; const Bit: Integer);
begin
  Value := Value and not (1 shl Bit);
end;

const
  BitsPerInteger  = SizeOf(Integer) * 8;

function BinaryToString(const Value: Integer): string;
var
  I, J: Integer;
  P: PChar;
begin
  SetLength(Result, BitsPerInteger);
  P := PChar(Result) + ((BitsPerInteger - 1) * SizeOf(Char));
  J := Value;
  for I := 0 to BitsPerInteger - 1 do
  begin
    P^ := Chr(48 + (J and $00000001));
    Dec(P);
    J := J shr 1;
  end;
end;

function StringToBinary(const S: String): Integer;
var
  K, I, P: Integer;
  c: Char;
begin
  K := Length(S);
  if K > BitsPerInteger then
    raise Exception.Create(err_Incorrect_string_in_StringToBinary);
  I := K;
  result := 0;
  P := 1;
  while I > 0 do
  begin
    c := S[I];
    case c of
      '1': result := result + P;
      '0': begin end;
     else
       raise Exception.Create(err_Incorrect_string_in_StringToBinary);
     end;
    Dec(I);
    P := P * 2;
  end;
end;

function StringToOctal(const S: String): Integer;
var
  K, I, P: Integer;
  c: Char;
begin
  K := Length(S);
  I := K;
  result := 0;
  P := 1;
  while I > 0 do
  begin
    c := S[I];
    case c of
      '0'..'7': result := result + (ord(S[I]) - ord('0')) * P;
     else
       raise Exception.Create(err_Incorrect_string_in_StringToOctal);
     end;
    Dec(I);
    P := P * 8;
  end;
end;

function ChPos(ch: Char; const S: String): Integer;
var
  I: Integer;
begin
  for I:=1 to Length(S) do
    if S[I] = ch then
    begin
      result := I;
      Exit;
    end;
  result := 0;
end;

function _Shr(X, Y: Integer): Variant;
var
  I, J: Integer;
begin
  J := X shr Y;
  if X >= 0 then
  begin
    result := J;
    Exit;
  end;

  if Y < 0 then
  begin
    result := NaN;
    Exit;
  end;

  for I:=31 downto 32 - Y do
    SetBit(J, I);

  result := J;
end;

procedure AdjustEnum(var Val: Integer);
type
  T = array[1..4] of Byte;
begin
  T(Val)[2] := 0;
  T(Val)[3] := 0;
  T(Val)[4] := 0;
end;

function IsCorrectAddress(Address: Pointer): Boolean;
var
  R: record
       W1, W2: Word;
     end;
begin
  Move(Address, R, SizeOf(Pointer));
  result := (R.W2 <> 0);
end;


{$ifdef fp}
function _IsDelphiClass(Address: Pointer): Boolean;
begin
  result := true;
end;
{$else}
function _IsDelphiClass(Address: Pointer): Boolean; assembler;
asm
        CMP     Address, Address.vmtSelfPtr
        JNZ     @False
        MOV     Result, True
        JMP     @Exit
@False:
        MOV     Result, False
@Exit:
end;
{$endif}

function IsDelphiClass(Address: Pointer): Boolean;
begin
  if IsCorrectAddress(Address) then
    result := _IsDelphiClass(Address)
  else
    result := false;
end;


{$ifdef fp}
function _IsDelphiObject(Address: Pointer): Boolean;
begin
  result := true;
end;
{$else}
function _IsDelphiObject(Address: Pointer): Boolean; assembler;
asm
// or IsDelphiClass(Pointer(Address^));
        MOV     EAX, [Address]
        CMP     EAX, EAX.vmtSelfPtr
        JNZ     @False
        MOV     Result, True
        JMP     @Exit
@False:
        MOV     Result, False
@Exit:
end;

{$endif}

function IsDelphiObject(Address: Pointer): Boolean;
var
  VMT, SelfP : pointer;
begin
  Result := FALSE;
  if IsCorrectAddress(Address) then
    try
      VMT := PPointer(Address)^;
      if IsCorrectAddress(VMT) then
      begin
        SelfP := Pointer(DWORD(VMT) + vmtSelfPtr);
        if IsCorrectAddress(SelfP) then
        begin
          SelfP := PPointer(SelfP)^;
          if IsCorrectAddress(SelfP) then
            Result := VMT = SelfP;
        end;
      end;
    except
    end;
end;

{
function IsDelphiObject(Address: Pointer): Boolean;
begin
  if IsCorrectAddress(Address) then
  begin
    try
      result := _IsDelphiObject(Address);
    except
      asm
        MOV     EAX, [Address]
      end;
      result := false;
    end;
  end
  else
    result := false;
end;
}

procedure ErrMessageBox(const S:  String);
begin
{$IFDEF CONSOLE}
  writeln(S);
  Exit;
{$ENDIF}

{$IFDEF WIN32}
  MessageBox(GetActiveWindow(), PChar(S), PChar('PAXScript'), MB_ICONEXCLAMATION or MB_OK);
{$ENDIF}

{$IFDEF LINUX}
{$IFDEF CONSOLE}
  writeln(S);
{$ELSE}
  Application.MessageBox(PChar(S), 'PAXScript', [smbOK]);
{$ENDIF}
{$ENDIF}
end;

function IsVBArray(const V: Variant): boolean;
begin
  result := VarType(V) > varArray;
end;

function IsUndefined(const V: Variant): boolean;
var
  VT: Integer;
begin
  VT := VarType(V);
  result := (VT = varUndefined) or (VT = varNull);
end;

function IsString(const V: Variant): boolean;
begin
  result := VarType(V) = varString;
end;

function IsNumber(const V: Variant): boolean;
var
  VT: Integer;
begin
  VT := VarType(V);
  result := (VT = varInteger) or (VT = varDouble);
end;

function IsBoolean(const V: Variant): boolean;
begin
  result := VarType(V) = varBoolean;
end;

function IsObject(const V: Variant): boolean;
begin
  result := VarType(V) = varScriptObject;
end;

function GetOperName(OP: Integer): String;
begin
  if OP = 0 then
    result := 'UNKNOWN'
  else
    result := PAXOperators[BOUND_OPER - OP];
end;

function ShiftPointer(P: Pointer; D: Integer): Pointer;
begin
  result := Pointer(Integer(P) + D);
end;

function StrEql(Const S1, S2: String): Boolean;
begin
  Result := CompareText(S1, S2) = 0;
end;

function Norm(const S: String; L: Integer): String;
begin
  result := Copy(S, 1, L);
  while Length(result) < L do
    result := ' ' + result;
end;

procedure TPAXEntryStack.Push(ABreakLabel, AContinueLabel: Integer;
                           var AStringLabel: String);
var
  EntryRec: TPAXEntryRec;
begin
  EntryRec := TPAXEntryRec.Create;
  with EntryRec do
  begin
    BreakLabel := ABreakLabel;
    ContinueLabel := AContinueLabel;
    StringLabel := AStringLabel;
  end;
  Add(EntryRec);

  AStringLabel := '';
end;

procedure TPAXEntryStack.Pop;
begin
  TPAXEntryRec(Items[Count - 1]).Free;
  Delete(Count - 1);
end;

function TPAXEntryStack.TopBreakLabel(const AStringLabel: String = ''): Integer;
var
  I: Integer;
  R: TPAXEntryRec;
begin
  if AStringLabel <> '' then
  begin
    for I:=Count - 1 downto 0 do
    begin
      R := TPAXEntryRec(Items[I]);
      with R do
        if StringLabel = AStringLabel then
        begin
          result := BreakLabel;
          Exit;
        end;
    end;
    raise TPAXScriptFailure.Create(errLabelIsNotFound);
  end
  else
    with TPAXEntryRec(Items[Count - 1]) do
      result := BreakLabel;
end;

function TPAXEntryStack.TopContinueLabel(const AStringLabel: String = ''): Integer;
var
  I: Integer;
begin
  if AStringLabel <> '' then
  begin
    for I:=Count - 1 downto 0 do
    with TPAXEntryRec(Items[I]) do
      if StringLabel = AStringLabel then
      begin
        result := ContinueLabel;
        Exit;
      end;
    raise TPAXScriptFailure.Create(errLabelIsNotFound);
  end
  else
    with TPAXEntryRec(Items[Count - 1]) do
      result := ContinueLabel;
end;

constructor TPAXIndexedList.Create;
begin
  inherited;
  fItems := TList.Create;
  Objects := TList.Create;
end;

function TPaxIndexedList.Count: Integer;
begin
  result := fItems.Count;
end;

procedure TPAXIndexedList.Clear;
var
  I: Integer;
begin
  for I:=0 to Count - 1 do
    if Objects[I] <> nil then
    begin
      TObject(Objects[I]).Free;
      Objects[I] := nil;
    end;

  fItems.Clear;
  Objects.Clear;
end;

procedure TPAXIndexedList.Delete(I: Integer);
begin
  if Objects[I] <> nil then
    TObject(Objects[I]).Free;
  fItems.Delete(I);
  Objects.Delete(I);
end;

destructor TPAXIndexedList.Destroy;
begin
  Clear;
  fItems.Free;
  Objects.Free;
  inherited;
end;

function TPAXIndexedList.IndexOf(I: Integer): Integer;
var
  J: Integer;
begin
  result := -1;
  for J:=Count - 1 downto 0 do
    if Integer(fItems[J]) = I then
    begin
      result := J;
      Exit;
    end;
end;

function TPAXIndexedList.GetNameID(I: Integer): Integer;
begin
  result := Integer(fItems[I]);
end;

procedure TPAXIndexedList.SetNameID(I: Integer; Value: Integer);
begin
  fItems[I] := Pointer(Value);
end;

function TPAXIndexedList.AddObject(ID: Integer; AnObject: TObject): Integer;
begin
  result := fItems.Add(Pointer(ID));
  Objects.Add(AnObject);
end;

procedure TPAXIndexedList.DeleteObject(Index: Integer);
begin
  TObject(Objects[Index]).Free;

  Objects.Delete(Index);
  fItems.Delete(Index);
end;

function TPAXIndexedList.GetObject(ID: Integer): TObject;
var
  I: Integer;
begin
  I := IndexOf(ID);
  if I = - 1 then
    result := nil
  else
    result := Objects[I];
end;

constructor TPAXHashedIndexedList.Create;
begin
  inherited;
  HashTable := TPaxHashTable.Create;
end;

destructor TPAXHashedIndexedList.Destroy;
begin
  HashTable.Free;
  inherited;
end;

function TPAXHashedIndexedList.IndexOf(ID: Integer): Integer;
var
  found: boolean;
begin
  result := HashTable.FindValue(ID, found);
end;

function TPAXHashedIndexedList.AddObject(ID: Integer; AnObject: TObject): Integer;
begin
  result := fItems.Add(Pointer(ID));
  Objects.Add(AnObject);

  HashTable.Add(ID, result);
end;

function TPAXHashedIndexedList.GetObject(ID: Integer): TObject;
var
  I: Integer;
begin
  I := IndexOf(ID);
  if I = - 1 then
    result := nil
  else
    result := Objects[I];
end;

procedure TPAXHashedIndexedList.DeleteObject(Index: Integer);
var
  I: Integer;
begin
  TObject(Objects[Index]).Free;
  Objects.Delete(Index);
  fItems.Delete(Index);

  HashTable.Clear;
  for I := 0 to Count - 1 do
    HashTable.Add(Integer(fItems[I]), I);
end;

procedure TPAXHashedIndexedList.Clear;
begin
  inherited;
  HashTable.Clear;
end;

function TPAXTypes.AddType(const TypeName: String; TypeSize: Integer): Integer;
begin
  result := AddObject(TypeName, TObject(TypeSize));
end;

function TPAXTypes.GetSize(TypeID: Integer): Integer;
begin
  result := Integer(Objects[TypeID]);
end;

function TPAXTypes.GetTypeID(const TypeName: String): Integer;
var
  I: Integer;
begin
  for I:=0 to Count - 1 do
    if StrEql(Strings[I], TypeName) then
    begin
      result := I;
      Exit;
    end;
  result := -1;


end;

constructor TPAXStack.Create;
begin
  SetLength(fItems, FirstStackSize);
  L := Length(fItems) - 1;
  Card := 0;
end;

procedure TPAXStack.Clear;
begin
  Card := 0;
end;

function TPAXStack.GetItem(I: Integer): Integer;
begin
  result := fItems[I];
end;

function TPAXStack.Push(I: Integer): Integer;
begin
  if Card = L then
  begin
    SetLength(fItems, Card + DeltaStackSize);
    L := Length(fItems) - 1;
  end;

  Inc(Card);
  fItems[Card] := I;
  result := I;
end;

function TPAXStack.IndexOf(I: Integer): Integer;
var
  J: Integer;
begin
  for J:=1 to Card do
    if fItems[J] = I then
    begin
      result := J;
      Exit;
    end;
  result := -1;
end;

function TPAXStack.PushUnique(I: Integer): Integer;
begin
  result := I;
  if IndexOf(I) = -1 then