rm_jvinterpreter_system.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 576 行 · 第 1/2 页

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvInterpreter_System.PAS, released on 2002-07-04.
The Initial Developers of the Original Code are: Andrei Prygounkov <[e-mail]>
Copyright (c) 1999, 2002 Andrei Prygounkov
All Rights Reserved.
Contributor(s):  peter Fischer-Haase <[e-mail]> commented as "pfh"
Last Modified: 2002-07-04
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net
Description : JVCL Interpreter version 2
Known Issues:
-----------------------------------------------------------------------------}
{$I rm_JVCL.INC}
unit rm_JvInterpreter_System;
interface
uses
{$IFDEF COMPILER6_UP}
  Variants,
{$ENDIF}
  rm_JvInterpreter, SysUtils;
procedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);
implementation
{ TObject }
{ function ClassType: TClass; }

procedure TObject_ClassType(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := C2V(TObject(Args.Obj).ClassType);
end;
{ function ClassName: ShortString; }

procedure TObject_ClassName(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := TObject(Args.Obj).ClassName;
end;
{ function ClassNameIs(const Name: string): Boolean; }

procedure TObject_ClassNameIs(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := TObject(Args.Obj).ClassNameIs(Args.Values[0]);
end;
{ function ClassParent: TClass; }

procedure TObject_ClassParent(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := C2V(TObject(Args.Obj).ClassParent);
end;
{ function ClassInfo: Pointer; }

procedure TObject_ClassInfo(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := P2V(TObject(Args.Obj).ClassInfo);
end;
{ function InstanceSize: Longint; }

procedure TObject_InstanceSize(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := TObject(Args.Obj).InstanceSize;
end;
{ function InheritsFrom(AClass: TClass): Boolean; }

procedure TObject_InheritsFrom(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := TObject(Args.Obj).InheritsFrom(V2C(Args.Values[0]));
end;
(*
{ function GetInterface(const IID: TGUID; out Obj): Boolean; }
procedure TObject_GetInterface(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := TObject(Args.Obj).GetInterface(Args.Values[0], Args.Values[1], Args.Values[2]);
end;
*)
{ TInterfacedObject }
{ property Read RefCount: Integer }
{$IFDEF COMPILER3_UP}

procedure TInterfacedObject_Read_RefCount(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := TInterfacedObject(Args.Obj).RefCount;
end;
{$ENDIF COMPILER3_UP}
{ procedure Move(const Source; var Dest; Count: Integer); }

procedure JvInterpreter_Move(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Move(Args.Values[0], Args.Values[1], Args.Values[2]);
end;
{ function ParamCount: Integer; }

procedure JvInterpreter_ParamCount(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := ParamCount;
end;
{ function ParamStr(Index: Integer): string; }

procedure JvInterpreter_ParamStr(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := ParamStr(Args.Values[0]);
end;
{ procedure Randomize; }

procedure JvInterpreter_Randomize(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Randomize;
end;

procedure JvInterpreter_Random(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := Random(Integer(Args.Values[0]));
end;
{ function UpCase(Ch: Char): Char; }

procedure JvInterpreter_UpCase(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := UpCase(string(Args.Values[0])[1]);
end;
(*
{ function WideCharToString(Source: PWideChar): string; }
procedure JvInterpreter_WideCharToString(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := WideCharToString(Args.Values[0]);
end;
{ function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string; }
procedure JvInterpreter_WideCharLenToString(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := WideCharLenToString(Args.Values[0], Args.Values[1]);
end;
{ procedure WideCharToStrVar(Source: PWideChar; var Dest: string); }
procedure JvInterpreter_WideCharToStrVar(var Value: Variant; Args: TJvInterpreterArgs);
begin
  WideCharToStrVar(Args.Values[0], string(TVarData(Args.Values[1]).vString));
end;
{ procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer; var Dest: string); }
procedure JvInterpreter_WideCharLenToStrVar(var Value: Variant; Args: TJvInterpreterArgs);
begin
  WideCharLenToStrVar(Args.Values[0], Args.Values[1], string(TVarData(Args.Values[2]).vString));
end;
{ function StringToWideChar(const Source: string; Dest: PWideChar; DestSize: Integer): PWideChar; }
procedure JvInterpreter_StringToWideChar(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := StringToWideChar(Args.Values[0], Args.Values[1], Args.Values[2]);
end;
{ function OleStrToString(Source: PWideChar): string; }
procedure JvInterpreter_OleStrToString(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := OleStrToString(Args.Values[0]);
end;
{ procedure OleStrToStrVar(Source: PWideChar; var Dest: string); }
procedure JvInterpreter_OleStrToStrVar(var Value: Variant; Args: TJvInterpreterArgs);
begin
  OleStrToStrVar(Args.Values[0], string(TVarData(Args.Values[1]).vString));
end;
{ function StringToOleStr(const Source: string): PWideChar; }
procedure JvInterpreter_StringToOleStr(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := StringToOleStr(Args.Values[0]);
end;
*)
{ function VarType(const V: Variant): Integer; }

procedure JvInterpreter_VarType(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := VarType(Args.Values[0]);
end;
{ function VarAsType(const V: Variant; VarType: Integer): Variant; }

procedure JvInterpreter_VarAsType(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := VarAsType(Args.Values[0], Args.Values[1]);
end;
{ function VarIsEmpty(const V: Variant): Boolean; }

procedure JvInterpreter_VarIsEmpty(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := VarIsEmpty(Args.Values[0]);
end;
{ function VarIsNull(const V: Variant): Boolean; }

procedure JvInterpreter_VarIsNull(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := VarIsNull(Args.Values[0]);
end;
{ function VarToStr(const V: Variant): string; }

procedure JvInterpreter_VarToStr(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := VarToStr(Args.Values[0]);
end;
{ function VarFromDateTime(DateTime: TDateTime): Variant; }

procedure JvInterpreter_VarFromDateTime(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := VarFromDateTime(Args.Values[0]);
end;
{ function VarToDateTime(const V: Variant): TDateTime; }

procedure JvInterpreter_VarToDateTime(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := VarToDateTime(Args.Values[0]);
end;
{ function VarArrayCreate(const Bounds: array of Integer; VarType: Integer): Variant; }

procedure JvInterpreter_VarArrayCreate(var Value: Variant; Args: TJvInterpreterArgs);
var
  OA: TOpenArray;
  OAV: TValueArray;
  OAS: integer;
  i: integer;
  AI: array of integer;
begin
  V2OA(Args.Values[0], OA, OAV, OAS);
  if Odd(OAS) then
    raise Exception.Create('The size of bounds array must be even!');
  SetLength(AI, OAS);
  for i := 0 to OAS - 1 do
    AI[i] := OAV[i];
  Value := VarArrayCreate(AI, Args.Values[1]);
end;
{function VarArrayOf(const Values: array of Variant): Variant; }

procedure JvInterpreter_VarArrayOf(var Value: Variant; Args: TJvInterpreterArgs);
var
  OA: TOpenArray;
  OAV: TValueArray;
  OAS: integer;
  i: integer;
  AV: array of Variant;
begin
  V2OA(Args.Values[0], OA, OAV, OAS);
  SetLength(AV, OAS);
  for i := 0 to OAS - 1 do
    AV[i] := OAV[i];
  Value := VarArrayOf(AV);
end;
{ function VarArrayDimCount(const A: Variant): Integer; }

procedure JvInterpreter_VarArrayDimCount(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := VarArrayDimCount(Args.Values[0]);
end;
{ function VarArrayLowBound(const A: Variant; Dim: Integer): Integer; }

procedure JvInterpreter_VarArrayLowBound(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := VarArrayLowBound(Args.Values[0], Args.Values[1]);
end;
{ function VarArrayHighBound(const A: Variant; Dim: Integer): Integer; }

procedure JvInterpreter_VarArrayHighBound(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := VarArrayHighBound(Args.Values[0], Args.Values[1]);
end;
(*{ function VarArrayLock(const A: Variant): Pointer; }
procedure JvInterpreter_VarArrayLock(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := P2V(VarArrayLock(Args.Values[0]));
end;
{ procedure VarArrayUnlock(const A: Variant); }
procedure JvInterpreter_VarArrayUnlock(var Value: Variant; Args: TJvInterpreterArgs);
begin
  VarArrayUnlock(Args.Values[0]);
end;
{ function VarArrayRef(const A: Variant): Variant; }
procedure JvInterpreter_VarArrayRef(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := VarArrayRef(Args.Values[0]);
end;*)
{ function VarIsArray(const A: Variant): Boolean; }

procedure JvInterpreter_VarIsArray(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := VarIsArray(Args.Values[0]);
end;
{ function Ord(const A: Variant): Integer; }

procedure JvInterpreter_Ord(var Value: Variant; Args: TJvInterpreterArgs);
begin
  if VarType(Args.Values[0]) = varString then
    Value := Ord(VarToStr(Args.Values[0])[1])
  else
    Value := Integer(Args.Values[0]);