Создание своей DLL на Delphi или Lazarus для Lua (в QUIK) (Страница 2 из 3)

unit LuaHelpers;

interface

uses 
  Classes, SysUtils,
  LuaLib;

type
  TLuaState     = LuaLib.lua_State;

  TLuaContext   = class;
  TLuaTable     = class;

  TLuaField     = class(tObject)
  private
    fContext    : TLuaContext;
    fFieldType  : integer;
    fNumber     : double;
    fBool       : boolean;
    fString     : ansistring;
    fTable      : TLuaTable;
    fIndex      : integer;

    function    getabsindex(AIndex: integer): integer;
    function    fExtractField(AIndex: integer): TLuaField;
    function    fGetField(AIndex: integer; const AName: ansistring): TLuaField;
  public
    constructor create(AContext: TLuaContext);
    destructor  destroy; override;
    function    AsBoolean(adefault: boolean = false): boolean;
    function    AsInteger(adefault: integer = 0): integer;
    function    AsNumber(adefault: double = 0.0): double;
    function    AsString(const adefault: ansistring = ''): ansistring;
    function    AsTable: TLuaTable;

    property    FieldType: integer read fFieldType;
    property    FieldByName[AIndex: integer; const AName: ansistring]: TLuaField read fGetField; default;
  end;

  TLuaTable     = class(tObject)
  private
    fContext    : TLuaContext;
    fField      : TLuaField;
    fIndex      : integer;
    fPopSize    : integer;
    fCurField   : TLuaField;
    fStackAlloc : boolean;

    function    getabsindex(AIndex: integer): integer;
    procedure   fSetIndex(AIndex: integer);
    function    fGetFieldByName(const AName: ansistring): TLuaField;
    function    fGetField: TLuaField;
    function    fGetSelf: TLuaTable;
  protected
    property    Field: TLuaField read fGetField;
  public
    constructor create(AContext: TLuaContext); overload;
    constructor create(AContext: TLuaContext; AIndex: integer); overload;
    constructor create(AContext: TLuaContext; ALuaTable: TLuaTable; const AName: ansistring); overload;
    constructor create(AContext: TLuaContext; const AGlobalName: ansistring); overload;
    destructor  destroy; override;

    function    FindFirst: boolean;
    function    FindNext: boolean;
    procedure   FindClose;

    function    FindField(const AName: ansistring): boolean;

    function    CallMethodSafe(const AName: ansistring; const AArgs: array of const; AResCount: integer; var error: ansistring; AResType: integer = LUA_TNONE): boolean;

    property    CurrentTable: TLuaTable read fGetSelf;
    property    Index: integer read fIndex write fSetIndex;
    property    FieldByName[const AName: ansistring]: TLuaField read fGetFieldByName; default;
    property    CurrentField: TLuaField read fCurField;
    property    Context: TLuaContext read fContext;
  end;

  TLuaContext   = class(tObject)
  private
    fLuaState   : TLuaState;
    fField      : TLuaField;
    function    fGetStackByIndex(AIndex: integer): TLuaField;
    function    fGetGlobalByName(const AName: ansistring): TLuaField;
    function    fGetSelf: TLuaContext;
  public
    constructor create(ALuaState: TLuaState);
    destructor  destroy; override;

    function    PushArgs(const aargs: array of const): integer;

    function    PushTable(aKVTable: tStringList): integer; overload;
    function    PushTable(const aargs: array of const): integer; overload;  // aargs must look like: ['name1', value1, 'name2', value2]

    function    Call(const AName: ansistring; const AArgs: array of const; AResCount: integer; AResType: integer = LUA_TNONE): boolean;
    function    CallSafe(const AName: ansistring; const AArgs: array of const; AResCount: integer; var error: ansistring; AResType: integer = LUA_TNONE): boolean;

    function    ExecuteSafe(const AScript: ansistring; AResCount: integer; var error: ansistring): boolean;

    procedure   CleanUp(ACount: integer);

    procedure   SetGlobal(AIndex: integer; const AName: ansistring);
    procedure   ResetGlobal(const AName: ansistring);

    property    CurrentContext: TLuaContext read fGetSelf;
    property    CurrentState: TLuaState read fLuaState;
    property    Stack[AIndex: integer]: TLuaField read fGetStackByIndex; default;
    property    Globals[const AName: ansistring]: TLuaField read fGetGlobalByName;
  end;

  TOnTableItemEx = function(ATable: TLuaTable): boolean of object;

