base_class.pas

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

function DelphiInstanceToScriptObject(Instance: TObject; Scripter: Pointer;
                                      RaiseException: boolean = true): TPAXScriptObject;
var
  S: String;
  ClassRec: TPAXClassRec;
  W: TPAXScriptObjectList;
begin
  W := TPAXBaseScripter(Scripter).ScriptObjectList;
  result := W.FindScriptObject(Instance);
  if result <> nil then
    Exit;

  ClassRec := TPAXBaseScripter(Scripter).ClassList.FindClassByInstance(Instance);

  if ClassRec = nil then
  if not RaiseException then
    Exit;

  if ClassRec = nil then
  begin
    S := Instance.ClassName;
    raise TPAXScriptFailure.Create(Format(errClassIsNotImported, [S]));
  end;
  result := ClassRec.CreateScriptObject;
  result.Instance := Instance;

//  if Instance.ClassType = TPAXArray then
    result.RefCount := 1;
end;

function DelphiClassToScriptObject(AClass: TClass; Scripter: Pointer): TPAXScriptObject;
var
  S: String;
  ClassRec: TPAXClassRec;
begin
  S := AClass.ClassName;
  ClassRec := TPAXBaseScripter(Scripter).ClassList.FindClassByName(S);
  if ClassRec = nil then
    raise TPAXScriptFailure.Create(Format(errClassIsNotImported, [S]));
  result := ClassRec.CreateScriptObject;
  result.PClass := AClass;
end;

function InterfaceToScriptObject(const I: IUnknown; Scripter: Pointer;
                                 const InterfaceClassName: String = ''): TPaxScriptObject;
var
  Instance: TObject;
  S: String;
  ClassRec: TPaxClassRec;
begin
  result := nil;
  Instance := GetImplementorOfInterface(I);
  if Instance = nil then
    Exit
  else
  begin
    if InterfaceClassName <> '' then
      S := InterfaceClassName
    else
    begin
      S := Instance.ClassName;
      S[1] := 'I';
    end;

    ClassRec := TPaxBaseScripter(Scripter).ClassList.FindClassByName(S);
    if ClassRec <> nil then
    begin
      result := ClassRec.CreateScriptObject;
      Move(I, result.Intf, 4);
      result.RefCount := 1;
    end
    else
    begin
      ClassRec := TPaxBaseScripter(Scripter).ClassList.FindClassByName('IUnknown');
      if ClassRec <> nil then
      begin
        result := ClassRec.CreateScriptObject;
        Move(I, result.Intf, 4);
        result.RefCount := 1;
      end;
    end;
  end;
end;

function IsHostObject(const V: Variant): Boolean;
var
  SO: TPAXScriptObject;
begin
  if IsObject(V) then
  begin
    SO := VariantToScriptObject(V);
    result := SO.Instance <> nil;
  end
  else
    result := false;
end;

function IsPaxArray(const V: Variant): Boolean;
var
  SO: TPAXScriptObject;
begin
  if IsObject(V) then
  begin
    SO := VariantToScriptObject(V);
    result := SO.ClassRec.ck = ckArray;
  end
  else
    result := false;
end;

function IsDynamicArray(const V: Variant): Boolean;
var
  SO: TPAXScriptObject;
begin
  if IsObject(V) then
  begin
    SO := VariantToScriptObject(V);
    result := SO.ClassRec.ck = ckDynamicArray;
  end
  else
    result := false;
end;

function IsDateObject(const V: Variant): Boolean;
var
  SO: TPAXScriptObject;
  ClassList: TPAXClassList;
begin
  if IsObject(V) then
  begin
    SO := VariantToScriptObject(V);
    ClassList := TPAXBaseScripter(SO.Scripter).ClassList;
    result := SO.ClassRec = ClassList.DateClassRec;
  end
  else
    result := false;
end;

function IsFunctionObject(const V: Variant): Boolean;
var
  SO: TPAXScriptObject;
  ClassList: TPAXClassList;
begin
  if IsObject(V) then
  begin
    SO := VariantToScriptObject(V);
    ClassList := TPAXBaseScripter(SO.Scripter).ClassList;
    result := SO.ClassRec = ClassList.FunctionClassRec;
  end
  else
    result := false;
