base_extern.pas

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

function TPAXMethodBody.GetField(I: Integer): TPAXParameter;
begin
  if I >= fParameterList.Count then
    AddParameters(I + 10);

  result := fParameterList[I];
end;

procedure TPAXMethodBody.SetField(I: Integer; Value: TPAXParameter);
begin
  if I >= fParameterList.Count then
    AddParameters(I + 10);

  fParameterList[I] := Value;
end;

constructor TPAXDefinition.Create(DefList: TPAXDefinitionList;
                               const Name: String; Owner: TPAXDefinition;
                               DefKind: TPAXDefKind);
begin
  Self.DefList := DefList;
  Self.Name := Name;
  Self.Owner := Owner;
  Self.DefKind := DefKind;
  UserData := 0;
  Module := -1;
  ResultType := '';
end;

function TPAXDefinition.FullName: String;
begin
  if Owner <> nil then
    result := Owner.FullName + '.' + Name
  else
    result := Name;
end;

function TPAXDefinition.GetValue: Variant;
begin
  result := DefValue;
end;

function TPAXDefinition.PValue: PVariant;
begin
  result := @ DefValue;
end;

procedure TPAXDefinition.SetValue(const AValue: Variant);
begin
  DefValue := AValue;
end;

procedure TPAXDefinition.AddToScripter(Scripter: Pointer);
begin
end;

procedure TPAXDefinition.AddToScripterList;
var
  I: Integer;
begin
  if Assigned(ScripterList) then
  begin
    for I:=0 to ScripterList.Count - 1 do
      AddToScripter(ScripterList[I]);
  end;
end;

constructor TPaxFieldDefinition.Create(DefList: TPAXDefinitionList; PClass: TClass; const FieldName,
                                       FieldType: String; Offset: Integer);
var
  Owner: TPaxDefinition;
  S: String;
begin
  Owner := DefList.FindClassDef(PClass);
  inherited Create(DefList, FieldName, Owner, dkField);
  Self.PClass := PClass;
  Self.FieldType := FieldType;
  Self.Offset := Offset;
  Self.TypeID := PAXTypes.IndexOf(UpperCase(FieldType));
  if Self.TypeID = -1 then
  begin
    S := FindTypeAlias(FieldType, true);
    Self.TypeID := PAXTypes.IndexOf(UpperCase(S));
  end;
end;

function TPAXFieldDefinition.GetFieldAddress(SO: pointer): Pointer;
var
  Address: Pointer;
begin
  Address := ShiftPointer(TPaxScriptObject(SO).Instance, Offset);
  DefValue := GetVariantValue(TPaxScriptObject(SO).Scripter, Address, TypeID);
  result := @DefValue;
end;

function TPaxFieldDefinition.GetFieldValue(SO: pointer): Variant;
begin
  GetFieldAddress(SO);
  result := DefValue;
end;

procedure TPaxFieldDefinition.SetFieldValue(SO: pointer; const Value: Variant);
var
  Address: Pointer;
begin
  Address := ShiftPointer(TPaxScriptObject(SO).Instance, Offset);
  PutVariantValue(TPaxScriptObject(SO).Scripter, Address, Value, TypeID);
end;

procedure TPaxFieldDefinition.Dump(var T: TextFile);
begin
  writeln(T, 'Field =', Name,  ' Type =', FieldType, ' Class =', PClass.ClassName,
             ' Offset =', Offset,
             ' Index =', Index);
end;

procedure TPaxFieldDefinition.AddToScripter(Scripter: Pointer);
var
  ClassRec: TPAXClassRec;
  ClassList: TPAXClassList;
begin
  ClassList := TPAXBaseScripter(Scripter).ClassList;
  ClassRec := ClassList.FindImportedClass(PClass);

  if (SignLoadOnDemand and (ClassRec = nil)) then
    ClassRec := TPAXBaseScripter(Scripter).ClassList.FindClassByName(Owner.Name);
  
  if ClassRec <> nil then
    ClassRec.AddHostField(Self)
  else
    raise TPAXScriptFailure.Create(Format(errClassIsNotImported, [PClass.ClassName]));
end;