implementation

function  StrToFloatDef(const astr: ansistring; adef: extended): extended;
begin if not TextToFloat(pAnsiChar(astr), result, fvExtended) then result:= adef; end;

{ TLuaField }

constructor TLuaField.create(AContext: TLuaContext);
begin
  inherited create;
  fContext:= AContext;
  fTable:= nil;
  fFieldType:= LUA_TNONE;
  fNumber:= 0;
  fBool:= false;
  setlength(fString, 0);
end;

destructor TLuaField.destroy;
begin
  if assigned(fTable) then freeandnil(fTable);
  inherited destroy;
end;

function TLuaField.getabsindex(AIndex: integer): integer;
begin
  if ((AIndex = LUA_GLOBALSINDEX) or (AIndex = LUA_REGISTRYINDEX)) then result := AIndex
  else if (AIndex < 0) then result := AIndex + lua_gettop(fContext.CurrentState) + 1
  else result := AIndex;
end;

function TLuaField.fExtractField(AIndex: integer): TLuaField;
var len : cardinal;
begin
  fFieldType:= lua_type(fContext.CurrentState, AIndex);
  case fFieldType of
    LUA_TNUMBER   : fNumber := lua_tonumber(fContext.CurrentState, AIndex);
    LUA_TBOOLEAN  : fBool := lua_toboolean(fContext.CurrentState, AIndex);
    LUA_TSTRING   : begin
                      len:= 0;
                      SetString(fString, lua_tolstring(fContext.CurrentState, AIndex, len), len);
                    end;
    LUA_TTABLE    : begin
                      if not assigned(fTable) then fTable:= TLuaTable.create(fContext, AIndex)
                                              else fTable.Index:= AIndex;
                    end;
    LUA_TFUNCTION : fIndex:= getabsindex(aindex);
    else            fFieldType:= LUA_TNONE;
  end;
  result:= Self;
end;

function TLuaField.fGetField(AIndex: integer; const AName: ansistring): TLuaField;
begin
  result:= Self;
  lua_pushstring(fContext.CurrentState, pAnsiChar(AName));
  lua_gettable(fContext.CurrentState, AIndex);
  try
    case lua_type(fContext.CurrentState, -1) of
      LUA_TTABLE : fFieldType:= LUA_TNONE;
      else         result:= fExtractField(-1) // only simple types allowed
    end;
  finally lua_pop(fContext.CurrentState, 1); end;
end;

function TLuaField.AsBoolean(adefault: boolean): boolean;
begin
  case fFieldType of
    LUA_TBOOLEAN : result:= fBool;
    LUA_TNUMBER  : result:= (fNumber <> 0);
    LUA_TSTRING  : result:= (AnsiCompareText(fString, 'TRUE') = 0);
    else           result:= adefault;
  end;
end;

function TLuaField.AsInteger(adefault: integer): integer;
begin result:= round(AsNumber(adefault)); end;

function TLuaField.AsNumber(adefault: double): double;
begin
  case fFieldType of
    LUA_TBOOLEAN : result:= integer(fBool);
    LUA_TNUMBER  : result:= fNumber;
    LUA_TSTRING  : result:= StrToFloatDef(fString, adefault);
    else           result:= adefault;
  end;
end;

function TLuaField.AsString(const adefault: ansistring): ansistring;
const boolval : array[boolean] of ansistring = ('FALSE', 'TRUE');
begin
  case fFieldType of
    LUA_TBOOLEAN : result:= boolval[fBool];
    LUA_TNUMBER  : result:= FloatToStr(fNumber);
    LUA_TSTRING  : result:= fString;
    else           result:= '';
  end;
end;

function TLuaField.AsTable: TLuaTable;
begin
  if (fFieldType = LUA_TTABLE) then result:= fTable
                               else result:= nil;
end;

{ TLuaTable }

constructor TLuaTable.create(AContext: TLuaContext);
begin
  inherited create;
  fContext:= AContext;
  fField:= nil;
  fCurField:= nil;
  fIndex:= 0;
  fStackAlloc:= false;
  fPopSize:= 0;
end;

constructor TLuaTable.create(AContext: TLuaContext; AIndex: integer);
begin
  inherited create;
  fContext:= AContext;
  fField:= nil;
  fCurField:= nil;
  fIndex:= getabsindex(AIndex);
  fStackAlloc:= false;
  fPopSize:= 0;
