rm_jvinterpreter.pas

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

    Result := varDouble
  else if Cmp(TypeName, 'tdatetime') then
    Result := varDate
  else if Cmp(TypeName, 'tobject') then
    Result := varObject
  else
    Result := varEmpty;
end;

procedure ClearList(List: TList);
var
  i: Integer;
begin
  if not Assigned(List) then
    Exit;
  for i := 0 to List.Count - 1 do
    TObject(List[i]).Free;
  List.Clear;
end;

procedure ClearMethodList(List: TList);
var
  i: Integer;
begin
  for i := 0 to List.Count - 1 do
    Dispose(PMethod(List[i]));
  List.Clear;
end;
//=== TJvStringStream ========================================================
{$IFNDEF COMPILER3_UP}

constructor TJvStringStream.Create(const AString: string);
begin
  inherited Create;
  FDataString := AString;
end;

function TJvStringStream.Read(var Buffer; Count: Longint): Longint;
begin
  Result := Length(FDataString) - FPosition;
  if Result > Count then
    Result := Count;
  Move(PChar(@FDataString[FPosition + 1])^, Buffer, Result);
  Inc(FPosition, Result);
end;

function TJvStringStream.Write(const Buffer; Count: Longint): Longint;
begin
  Result := Count;
  SetLength(FDataString, (FPosition + Result));
  Move(Buffer, PChar(@FDataString[FPosition + 1])^, Result);
  Inc(FPosition, Result);
end;

function TJvStringStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
  case Origin of
    soFromBeginning:
      FPosition := Offset;
    soFromCurrent:
      FPosition := FPosition + Offset;
    soFromEnd:
      FPosition := Length(FDataString) - Offset;
  end;
  Result := FPosition;
end;

procedure TJvStringStream.SetSize(NewSize: Longint);
begin
  SetLength(FDataString, NewSize);
  if FPosition > NewSize then
    FPosition := NewSize;
end;
{$ENDIF}
{$IFNDEF COMPILER3_UP}

function AnsiStrIComp(S1, S2: PChar): Integer;
begin
  Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, -1,
    S2, -1) - 2;
end;

function AnsiStrLIComp(S1, S2: PChar; MaxLen: Cardinal): Integer;
begin
  Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE,
    S1, MaxLen, S2, MaxLen) - 2;
end;
{$ENDIF COMPILER3_UP}
// (rom) JvUtil added to uses and funtions deleted

function Cmp(const S1, S2: string): Boolean;
begin
{$IFDEF COMPLIB_VCL}
  // Direct call to CompareString is faster when ANSICompareText.
  Result := (Length(S1) = Length(S2)) and
    (CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PChar(S1),
    -1, PChar(S2), -1) = 2);
{$ENDIF COMPLIB_VCL}
{$IFDEF COMPLIB_CLX}
  Result := ANSICompareText(S1, S2) = 0;
{$ENDIF COMPLIB_CLX}
end;
{************* Some code from RAStream unit **************}

procedure StringSaveToStream(Stream: TStream; S: string);
var
  L: Integer;
  P: PChar;
begin
  L := Length(S);
  Stream.WriteBuffer(L, SizeOf(L));
  P := PChar(S);
  Stream.WriteBuffer(P^, L);
end;

function StringLoadFromStream(Stream: TStream): string;
var
  L: Integer;
  P: PChar;
begin
  Stream.ReadBuffer(L, SizeOf(L));
  SetLength(Result, L);
  P := PChar(Result);
  Stream.ReadBuffer(P^, L);
end;

procedure IntSaveToStream(Stream: TStream; AInt: Integer);
begin
  Stream.WriteBuffer(AInt, SizeOf(AInt));
end;

function IntLoadFromStream(Stream: TStream): Integer;
begin
  Stream.ReadBuffer(Result, SizeOf(Result));
end;

procedure WordSaveToStream(Stream: TStream; AWord: Word);
begin
  Stream.WriteBuffer(AWord, SizeOf(AWord));
end;

function WordLoadFromStream(Stream: TStream): Word;
begin
  Stream.ReadBuffer(Result, SizeOf(Result));
end;

procedure ExtendedSaveToStream(Stream: TStream; AExt: Extended);
begin
  Stream.WriteBuffer(AExt, SizeOf(AExt));
end;

function ExtendedLoadFromStream(Stream: TStream): Extended;
begin
  Stream.ReadBuffer(Result, SizeOf(Result));
end;

procedure BoolSaveToStream(Stream: TStream; ABool: Boolean);
var
  B: Integer;
begin
  B := Integer(ABool);
  Stream.WriteBuffer(B, SizeOf(B));
end;

function BoolLoadFromStream(Stream: TStream): Boolean;
var
  B: Integer;
begin
  Stream.ReadBuffer(B, SizeOf(B));
  Result := (B <> 0);
