imp_pascal.pas

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

  with MethodBody do
  begin
    FW := GetFileWrapper(Params[0].AsVariant);
    if FW.FileKind = fkText then
      Result.AsVariant := SeekEof(FW.T)
    else
      raise Exception.Create('Incompatible types');
  end;
end;

procedure _Append(MethodBody: TPAXMethodBody);
var
  FW: TFileWrapper;
begin
  with MethodBody do
  begin
    FW := GetFileWrapper(Params[0].AsVariant);
    if FW.FileKind = fkText then
      Append(FW.T)
    else
      raise Exception.Create('Incompatible types');
  end;
end;

procedure _Flush(MethodBody: TPAXMethodBody);
var
  FW: TFileWrapper;
begin
  with MethodBody do
  begin
    FW := GetFileWrapper(Params[0].AsVariant);
    if FW.FileKind = fkText then
      Flush(FW.T)
    else
      raise Exception.Create('Incompatible types');
  end;
end;

procedure _Reset(MethodBody: TPAXMethodBody);
var
  FW: TFileWrapper;
begin
  with MethodBody do
  begin
    FW := GetFileWrapper(Params[0].AsVariant);
    case FW.FileKind of
      fkText: Reset(FW.T);
      fkFile: Reset(FW.F);
    end;
  end;
end;

procedure _Rewrite(MethodBody: TPAXMethodBody);
var
  FW: TFileWrapper;
begin
  with MethodBody do
  begin
    FW := GetFileWrapper(Params[0].AsVariant);
    case FW.FileKind of
      fkText: Rewrite(FW.T);
      fkFile: Rewrite(FW.F);
    end;
  end;
end;

procedure _CloseFile(MethodBody: TPAXMethodBody);
var
  FW: TFileWrapper;
  SO: TPAXScriptObject;
begin
  with MethodBody do
  begin
    FW := GetFileWrapper(Params[0].AsVariant);
    SO := VariantToScriptObject(Params[0].AsVariant);
    case FW.FileKind of
      fkText: CloseFile(FW.T);
      fkFile: CloseFile(FW.F);
    end;
    FW.Free;
    TPAXBaseScripter(Scripter).ScriptObjectList.RemoveObject(SO);

    Params[0].AsVariant := Undefined;
  end;
end;

procedure _Writeln(MethodBody: TPAXMethodBody);
var
  I: Integer;
  S: String;
  L: TStringList;
  FW: TFileWrapper;