end;

constructor TLuaTable.create(AContext: TLuaContext; ALuaTable: TLuaTable; const AName: ansistring);
begin
  inherited create;
  fContext:= AContext;
  fField:= nil;
  fCurField:= nil;
  fIndex:= 0;
  fStackAlloc:= false;
  fPopSize:= 0;

  lua_pushstring(fContext.CurrentState, pAnsiChar(AName));
  lua_gettable(fContext.CurrentState, ALuaTable.Index);
  if lua_istable(fContext.CurrentState, -1) then begin
    fIndex:= getabsindex(-1);
    fStackAlloc:= true;
  end else begin
    lua_pop(fContext.CurrentState, 1);
    raise Exception.CreateFmt('Field %s is not a table', [AName]);
  end;
end;

constructor TLuaTable.create(AContext: TLuaContext; const AGlobalName: ansistring);
begin
  inherited create;
  fContext:= AContext;
  fField:= nil;
  fCurField:= nil;
  fIndex:= 0;
  fStackAlloc:= false;
  fPopSize:= 0;

  lua_getglobal(fContext.CurrentState, pAnsiChar(AGlobalName));
  if lua_istable(fContext.CurrentState, -1) then begin
    fIndex:= getabsindex(-1);
    fStackAlloc:= true;
  end else begin
    lua_pop(fContext.CurrentState, 1);
    raise Exception.CreateFmt('Global %s is not a table', [AGlobalName]);
  end;
end;

destructor TLuaTable.destroy;
begin
  if fStackAlloc then lua_pop(fContext.CurrentState, 1);
  fCurField:= nil;
  if assigned(fField) then freeandnil(fField);
  inherited destroy;
end;

function TLuaTable.getabsindex(AIndex: integer): integer;
begin
  if ((AIndex = LUA_GLOBALSINDEX) or (AIndex = LUA_REGISTRYINDEX)) then result := AIndex
  else if (AIndex < 0) then result := AIndex + lua_gettop(fContext.CurrentState) + 1
  else result := AIndex;
end;

procedure TLuaTable.fSetIndex(AIndex: integer);
begin fIndex:= getabsindex(AIndex); end;

function TLuaTable.fGetField: TLuaField;
begin
  if not assigned(fField) then fField:= TLuaField.create(fContext);
  result:= fField;
end;

function TLuaTable.fGetFieldByName(const AName: ansistring): TLuaField;
begin result:= Field.FieldByName[fIndex, AName]; end;

function TLuaTable.fGetSelf: TLuaTable;
begin result:= Self; end;

function TLuaTable.FindFirst: boolean;
begin
  FindClose;
  lua_pushnil(fContext.CurrentState);
  lua_pushnil(fContext.CurrentState);  // imitate "value"
  result:= FindNext;
end;

function TLuaTable.FindNext: boolean;
begin
  lua_pop(fContext.CurrentState, 1);   // pop previous "value"
  result:= (lua_next(fContext.CurrentState, Index) <> 0);
  if result then begin
    fCurField:= Field.fExtractField(-1);
    fPopSize:= 2;                      // leave "key" on stack, need to cleanup if findclose()
  end else begin
    fCurField:= nil;
    fPopSize:= 0;                      // no need to cleanup, stack is empty
  end;
end;

procedure TLuaTable.FindClose;
begin
  if (fPopSize > 0) then lua_pop(fContext.CurrentState, fPopSize);
  fPopSize:= 0;
end;

function TLuaTable.FindField(const AName: ansistring): boolean;
begin
  lua_pushstring(fContext.CurrentState, pAnsiChar(AName));
  lua_gettable(fContext.CurrentState, Index);
  fCurField:= Field.fExtractField(-1);
  fPopSize:= 1;
  result:= true;
end;

function TLuaTable.CallMethodSafe(const AName: ansistring; const AArgs: array of const; AResCount: integer; var error: ansistring; AResType: integer): boolean;
var len: cardinal;
begin
  if (AResCount < 0) then AResCount:= LUA_MULTRET;
  lua_getfield(fContext.CurrentState, Index, pAnsiChar(AName));
  lua_pushvalue(fContext.CurrentState, Index);
  fContext.PushArgs(AArgs);
  if (lua_pcall(fContext.CurrentState, length(aargs) + 1, AResCount, 0) = 0) then begin
    if (AResType <> LUA_TNONE) then begin
      result:= (lua_type(fContext.CurrentState, -1) = AResType);
      if not result and (AResCount > 0) then lua_pop(fContext.CurrentState, AResCount);
    end else result:= true;
  end else begin
    len:= 0;
    SetString(error, lua_tolstring(fContext.CurrentState, -1, len), len);
    lua_pop(fContext.CurrentState, 1);
    result:= false;
  end;
