base_extern.pas

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

procedure TPAXArray.InsertIndex(I: Integer);
begin
  fIndexes.Insert(0, Pointer(I));
end;

function TPAXArray.Get(const Indexes: array of Integer): Variant;
var
  I: Integer;
begin
  fIndexes.Clear;
  for I:=0 to System.Length(Indexes) - 1 do
    fIndexes.Add(Indexes[I]);
  result := _Get;
end;

function TPAXArray.GetPtr(const Indexes: array of Integer): PVariant;
var
  I: Integer;
begin
  fIndexes.Clear;
  for I:=0 to System.Length(Indexes) - 1 do
    fIndexes.Add(Indexes[I]);
  result := AddressOfElement;
end;

procedure TPAXArray.Put(const Indexes: array of Integer; const Value: Variant);
var
  I: Integer;
begin
  fIndexes.Clear;
  for I:=0 to System.Length(Indexes) - 1 do
    fIndexes.Add(Indexes[I]);
  _Put(Value);
end;

function TPAXArray._CheckIndexes: Boolean;
var
  I, Idx: Integer;
begin
  for I:=0 to fIndexes.Count - 1 do
  begin
    Idx := fIndexes[I] + 1;
    if Idx > fBounds[I] then
    begin
      result := False;
      Exit;
    end;
  end;
  result := true;
end;

function TPAXArray.CheckIndexes(const Indexes: array of Integer): Boolean;
var
  I, Idx: Integer;
begin
  result := true;
  for I:=0 to L - 1 do
  begin
    Idx := Indexes[I] + 1;
    if Idx > fBounds[I] then
    begin
      result := False;
      Exit;
    end;
  end;
end;

procedure TPAXArray.PutEx(const Indexes: array of Integer; const Value: Variant);
begin
  if not CheckIndexes(Indexes) then
    ReDim(Indexes);
  Put(Indexes, Value);
end;

function TPAXArray.GetEx(const Indexes: array of Integer): Variant;
begin
  if not CheckIndexes(Indexes) then
    ReDim(Indexes);
  result := Get(Indexes);
end;

function IsScripters: Boolean;
begin
  if Assigned(ScripterList) then
    result := ScripterList.Count > 0
  else
    result := false;
end;