begin
  S := '';
  L := TStringList.Create;
  try
    with MethodBody do
    begin
      if ParamCount > 0 then
      begin
        FW := GetTextFileWrapper(Params[0].AsVariant);
        if FW <> nil then
        begin
          for I:=1 to ParamCount - 1 do
            S := S + toString(Params[I].AsVariant);
          Writeln(FW.T, S);
          Exit;
        end;
      end;

      for I:=0 to ParamCount - 1 do
        S := S + toString(Params[I].AsVariant);
      with TPAXBaseScripter(MethodBody.Scripter) do
        if Assigned(OnPrint) then
        begin
          OnPrint(Owner, S);
          OnPrint(Owner, #13#10);
        end
        else
          ErrMessageBox(S);
    end;
  finally
    L.Free;
  end;
end;

procedure _Write(MethodBody: TPAXMethodBody);
var
  I: Integer;
  S: String;
  L: TStringList;
  FW: TFileWrapper;
begin
  S := '';
  L := TStringList.Create;
  try
    with MethodBody do
    begin
      if ParamCount > 0 then
      begin
        FW := GetTextFileWrapper(Params[0].AsVariant);
        if FW <> nil then
        begin
          for I:=1 to ParamCount - 1 do
            S := S + toString(Params[I].AsVariant);
          Write(FW.T, S);
          Exit;
        end;
      end;

      for I:=0 to ParamCount - 1 do
        S := S + toString(Params[I].AsVariant);
      L.Add(S);

      with TPAXBaseScripter(MethodBody.Scripter) do
        if Assigned(OnPrint) then
          OnPrint(Owner, S)
        else
          ErrMessageBox(S);
    end;
  finally
    L.Free;
  end;
end;

procedure _Read(MethodBody: TPAXMethodBody);
var
  I: Integer;
  S: String;
  FW: TFileWrapper;
begin
  with MethodBody do
  begin
    if ParamCount > 0 then
    begin
      FW := GetTextFileWrapper(Params[0].AsVariant);
      if FW <> nil then
      begin
        for I:=1 to ParamCount - 1 do
        begin
          Read(FW.T, S);
          Params[I].AsVariant := StringValueToVariant(S, Params[I].AsVariant);
        end;
        Exit;
      end;
    end;

    for I:=0 to ParamCount - 1 do
    begin
      with TPAXBaseScripter(MethodBody.Scripter) do
        if Assigned(OnPrint) then
          OnRead(Owner, S)
        else
          Read(S);
      Params[I].AsVariant := StringValueToVariant(S, Params[I].AsVariant);
    end;
  end;
end;

procedure _Readln(MethodBody: TPAXMethodBody);
var
  I: Integer;
  S: String;
  FW: TFileWrapper;
begin
  with MethodBody do
  begin
    if ParamCount > 0 then
    begin
      FW := GetTextFileWrapper(Params[0].AsVariant);
      if FW <> nil then
      begin
        for I:=1 to ParamCount - 1 do
        begin
          Readln(FW.T, S);
          Params[I].AsVariant := StringValueToVariant(S, Params[I].AsVariant);
        end;
        Exit;
      end;
    end;

    for I:=0 to ParamCount - 1 do
    begin
      with TPAXBaseScripter(MethodBody.Scripter) do
        if Assigned(OnPrint) then
          OnRead(Owner, S)
        else
          Readln(S);
      Params[I].AsVariant := StringValueToVariant(S, Params[I].AsVariant);
    end;
  end;
end;


var
  H: Integer;

initialization

  Randomize;

  H := RegisterNamespace('paxPascalNamespace', -1);

  RegisterConstant('Null', Null);

  RegisterConstant('varEmpty', varEmpty);
  RegisterConstant('varNull', varNull);
  RegisterConstant('varSmallint', varSmallint);
  RegisterConstant('varInteger', varInteger);
  RegisterConstant('varSingle', varSingle);
  RegisterConstant('varDouble', varDouble);
  RegisterConstant('varCurrency', varCurrency);
  RegisterConstant('varDate', varDate);
  RegisterConstant('varOleStr', varOleStr);
  RegisterConstant('varDispatch', varDispatch);
  RegisterConstant('varError', varError);
  RegisterConstant('varBoolean', varBoolean);
  RegisterConstant('varVariant', varVariant);
  RegisterConstant('varUnknown', varUnknown);
  RegisterConstant('varByte', varByte);
  RegisterConstant('varStrArg', varStrArg);
  RegisterConstant('varString', varString);
  RegisterConstant('varAny', varAny);
  RegisterConstant('varTypeMask', varTypeMask);
  RegisterConstant('varArray', varArray);
  RegisterConstant('varByRef', varByRef);

  RegisterStdRoutine('ArcCos', _ArcCos, 1, H);
  RegisterStdRoutine('ArcTan', _ArcTan, 1, H);
  RegisterStdRoutine('ArcTan2', _ArcTan2, 2, H);
  RegisterStdRoutine('ArcSin', _ArcSin, 1, H);
  RegisterStdRoutine('Cos', _Cos, 1, H);
  RegisterStdRoutine('Tan', _Tan, 1, H);
  RegisterStdRoutine('Sin', _Sin, 1, H);
  RegisterStdRoutine('Cosh', _Cosh, 1, H);
  RegisterStdRoutine('Tanh', _Tanh, 1, H);
  RegisterStdRoutine('Sinh', _Sinh, 1, H);

  RegisterStdRoutineEx2('Inc', _Inc, -1, [typeINTEGER], [true], H);
  RegisterStdRoutineEx2('Dec', _Dec, -1, [typeINTEGER], [true], H);
  RegisterStdRoutine('Pos', _Pos, 2, H);
  RegisterStdRoutine('Copy', _Copy, 3, H);
  RegisterStdRoutine('Delete', _Delete, 3, H);
  RegisterStdRoutine('Insert', _Insert, 3, H);

  RegisterRoutine('function Abs(const X: Variant): Variant;', @_Abs, H);
  RegisterRoutine('function Exp(const X: Variant): Variant;', @_Exp, H);
  RegisterRoutine('function Ln(const X: Variant): Variant;', @_Ln, H);
  RegisterStdRoutine('Sqr', _Sqr, 1, H);

  RegisterRoutine('function Trunc(const X: Variant): Integer;', @_Trunc, H);

  RegisterRoutine('function Random(Range: Integer): Integer;', @_Random, H);

  RegisterRoutine('function Chr(X: Byte): Char;', @_Chr);
  RegisterStdRoutine('Ord', _Ord, 1, H);

  RegisterClassType(TFileWrapper, -1);
  RegisterClassType(TextFile, -1);

  RegisterStdRoutine('AssignFile', _AssignFile, 2, H);
  RegisterStdRoutine('Eoln', _Eoln, 1, H);
  RegisterStdRoutine('SeekEoln', _SeekEoln, 1, H);
  RegisterStdRoutine('Eof', _Eof, 1, H);
  RegisterStdRoutine('SeekEof', _SeekEof, 1, H);
  RegisterStdRoutine('Append', _Append, 1, H);
  RegisterStdRoutine('Flush', _Flush, 1, H);
  RegisterStdRoutine('Reset', _Reset, 1, H);
  RegisterStdRoutine('Rewrite', _Rewrite, 1, H);
  RegisterStdRoutine('CloseFile', _CloseFile, 1, H);
  RegisterStdRoutine('write', _Write, -1, H);
  RegisterStdRoutine('writeln', _Writeln, -1, H);
  RegisterStdRoutine('read', _Read, -1, H);
  RegisterStdRoutine('readln', _Readln, -1, H);

  RegisterRoutine('function VarArrayCreate(const Bounds: array of Integer; VarType: Integer): Variant;',
                  @VarArrayCreate);
  RegisterRoutine('function VarArrayOf(const Values: array of Variant): Variant;',
                  @VarArrayOf);
  RegisterRoutine('function VarArrayDimCount(const A: Variant): Integer;',
                  @VarArrayDimCount);
  RegisterRoutine('function VarArrayLowBound(const A: Variant; Dim: Integer): Integer;',
                  @VarArrayLowBound);
  RegisterRoutine('function VarArrayHighBound(const A: Variant; Dim: Integer): Integer;',
                  @VarArrayHighBound);
  RegisterRoutine('function VarIsArray(const A: Variant): Boolean;',
                  @VarIsArray);

  RegisterRoutine('function Round(X: Extended): Int64;', @_Round);
  RegisterRoutine('function Int(X: Extended): Extended;', @_Int);
end.