end;

{ TLuaContext }

constructor TLuaContext.create(ALuaState: TLuaState);
begin
  inherited create;
  fLuaState:= ALuaState;
  fField:= nil;
end;

destructor TLuaContext.destroy;
begin
  if assigned(fField) then freeandnil(fField);
  inherited destroy;
end;

function TLuaContext.fGetStackByIndex(AIndex: integer): TLuaField;
begin
  if not assigned(fField) then fField:= TLuaField.create(Self);
  result:= fField.fExtractField(AIndex);
end;

function TLuaContext.fGetGlobalByName(const AName: ansistring): TLuaField;
begin
  if not assigned(fField) then fField:= TLuaField.create(Self);
  lua_getglobal(fLuaState, pAnsiChar(AName));
  result:= fField.fExtractField(-1);  // may be problems with tables?
  lua_pop(fLuaState, 1);
end;

function TLuaContext.fGetSelf: TLuaContext;
begin result:= Self; end;

function TLuaContext.PushArgs(const aargs: array of const): integer;
var i : integer;
begin
  for i:= 0 to length(aargs) - 1 do begin
    with aargs[i] do begin
      case vType of
        vtInteger    : lua_pushinteger(fLuaState, vInteger);
        vtInt64      : lua_pushnumber(fLuaState, vInt64^);
        vtPChar      : lua_pushstring(fLuaState, pAnsiChar(vPChar));
        vtAnsiString : lua_pushstring(fLuaState, pAnsiChar(vAnsiString));
        vtExtended   : lua_pushnumber(fLuaState, vExtended^);
        vtBoolean    : lua_pushboolean(fLuaState, vBoolean);
        vtObject     : if assigned(vObject) then begin
                         if (vObject is tStringList) then PushTable(tStringList(vObject))
                                                     else lua_pushnil(fLuaState);
                       end else lua_pushnil(fLuaState);
        else           lua_pushnil(fLuaState);
      end;
    end;
  end;
  result:= length(aargs);
end;

function TLuaContext.PushTable(aKVTable: tStringList): integer;
var tmp : ansistring;
    p   : pAnsiChar;
    i   : integer;
begin
  result:= 0;
  if assigned(aKVTable) then with aKVTable do begin
    lua_createtable(fLuaState, Count, 0);
    for i := 0 to count - 1 do begin
      tmp:= Names[i];
      lua_pushstring(fLuaState, pAnsiChar(tmp));
      tmp:= Values[tmp];
      if (length(tmp) > 0) and (tmp[1]='"') then begin
        p:= pAnsiChar(tmp);
        tmp:= AnsiExtractQuotedStr(p, '"');
      end;
      lua_pushstring(fLuaState, pAnsiChar(tmp));
      lua_settable(fLuaState, -3);
    end;
    result:= 1;
  end;
end;

function TLuaContext.PushTable(const aargs: array of const): integer;
var i, count : integer;
begin
  count:= (length(aargs) div 2) * 2;                   // must be even, if not - last pair is not pushed!
  lua_createtable(fLuaState, count div 2, 0);
  for i:= 0 to count - 1 do begin
    with aargs[i] do
      case vType of
        vtInteger    : lua_pushinteger(fLuaState, vInteger);
        vtInt64      : lua_pushnumber(fLuaState, vInt64^);
        vtPChar      : lua_pushstring(fLuaState, pAnsiChar(vPChar));
        vtAnsiString : lua_pushstring(fLuaState, pAnsiChar(vAnsiString));
        vtExtended   : lua_pushnumber(fLuaState, vExtended^);
        vtBoolean    : lua_pushboolean(fLuaState, vBoolean);
        else           lua_pushnil(fLuaState);
      end;
    if (i mod 2 = 1) then lua_settable(fLuaState, -3); // set on every odd i
  end;
  result:= 1;
end;