constructor TPAXRecordFieldDefinition.Create(DefList: TPAXDefinitionList;
                                             Owner: TPaxClassDefinition;
                                             const FieldName, FieldType: String;
                                             Offset: Integer);
var
  FieldTypeDef: TPaxClassDefinition;
begin
  FieldTypeDef := DefList.FindClassDefByName(FieldType);

  inherited Create(DefList, FieldName, Owner, dkRecordField);
  Self.FieldType := FieldType;
  Self.Offset := Offset;
  Self.TypeID := PAXTypes.IndexOf(UpperCase(FieldType));

  if FieldTypeDef <> nil then
  begin
    if FieldTypeDef.ClassKind = ckEnum then
      Self.TypeID := typeENUM
    else if FieldTypeDef.ClassKind = ckStructure then
      Self.TypeID := typeRECORD
    else if FieldTypeDef.ClassKind = ckDynamicArray then
      Self.TypeID := typeARRAY;
  end;
end;

function TPAXRecordFieldDefinition.GetFieldAddress(Scripter, Address: pointer): Pointer;
begin
  Address := ShiftPointer(Address, Offset);
  DefValue := GetVariantValue(Scripter, Address, TypeID, FieldType);
  result := @DefValue;
end;

function TPaxRecordFieldDefinition.GetFieldValue(Scripter, Address: pointer): Variant;
begin
  GetFieldAddress(Scripter, Address);
  result := DefValue;
end;

procedure TPaxRecordFieldDefinition.SetFieldValue(Scripter, Address: pointer; const Value: Variant);
begin
  Address := ShiftPointer(Address, Offset);
  PutVariantValue(Scripter, Address, Value, TypeID);
end;

procedure TPaxRecordFieldDefinition.Dump(var T: TextFile);
begin
  writeln(T, 'RecordField =', Name,  ' Type =', FieldType, ' Offset =', Offset,
             ' Index =', Index);
end;

procedure TPaxRecordFieldDefinition.AddToScripter(Scripter: Pointer);
var
  ClassRec: TPAXClassRec;
  ClassList: TPAXClassList;
begin
  ClassList := TPAXBaseScripter(Scripter).ClassList;
  ClassRec := ClassList.FindClassByName(Owner.Name);

  if (SignLoadOnDemand and (ClassRec = nil)) then
    ClassRec := TPAXBaseScripter(Scripter).ClassList.FindClassByName(Owner.Name);
  
  if ClassRec <> nil then
    ClassRec.AddHostRecordField(Self)
  else
    raise TPAXScriptFailure.Create(Format(errClassIsNotImported, [Owner.Name]));
end;

constructor TPAXClassDefinition.Create(DefList: TPAXDefinitionList;
                                       const Name: String; Owner, Ancestor: TPAXDefinition);
begin
  inherited Create(DefList, Name, Owner, dkClass);
  Self.Ancestor := Ancestor;
  Self.GetPropDef := nil;
  Self.PutPropDef := nil;
  Self.ClassKind := ckClass;
  RecordSize := -1;
  Self.pti := nil;
  FillChar(guid, SizeOf(guid), 0);
  IsSet := false;
  PtiSet:= nil;
  IsStaticArray := false;

  OwnerList := nil;
end;

destructor TPAXClassDefinition.Destroy;
begin
  if OwnerList <> nil then
    OwnerList.Free;
end;

procedure TPAXClassDefinition.Dump(var T: TextFile);
var
  StrAncestor: String;
begin
  if Ancestor = nil then
    StrAncestor := 'nil'
  else
    StrAncestor := Ancestor.FullName;
  writeln(T, 'Class =', FullName,  ' Ancestor =', StrAncestor,
          ' Index =', Index);
end;

procedure TPAXClassDefinition.CreateOwnerList;
var
  P: TPAXDefinition;
begin
  OwnerList := TStringList.Create;

  P := Owner;
  while P <> nil do
  begin
    OwnerList.Insert(0, P.Name);
    P := P.Owner;
  end;
end;

function TPAXClassDefinition.FindClassRec(Scripter: Pointer): Pointer;
begin
  if OwnerList = nil then
     CreateOwnerList;

  result := TPAXBaseScripter(Scripter).ClassList.FindNestedClass(OwnerList, Name);