end;
{################## from RAStream unit ##################}
{$IFDEF JvInterpreter_OLEAUTO}
{************* Some code from Delphi's OleAuto unit **************}
const
{$IFDEF COMPILER3_UP}
  { Maximum number of dispatch arguments }
  MaxDispArgs = 64;
{$ENDIF COMPILER3_UP}
  { Special variant type codes }
  varStrArg = $0048;
  { Parameter type masks }
  atVarMask = $3F;
  atTypeMask = $7F;
  atByRef = $80;
{ Call GetIDsOfNames method on the given IDispatch interface }

procedure GetIDsOfNames(Dispatch: IDispatch; Names: PChar;
  NameCount: Integer; DispIDs: PDispIDList);
var
  I, N: Integer;
  Ch: WideChar;
  P: PWideChar;
  NameRefs: array[0..MaxDispArgs - 1] of PWideChar;
  WideNames: array[0..1023] of WideChar;
  R: Integer;
begin
  I := 0;
  N := 0;
  repeat
    P := @WideNames[I];
    if N = 0 then
      NameRefs[0] := P
    else
      NameRefs[NameCount - N] := P;
    repeat
      Ch := WideChar(Names[I]);
      WideNames[I] := Ch;
      Inc(I);
    until Char(Ch) = #0;
    Inc(N);
  until N = NameCount;
  { if Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount,
    LOCALE_SYSTEM_DEFAULT, DispIDs) <> 0 then }
  R := Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount,
    LOCALE_SYSTEM_DEFAULT, DispIDs);
  if R <> 0 then
{$IFDEF COMPILER3_UP}
    raise EOleError.CreateFmt(SNoMethod, [Names]);
{$ELSE}
    raise EOleError.CreateResFmt(SNoMethod, [Names]);
{$ENDIF COMPILER3_UP}
end;
{ Central call dispatcher }

procedure VarDispInvoke(Result: PVariant; const Dispatch: Pointer;
  Names: PChar; CallDesc: PCallDesc; ParamTypes: Pointer); cdecl;
var
  DispIDs: array[0..MaxDispArgs - 1] of Integer;
begin
  GetIDsOfNames(IDispatch(Dispatch), Names, CallDesc^.NamedArgCount + 1, PDispIDList(@DispIDs[0]));
  if Result <> nil then
    VarClear(Result^);
{$IFDEF COMPILER3_UP}
  DispatchInvoke(IDispatch(Dispatch), CallDesc, PDispIDList(@DispIDs[0]), ParamTypes, Result);
{$ELSE}
  DispInvoke(Dispatch, CallDesc, PDispIDList(@DispIDs[0]), ParamTypes, Result);
{$ENDIF COMPILER3_UP}
end;
{################## from OleAuto unit ##################}
{$ENDIF JvInterpreter_OLEAUTO}
type
  TFunc = procedure; far;
  TiFunc = function: Integer; far;
  TfFunc = function: Boolean; far;
  TwFunc = function: Word; far;

function CallDllIns(Ins: HINST; FuncName: string; Args: TJvInterpreterArgs;
  ParamDesc: TTypeArray; ResTyp: Word): Variant;
var
  Func: TFunc;
  iFunc: TiFunc;
  fFunc: TfFunc;
  wFunc: TwFunc;
  i: Integer;
  Aint: Integer;
 // Abyte : Byte;
  Aword: Word;
  Apointer: Pointer;
  Str: string;
begin
  Result := Null;
  Func := GetProcAddress(Ins, PChar(FuncName));
  iFunc := @Func;
  fFunc := @Func;
  wFunc := @Func;
  if @Func <> nil then
  begin
    try
      for i := Args.Count - 1 downto 0 do { 'stdcall' call conversion }
      begin
        if (ParamDesc[i] and varByRef) = 0 then
          case ParamDesc[i] of
            varInteger, { ttByte,} varBoolean:
              begin
                Aint := Args.Values[i];
                asm push Aint
                end;
              end;
            varSmallInt:
              begin
                Aword := Word(Args.Values[i]);
                asm push Aword
                end;
              end;
            varString:
              begin
                Apointer := PChar(string(Args.Values[i]));
                asm push Apointer
                end;
              end;
          else
            JvInterpreterErrorN(ieDllInvalidArgument, -1, FuncName);
          end
        else
          case ParamDesc[i] and not varByRef of
            varInteger, { ttByte,} varBoolean:
              begin
                Apointer := @TVarData(Args.Values[i]).vInteger;
                asm push Apointer
                end;
              end;
            varSmallInt:
              begin
                Apointer := @TVarData(Args.Values[i]).vSmallInt;
                asm push Apointer
                end;
              end;
          else
            JvInterpreterErrorN(ieDllInvalidArgument, -1, FuncName);
          end
      end;
      case ResTyp of
        varSmallInt:
          Result := wFunc;
        varInteger:
          Result := iFunc;
        varBoolean:
          Result := Boolean(Integer(fFunc));
        varEmpty:
          Func;
      else
        JvInterpreterErrorN(ieDllInvalidResult, -1, FuncName);
      end;
    except
      on E: EJvInterpreterError do
        raise E;
      on E: Exception do
      begin
        Str := E.Message;
        UniqueString(Str);
        raise Exception.Create(Str);
      end;
    end;
  end
  else
    JvInterpreterError(ieDllFunctionNotFound, -1);
end;

function CallDll(DllName, FuncName: string; Args: TJvInterpreterArgs;
  ParamDesc: TTypeArray; ResTyp: Word): Variant;
var
  Ins: HMODULE;
  LastError: DWORD;
begin
  Result := False;
  Ins := LoadLibrary(PChar(DllName));
  if Ins = 0 then
    JvInterpreterErrorN(ieDllErrorLoadLibrary, -1, DllName);
  try
    Result := CallDllIns(Ins, FuncName, Args, ParamDesc, ResTyp);