function TLuaContext.Call(const AName: ansistring; const AArgs: array of const; AResCount: integer; AResType: integer): boolean;
begin
  if (AResCount < 0) then AResCount:= LUA_MULTRET;
  lua_getglobal(fLuaState, pAnsiChar(AName));                              // get function index
  PushArgs(aargs);                                                         // push parameters
  lua_call(fLuaState, length(aargs), AResCount);                           // call function
  if (AResType <> LUA_TNONE) then begin
    result:= (lua_type(fLuaState, -1) = AResType);
    if not result and (AResCount > 0) then lua_pop(fLuaState, AResCount);  // cleanup stack if unexpected type returned
  end else result:= true;
end;

function TLuaContext.CallSafe(const AName: ansistring; const AArgs: array of const; AResCount: integer; var error: ansistring; AResType: integer): boolean;
var len: cardinal;
begin
  if (AResCount < 0) then AResCount:= LUA_MULTRET;
  lua_getglobal(fLuaState, pAnsiChar(AName));                              // get function index
  PushArgs(aargs);                                                         // push parameters
  if (lua_pcall(fLuaState, length(aargs), AResCount, 0) = 0) then begin    // call function in "protected mode"
    if (AResType <> LUA_TNONE) then begin
      result:= (lua_type(fLuaState, -1) = AResType);
      if not result and (AResCount > 0) then lua_pop(fLuaState, AResCount);// cleanup stack if unexpected type returned
    end else result:= true;
  end else begin
    len:= 0;
    SetString(error, lua_tolstring(fLuaState, -1, len), len);
    lua_pop(fLuaState, 1);
    result:= false;
  end;
end;

function TLuaContext.ExecuteSafe(const AScript: ansistring; AResCount: integer; var error: ansistring): boolean;
var len: cardinal;
begin
  result:= (luaL_loadstring(fLuaState, pAnsiChar(AScript)) = 0);
  if result then begin
    result:= (lua_pcall(fLuaState, 0, AResCount, 0) = 0);
    if not result then begin
      len:= 0;
      SetString(error, lua_tolstring(fLuaState, -1, len), len);
      lua_pop(fLuaState, 1);
      result:= false;
    end;
  end else error:= 'Script loading failed';
end;

procedure TLuaContext.CleanUp(ACount: integer);
begin lua_pop(fLuaState, ACount); end;

procedure TLuaContext.SetGlobal(AIndex: integer; const AName: ansistring);
begin
  lua_pushvalue(fLuaState, AIndex);
  lua_setglobal(fLuaState, pAnsiChar(AName));
end;

procedure TLuaContext.ResetGlobal(const AName: ansistring);
begin
  lua_pushnil(fLuaState);
  lua_setglobal(fLuaState, pAnsiChar(AName));
end;

end.

function tSomeLuaClass.OnQuote(LuaState: TLuaState): Integer;
var classcode, seccode : ansistring;
  procedure dumptable(acontext: tLuaContext; atable: tLuaTable; const aparamname: ansistring);
  var rowtbl : tLuaTable;
  begin
    with TLuaTable.create(acontext, atable, aparamname) do try
      if FindFirst then try
        repeat
          if assigned(CurrentField) then begin
            rowtbl:= CurrentField.AsTable;
            if assigned(rowtbl) then 
              log('%s  price: %s qty: %s', [aparamname, rowtbl['price'].AsString, rowtbl['quantity'].AsString]);
          end;
        until not FindNext;
      finally FindClose; end;
    finally free; end;
  end;
begin
  with tLuaContext.create(LuaState) do try
    classcode := Stack[1].AsString;
    seccode   := Stack[2].AsString;
    log('OnQuote: Class: %s Code: %s', [classcode, seccode]);
    if Call('getQuoteLevel2', [classcode, seccode], 1, LUA_TTABLE) then try
      with Stack[-1].AsTable do begin
        if (FieldByName['bid_count'].AsInteger > 0) then
          dumptable(CurrentContext, CurrentTable, 'bid');
        if (FieldByName['offer_count'].AsInteger > 0) then
          dumptable(CurrentContext, CurrentTable, 'offer');
      end;
    finally CleanUp(1); end;
  finally free; end;
  result:= 0;
end;

luaL_openlib(L, PChar('SimpleDelphiLua'), @ls_lib, 0);
lua_pop(L, 1);

lua_newtable(L);
luaL_setfuncs(L, @ls_lib, 0);
lua_pushvalue(L,-1);
lua_setglobal(L, 'SimpleDelphiLua');