end;

procedure TPAXClassDefinition.AddToScripter(Scripter: Pointer);
var
  ClassRec, OwnerRec: TPAXClassRec;
  ClassList: TPAXClassList;
  ClassID: Integer;
  OwnerName, AncestorName: String;
begin
  ClassList := TPAXBaseScripter(Scripter).ClassList;
  ClassRec := FindClassRec(Scripter);

  if ClassRec <> nil then
    Exit;

  ClassID := - Index;

  if Ancestor <> nil then
    AncestorName := Ancestor.Name
  else
    AncestorName := '';

  if Owner <> nil then
  begin
    OwnerName := Owner.Name;
    OwnerRec := TPAXClassDefinition(Owner).FindClassRec(Scripter);
  end
  else
  begin
    OwnerName := RootNamespaceName;
    OwnerRec := ClassList.Records[0];
  end;

  ClassRec := ClassList.AddClass(ClassID, Name, OwnerName, AncestorName, ml, ClassKind, true);
  ClassRec.fClassDef := Self;
  ClassRec.ck := ClassKind;
  ClassRec.IsStaticArray := IsStaticArray;

  if (GetPropDef <> nil) or (PutPropDef <> nil) then
    ClassRec.fHasRunTimeProperties := true;

  ClassRec.isSet := IsSet;
  ClassRec.PtiSet := PtiSet;

  if OwnerRec <> nil then
    OwnerRec.AddNestedClass(ClassID, ml);

  if StrEql('TPaxArray', Name) then
    TPAXBaseScripter(Scripter).ArrayClassRec := ClassRec;
end;

constructor TPAXRTTITypeDefinition.Create(DefList: TPAXDefinitionList; pti: PTypeInfo);
begin
  inherited Create(DefList, pti^.Name, nil, dkRTTIType);
  Self.pti := pti;
  Self.FinalType := GetFinalType;
end;

procedure TPAXRTTITypeDefinition.Dump(var T: TextFile);
begin
  writeln(T, 'RTTIType =', pti^.Name, ' Index =', Index);
end;

function TPAXRTTITypeDefinition.GetFinalType: Integer;
begin
  result := 0;
  case pti^.Kind of
    tkInteger: result := typeINTEGER;
    tkChar: result := typeCHAR;
    tkEnumeration: result := typeENUM;
    tkFloat: result := typeDOUBLE;
    tkString: result := typeSHORTSTRING;
    tkLString: result := typeSTRING;
    tkWString: result := typeWIDESTRING;
    tkClass: result := typeCLASS;
    tkWChar: result := typeWIDECHAR;
    tkMethod: result := typeMETHOD;
    tkVariant: result := typeVARIANT;
    tkSet: result := typeSET;
    tkInt64: result := typeINT64;
    tkInterface: result := typeINTERFACE;
  end;
  if StrEql(pti^.Name, 'TDateTime') then
    result := typeDOUBLE;
end;

constructor TPAXMethodDefinition.Create(DefList: TPAXDefinitionList;
                                     const Name: String; Proc: TPAXMethodImpl;
                                     NP: Integer; Owner: TPAXDefinition;
                                     IsStatic: Boolean);
begin
  inherited Create(DefList, Name, Owner, dkMethod);
  Self.Proc := Proc;
  Self.NP := NP;
  Self.PClass := nil;
  Self.DirectProc := nil;
  Self.CallConv := _ccRegister;
  Self.Fake := false;
  Self.NewFake := false;
  Self.IsStatic := IsStatic;
  DefParamList := TPaxVarList.Create;
  ReturnsDynamicArray := false;
  Self.IsIntf := false;
  MethodIndex := 0;
  intf_pti := nil;
  FillChar(guid, SizeOf(guid), 0);
end;

destructor TPAXMethodDefinition.Destroy;
begin
  DefParamList.Free;
  inherited;
end;

function TPAXMethodDefinition.Duplicate: TPAXMethodDefinition;
var
  I: Integer;