end;

function IsStringObject(const V: Variant): Boolean;
var
  SO: TPAXScriptObject;
  ClassList: TPAXClassList;
begin
  if IsObject(V) then
  begin
    SO := VariantToScriptObject(V);
    ClassList := TPAXBaseScripter(SO.Scripter).ClassList;
    result := SO.ClassRec = ClassList.StringClassRec;
  end
  else
    result := false;
end;

function IsBooleanObject(const V: Variant): Boolean;
var
  SO: TPAXScriptObject;
  ClassList: TPAXClassList;
begin
  if IsObject(V) then
  begin
    SO := VariantToScriptObject(V);
    ClassList := TPAXBaseScripter(SO.Scripter).ClassList;
    result := SO.ClassRec = ClassList.BooleanClassRec;
  end
  else
    result := false;
end;

function IsNumberObject(const V: Variant): Boolean;
var
  SO: TPAXScriptObject;
  ClassList: TPAXClassList;
begin
  if IsObject(V) then
  begin
    SO := VariantToScriptObject(V);
    ClassList := TPAXBaseScripter(SO.Scripter).ClassList;
    result := SO.ClassRec = ClassList.NumberClassRec;
  end
  else
    result := false;
end;

constructor TPAXError.Create;
begin
  inherited;

  fScriptTime := '';
  fDescription := '';
  fModuleName := '';
  fFileName := '';
  fLine := '';
  fLineNumber := 0;
  fPosition := 0;
  fTextPosition := 0;
  fErrClassType := nil;
end;

function CreateNameIndex(const Name: String; Scripter: Pointer): Integer;
begin
  result := TPaxBaseScripter(Scripter).NameList.Add(Name);
end;

function NameIndexToUpperCaseIndex(NameIndex: Integer; Scripter: Pointer): Integer;
var
  S: String;
  I: Integer;
begin
  I := Integer(TPaxBaseScripter(Scripter).NameList.Objects[NameIndex]);
  if I = 0 then
  begin
    S := UpperCase(TPaxBaseScripter(Scripter).NameList[NameIndex]);
    result := TPaxBaseScripter(Scripter).NameList.Add(S);
    TPaxBaseScripter(Scripter).NameList.Objects[NameIndex] := TObject(result);
  end
  else
    result := I;
end;

constructor TPAXMemberList.Create(Owner: TPAXClassRec);
begin
  Self.Owner := Owner;
  inherited Create;
end;

function TPAXMemberList.Scripter: Pointer;
begin
  result :=Owner.Scripter;
end;

procedure TPAXMemberList.SaveToStream(S: TStream);
var
  I: Integer;
begin
  SaveInteger(Count, S);
  for I:=0 to Count - 1 do
    Records[I].SaveToStream(S);
end;

procedure TPAXMemberList.LoadFromStream(S: TStream;
                                        DS: Integer = 0; DP: Integer = 0);
var
  I, Index, K: Integer;
  MemberRec: TPAXMemberRec;
begin
  K := LoadInteger(S);
  for I:=0 to K - 1 do
  begin
    MemberRec := TPAXMemberRec.Create(0, Owner);
    MemberRec.LoadFromStream(S, DS, DP);

    Index := CreateNameIndex(MemberRec.GetName, Scripter);
    AddObject(Index, MemberRec);
  end;
end;

function TPAXMemberList.GetRecord(Index: Integer): TPAXMemberRec;
begin
  result := TPAXMemberRec(Objects[Index]);
end;

function TPAXMemberList.UpperCaseIndexOf(UpCaseIndex: Integer): Integer;
var
  I: Integer;
  R: TPAXMemberRec;
begin
  result := -1;
  if UpCaseIndex <= 0 then
    Exit;
  for I:=0 to Count - 1 do
  begin
    R := GetRecord(I);
    if R.UpCaseIndex = UpCaseIndex then
    begin
      result := I;
      Exit;
    end;
  end;
end;