procedure _Dump(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    TPAXBaseScripter(Scripter).Dump;
end;

procedure _IOResult(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.AsInteger := IOResult;
end;

procedure _ScriptObjectListCount(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.AsInteger := TPAXBaseScripter(Scripter).ScriptObjectList.Count;
end;

procedure _Destroy(MethodBody: TPAXMethodBody);
var
  SO: TPaxScriptObject;
  P: PVariant;
begin
  with MethodBody do
  begin
    P := Params[0].PValue;
    if IsObject(P^) then
    begin
      SO := VariantToScriptObject(P^);
      TPAXBaseScripter(Scripter).ScriptObjectList.RemoveObject(SO);
    end;
    VarClear(P^);
  end;
end;

procedure _PaxArray(MethodBody: TPAXMethodBody);
var
  PaxArray: TPaxArray;
  Bounds: array of Integer;
  I: Integer;
  SO: TPaxScriptObject;
begin
  with MethodBody do
  begin
    SetLength(Bounds, ParamCount);
    for I:=0 to ParamCount - 1 do
      Bounds[I] := Params[I].AsInteger - 1;

    PaxArray := TPaxArray.Create(Bounds);
    PaxArray.Scripter := Scripter;

    SO := DelphiInstanceToScriptObject(PaxArray, Scripter);
    result.AsVariant := ScriptObjectToVariant(SO);
  end;
end;

procedure _GetTickCount(MethodBody: TPAXMethodBody);
begin
{$IFDEF WIN32}
  with MethodBody do
  begin
    result.AsInteger := GetTickCount;
  end;
{$ENDIF}
end;

procedure _GetTotalAllocated(MethodBody: TPAXMethodBody);
var
  D: Double;
begin
{$IFDEF WIN32}
  with MethodBody do
  begin
    D := GetHeapStatus.TotalAllocated;
    result.AsVariant := D;
  end;
{$ELSE}
    result.AsVariant := 0;
{$ENDIF}

end;

procedure _Sleep(MethodBody: TPAXMethodBody);
begin
{$IFDEF WIN32}
  with MethodBody do
    Sleep(Params[0].AsInteger);
{$ENDIF}
end;

procedure _CreateArray(MethodBody: TPAXMethodBody);
var
  HBound: Integer;
begin
  with MethodBody do
  begin
    HBound := Params[0].AsInteger;
    result.AsVariant := varArrayCreate([0, HBound], varVariant);
  end;
end;

procedure _DoNotDestroy(MethodBody: TPAXMethodBody);
var
  V: Variant;
  SO: TPAXScriptObject;
begin
  with MethodBody do
  begin
    V := Params[0].AsVariant;
    SO := VariantToScriptObject(V);
    SO.RefCount := 0;
  end;
end;

procedure _Assigned(MethodBody: TPAXMethodBody);
var
  V: Variant;
  SO: TPAXScriptObject;
begin
  with MethodBody do
  begin
    V := Params[0].AsVariant;
    if IsObject(V) then
    begin
      SO := VariantToScriptObject(V);
      result.AsBoolean := TPAXBaseScripter(Scripter).ScriptObjectList.HasObject(SO);
    end
    else
      result.AsBoolean := false;
  end;
end;

constructor TPAXParameter.Create(AScripter: Pointer);
begin
  Scripter := AScripter;
  Clear;
end;

destructor TPAXParameter.Destroy;
begin
  inherited;
end;

procedure TPAXParameter.Clear;
begin
  PValue := nil;
  VType := varUndefined;
end;

function TPAXParameter.GetAsString: String;
var
  V: Variant;
begin
  V := Variant(PValue^);
  result := ToStr(Scripter, V);
end;

procedure TPAXParameter.SetAsString(const Value: String);
var
  S: String;
begin
  S := ToStr(Scripter, Value);
  Variant(PValue^) := S;
  VType := varString;
end;

function TPAXParameter.GetAsBoolean: Boolean;
var
  V: Variant;
begin
  V := Variant(PValue^);
  result := ToBoolean(V);
end;

procedure TPAXParameter.SetAsBoolean(Value: Boolean);
begin
  Variant(PValue^) := ToBoolean(Value);
  VType := varBoolean;
end;

function TPAXParameter.GetAsInteger: Integer;
begin
  result := ToInteger(PValue^);
end;

procedure TPAXParameter.SetAsInteger(Value: Integer);
begin
  Variant(PValue^) := Value;
end;

function ToCardinal(const V: Variant): Cardinal;
var
  D: Double;
begin
  case VarType(V) of
    varInteger: result := V;
    varDouble:
    begin
      D := V;
      result := Round(D);
    end;
    else
      raise TPAXScriptFailure.Create(errIncompatibleTypes);
  end;
end;

function TPAXParameter.GetAsCardinal: Cardinal;
begin
  result := toCardinal(PValue^);
end;

procedure TPAXParameter.SetAsCardinal(Value: Cardinal);
var
  Dbl: Double;
begin
  if Value > Cardinal(MaxInt) then
  begin
    Dbl := Value;
    Variant(PValue^) := Dbl;
  end
  else
    Variant(PValue^) := Integer(Value);
end;

function TPAXParameter.GetAsPointer: Pointer;
var
  SO: TPaxScriptObject;
begin
  if IsObject(PValue^) then
  begin
    SO := VariantToScriptObject(PValue^);
    if SO.ClassRec.fClassDef <> nil then
      result := SO.Instance
    else
      result := SO;  
  end
  else
    result := Pointer(Integer(PValue^));
end;

procedure TPAXParameter.SetAsPointer(Value: Pointer);
var
  Instance: TObject;
  AClass: TClass;
begin
  if IsDelphiObject(Value) then
  begin
    Instance := TObject(Value);
    if Instance.ClassType = TPaxScriptObject then
    begin
      Variant(PValue^) := Integer(Instance);
      TVarData(Variant(PValue^)).VType := varScriptObject;
    end
    else
      Variant(PValue^) := ScriptObjectToVariant(DelphiInstanceToScriptObject(Instance, Scripter));
  end
  else if IsDelphiClass(Value) then
  begin
    AClass := TClass(Value);
    Variant(PValue^) := ScriptObjectToVariant(DelphiClassToScriptObject(AClass, Scripter));
  end
  else
    Variant(PValue^) := Integer(Value);
end;

function TPAXParameter.GetAsDouble: Double;
begin
  result := PValue^;
end;

procedure TPAXParameter.SetAsDouble(Value: Double);
begin
  Variant(PValue^) := Value;
end;

function TPAXParameter.GetAsTObject: TObject;
var
  V: Variant;
begin
  V := Variant(PValue^);
  result := TObject(ToInteger(V));
  VType := varScriptObject;
end;

procedure TPAXParameter.SetAsTObject(Value: TObject);
begin
  Variant(PValue^) := Integer(Value);
  VType := varScriptObject;
end;

function TPAXParameter.GetAsVariant: Variant;
begin
  result := Variant(PValue^);
end;

procedure TPAXParameter.SetAsVariant(const Value: Variant);
begin
  Variant(PValue^) := Value;
  VType := VarType(Value);
end;

constructor TPAXParameterList.Create(AScripter: Pointer);
var
  I: Integer;
begin
  inherited Create;
  Scripter := AScripter;
  for I:=0 to MaxParams - 1 do
    Add(TPAXParameter.Create(AScripter));
end;

procedure TPAXParameterList.Clear;
var
  I: Integer;
begin
  for I:=0 to Count - 1 do
    TPAXParameter(Items[I]).Free;

  inherited;
end;

constructor TPAXMethodBody.Create(Scripter: Pointer);
begin
  Self.Scripter := Scripter;
  fResult := TPAXParameter.Create(Scripter);
  PSelf := nil;
  fParameterList := TPAXParameterList.Create(Scripter);
  fParamCount := 0;
end;

procedure TPAXMethodBody.AddParameters(K: Integer);
begin
  while fParameterList.Count < K do
    fParameterList.Add(TPAXParameter.Create(Scripter));
end;

function TPAXMethodBody.GetSelf: TObject;
begin
  if PSelf = nil then
    result := nil
  else
    result := TObject(PSelf^);
end;

procedure TPAXMethodBody.SetSelf(Value: TObject);
begin
  if PSelf <> nil then
    TObject(PSelf^) := Value;
end;

destructor TPAXMethodBody.Destroy;
begin
  fResult.Free;
  fParameterList.Free;
end;

function TPAXMethodBody.FindNestedClass(const NamespaceName, ClassName: String): Pointer;
var
  OwnerList: TStringList;
begin
  OwnerList := TStringList.Create;
  if NamespaceName <> '' then
    OwnerList.Add(NamespaceName);
  result := TPAXBaseScripter(Scripter).ClassList.FindNestedClass(OwnerList, ClassName);
  OwnerList.Free;
end;

function TPAXMethodBody.DefaultValue: Variant;
begin
  result := Undefined;
  if PSelf = nil then
    Exit;
  if GetSelf().InheritsFrom(TPAXScriptObject) then
   result := TPAXScriptObject(GetSelf()).DefaultValue;
end;

procedure TPAXMethodBody.Clear;
begin
  fResult.Clear;
  PSelf := nil;
end;

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

  result := fParameterList[I];
end;

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

  fParameterList[I] := Value;
end;