begin
  result := TPAXMethodDefinition.Create(DefList, Name, Proc, NP, Owner, true);

  result.PClass := PClass;
  result.DirectProc := DirectProc;
  result.CallConv := CallConv;
  result.Header := Header;
  SetLength(result.Types, Length(Types));
  SetLength(result.ExtraTypes, Length(Types));
  SetLength(result.StrTypes, Length(Types));
  SetLength(result.ParamNames, Length(Types));
  SetLength(result.Sizes, Length(Types));
  SetLength(result.ByRefs, Length(Types));
  SetLength(result.Consts, Length(Types));
  result.TypeSub := TypeSub;
  result.Fake := Fake;
  result.NewFake := NewFake;
  result.IsStatic := IsStatic;

  for I:=0 to Length(Types) - 1 do
    result.Types[I] := Types[I];
  for I:=0 to Length(Types) - 1 do
    result.ExtraTypes[I] := ExtraTypes[I];
  for I:=0 to Length(Types) - 1 do
    result.StrTypes[I] := StrTypes[I];
  for I:=0 to Length(Types) - 1 do
    result.ParamNames[I] := ParamNames[I];
  for I:=0 to Length(Types) - 1 do
    result.Sizes[I] := Sizes[I];
  for I:=0 to Length(ByRefs) - 1 do
    result.ByRefs[I] := ByRefs[I];
  for I:=0 to Length(Consts) - 1 do
    result.Consts[I] := Consts[I];
end;


procedure TPAXMethodDefinition.AddToScripter(Scripter: Pointer);
var
  ClassRec: TPAXClassRec;
  ClassList: TPAXClassList;
begin
  ClassList := TPAXBaseScripter(Scripter).ClassList;

  if Owner = nil then
    ClassRec := ClassList[0]
  else
  begin
//    ClassRec := ClassList.FindClassByName(Owner.Name);
    ClassRec := TPAXClassDefinition(Owner).FindClassRec(Scripter);
  end;

  if (SignLoadOnDemand and (ClassRec = nil)) then
    ClassRec := TPAXBaseScripter(Scripter).ClassList.FindClassByName(Owner.Name);

  if ClassRec <> nil then
    ClassRec.AddHostMethod(Self)
  else
    raise TPAXScriptFailure.Create(Format(errClassIsNotImported, [Owner.Name]));
end;

function TPAXMethodDefinition.LoadFromDll(Scripter: Pointer; SubID: Integer): Boolean;

var
  BaseScripter: TPaxBaseScripter;

function GetFinalType(ID: Integer): Integer;
var
  TypeIndex: Integer;
  RTTIDef: TPAXRTTITypeDefinition;
  S: String;
begin
  with BaseScripter do
  begin
    result := SymbolTable.PType[ID];
    TypeIndex := SymbolTable.TypeNameIndex[ID];
    if TypeIndex > 0 then
    begin
      result := typeCLASS;
      S := _GetName(TypeIndex, Scripter);
      RTTIDef := DefinitionList.FindRTTITypeDefByName(S);
      if RTTIDef <> nil then
        result := RTTIDef.FinalType;
    end;
  end;
end;

var
  DllName, DllProcName: String;
  DllID, DllProcID: Integer;
  DllRec: TPaxDllRec;
  I, ParamID, ResultID: Integer;
begin
  BaseScripter := TPaxBaseScripter(Scripter);
  with BaseScripter.SymbolTable do
  begin
    DllID := GetDllID(SubID);
    DllName := Name[DllID];
    DllProcID := GetDllProcID(SubID);
    DllProcName := Name[DllProcID];

    DirectProc := nil;
    if Assigned(TPaxBaseScripter(Scripter).OnLoadDll) then
        TPaxBaseScripter(Scripter).OnLoadDll(TPaxBaseScripter(Scripter).Owner, DllName,
                                             DllProcName, DirectProc);
    if DirectProc = nil then
    begin
      DllRec := DllList.LoadDll(DllName, scripter);
      if DllRec = nil then
        raise TPaxScriptFailure.Create(Format(errCannotLoadDll, [DllName]));

{$IFDEF FP}
     DirectProc := dynlibs.GetProcedureAddress(DllRec.Handle, PChar(DllProcName));