function TPAXMemberList.GetMemberID(const Name: String; UpCase: Boolean = true): Integer;
var
  NameIndex, UpCaseIndex, Index: Integer;
  P: TPAXClassRec;
begin
  result := 0;
  NameIndex := CreateNameIndex(Name, Scripter);

  if UpCase then
     UpCaseIndex := NameIndexToUpperCaseIndex(NameIndex, Scripter)
  else
     UpCaseIndex := -1;

  P := Owner;

  while P <> nil do
  begin
    Index := P.MemberList.IndexOf(NameIndex);
    if Index >= 0 then
    begin
      result := P.MemberList[Index].ID;
      Exit;
    end
    else
    begin
      Index := P.MemberList.UpperCaseIndexOf(UpCaseIndex);
      if Index >= 0 then
      begin
        result := P.MemberList[Index].ID;
        Exit;
      end;
    end;
    P := P.AncestorClassRec;
  end;
end;

function TPAXMemberList.IndexOfMember(const Name: String; UpCase: Boolean = true): Integer;
var
  NameIndex, UpCaseIndex, Index: Integer;
  P: TPAXClassRec;
begin
  result := -1;
  NameIndex := CreateNameIndex(Name, Scripter);

  if UpCase then
     UpCaseIndex := NameIndexToUpperCaseIndex(NameIndex, Scripter)
  else
     UpCaseIndex := -1;

  P := Owner;

  while P <> nil do
  begin
    Index := P.MemberList.IndexOf(NameIndex);
    if Index >= 0 then
    begin
      result := Index;
      Exit;
    end
    else
    begin
      Index := P.MemberList.UpperCaseIndexOf(UpCaseIndex);
      if Index >= 0 then
      begin
        result := Index;
        Exit;
      end;
    end;
    P := P.AncestorClassRec;
  end;
end;

function TPAXMemberList.GetMemberRec(const Name: String; UpCase: Boolean = true): TPAXMemberRec;
var
  NameIndex, UpCaseIndex, Index: Integer;
  P: TPAXClassRec;
begin
  result := nil;
  NameIndex := CreateNameIndex(Name, Scripter);

  if UpCase then
     UpCaseIndex := NameIndexToUpperCaseIndex(NameIndex, Scripter)
  else
     UpCaseIndex := -1;

  P := Owner;

  while P <> nil do
  begin
    Index := P.MemberList.IndexOf(NameIndex);
    if Index >= 0 then
    begin
      result := P.MemberList[Index];
      Exit;
    end
    else
    begin
      Index := P.MemberList.UpperCaseIndexOf(UpCaseIndex);
      if Index >= 0 then
      begin
        result := P.MemberList[Index];
        Exit;
      end;
    end;
    P := TPaxBaseScripter(P.Scripter).ClassList.FindClassByName(P.AncestorName);
  end;
end;

procedure TPAXMemberList.DeleteMember(const Name: String; UpCase: Boolean = true);
var
  NameIndex, UpCaseIndex, Index: Integer;
  P: TPAXClassRec;
begin
  NameIndex := CreateNameIndex(Name, Scripter);

  if UpCase then
     UpCaseIndex := NameIndexToUpperCaseIndex(NameIndex, Scripter)
  else
     UpCaseIndex := -1;

  P := Owner;

  while P <> nil do
  begin
    Index := P.MemberList.IndexOf(NameIndex);
    if Index >= 0 then
    begin
      P.MemberList.DeleteObject(Index);
      Exit;
    end
    else
    begin
      Index := P.MemberList.UpperCaseIndexOf(UpCaseIndex);
      if Index >= 0 then
      begin
        P.MemberList.Delete(Index);
        Exit;
      end;
    end;
    P := TPaxBaseScripter(P.Scripter).ClassList.FindClassByName(P.AncestorName);
  end;
end;

function TPAXMemberList.GetMemberRecByID(MemberID: Integer): TPAXMemberRec;
var
  I: Integer;
  P: TPAXClassRec;
begin
  P := Owner;
  while P <> nil do
  begin
    for I:=0 to P.MemberList.Count - 1 do
    begin
      result := P.MemberList[I];
      if result.ID = MemberID then