{
    This file is part of Chentrah,
    Copyright (C) 2004-2014 Anton Rzheshevski (chebmaster@mail.ru).

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see http://www.gnu.org/licenses/

 **********************************************************************

    This file contains the main unit for the game modules.

 **********************************************************************}

{$include mo_globaldefs.h}


{$ifdef unix}
  { define extdecl := cdecl }
{$else}
  { define extdecl := stdcall }
{$endif}


unit mo_hub;

interface
uses
  SysUtils,
  Classes,
  typinfo,
  IniFiles
  {$ifdef unix}
   , variants
   , dl
  {$else}
   , windows
  {$endif}
   , md5
  {$ifdef cpu32}
   , chelinfo
  {$else}
    {$ifndef buildmein}{$fatal Targets other than Win32 must only use builtin module}{$endif}
   ,lineinfo
  {$endif}

  ;


  {$include un_typedefs.h}
  
   procedure GrandInitialize(p: PMotherState; m,n,b: integer; logparams: array of const; sspl: integer);

  {$include un_texsages.h}

   MI_CORE_MIDs_END
   //custom message IDs go here
  );

  {$include un_gl.h} //opengl header

  {$ifdef mo_uses_openal}
    { Normally, the game modules do not interact with OpenAL at all.
        The sound is rendered using FBO + GLSL (0.1 seconds worth pre-render)
        then passed to the mother module for buffering and output.  }
    {$include un_al.h}
  {$endif}
  
  {$ifdef notlaz} { A chunk of code blocked from the Lazarus IDE
     to avoid confusing its code tools}
    {$include mo_fpc_pl_chk.h} //checks if sizeof(pointer) = sizeof(dword)
  {$endif}

//  {$include un_interface.h}

  {$include un_unicode.h}
  
  {$include mo_gtypes.inc}

type
  TRegisterProc = procedure(n: integer; var p: pointer);
                                      {$ifdef notlaz}cdecl;{$endif}

  EMoDying = class(Exception);
  Tprocedure = procedure; cdecl;
  TTryWrapperProcedure = procedure(p: pointer); cdecl;

var
  MotherState: PMotherState;
  SessionSpaceLimit: integer = 1;
  Config: TIniFile = nil;
  
  {$define header}
    {$include mo_exported_func.h}
  {$undef header}

  function PervertedFormat(U: WideString; P: array of const): WideString;
  function MsgFormat(M: TMessageId; Param: array of const): WideString;
  function MsgRaw(M: TMessageId): WideString;

  function HashToString(phash: pbyte): ansistring;

  function RuEn(Ru, En: WideString): WideString;
  function StrOrUndefined(U: WideString): WideString;

  function PCharToString(P: PAnsiChar): AnsiString;
  function PWideCharToWideString(P: PWideChar): WideString;
  function VarRecToWide(V: TVarRec): WideString;

  Procedure Die(YellID :TMessageID; Param: array of const); overload;
  Procedure Die(AnsiYell: AnsiString); overload;
  Procedure Die(AnsiYell: AnsiString; param: array of const); overload;
  Procedure Die(YellID :TMessageID); overload;
  Procedure Die(u: WideString; Param: array of const);  overload;
  Procedure Die(u: WideString);  overload;
  Procedure Die(r,e: WideString);  overload;
  Procedure DieBaka(u: AnsiString);
  Procedure DieSilently;

  procedure DieBySEhHack;
  function SehHackTellExceptionAddress(a: dword): WideString;


  Procedure AddLog(U: WideString); overload;
  Procedure AddLog(S: AnsiString); overload;
  Procedure AddLog(mID: TMessageID); overload;
  Procedure AddLog(mID: TMessageID; Param: array of const); overload;
  Procedure AddLog(U: WideString; Param: array of const); overload;
  Procedure AddLog(S: Ansistring; Param: array of const); overload;
  
  procedure SetConfigInt (section, id: AnsiString; Value: integer);
  function GetConfigInt (section, id: AnsiString): integer;
  
  function VersionToStr(major, minor, build: integer): AnsiString;
  function TellException(E: Exception): WideString;
  function ExpExpAddress(addr: pointer): WideString;
  function SehNameByCode(c: Dword): WideString;
  function ExplainCallStack(steps_to_ignore: integer; max_steps: integer = 9999): WideString;
  function ShortExpAddr(addr: pointer): WideString;

  function ParseHotKeyString(s: AnsiString): TKeySetArray;
  function GetOneHotKeyName(var s: TKeySet): WideString;
  function HotKeyStringDescription(var def: TKeySetArray): WideString;

  operator = (a, u: TResourceHash) b: System.boolean;
  
//Exception handling:
//  procedure TryWrap(p: Tprocedure); cdecl;
  procedure AfterEfCheck; cdecl;
  procedure MySafeCallErrorProc(error : HResult; addr : pointer);
  var
    OldSafeCallErrorProc: TSafeCallErrorProc = nil;
    SafeCallExceptionCaught: boolean = false;

//OpenGL:
  procedure InitGLProcAddresses(Load2: boolean);
  procedure SwitchToFixedPipeline;

//OpenAL:
  {$ifdef mo_uses_openal} //normally, the game modules do NOT use OpenAL.
   procedure InitALProcAddresses;
  {$endif}
  
//Timer
{$ifdef windows}
  //function Now(): TDateTime; //more precise version, with real resolution 1 ms
{$endif}
//  procedure Sleep(miliseconds: float);

  procedure PlaySound(wawfilename: ansistring);
const
  MAX_STACK_FRAMES_DUMP = 15;
  
implementation

uses
  chepersy, mo_threads;

  {$define impl}
  
  {$include un_gl.inc}

  {$include un_talesteller.inc}

  {$include mo_hub_1.inc}

  {$include mo_hub_die.inc}

  {$include un_unicode.inc}
  
  {$include mo_timer.inc}

  {$ifdef windows}
    {$include un_errmode.inc}
  {$endif}

  var
    dwarf: pointer;
    dwarfsize: integer;  //debugging line info extracted from the dll itself



  procedure GrandInitialize(p: PMotherState; m,n,b: integer; logparams: array of const; sspl: integer);
  var
  {$ifdef fpc}
    Mm: TMemoryManager;
  {$endif}  
    dwlname: string;
  begin
    MotherState:= p;
    SessionSpaceLimit:= sspl;
   {$ifdef windows}
    //БЯКА! Устаревшая. winwidestringalloc:= false; //WideString becomes COM - incompatible but works faster
   {$endif}
//byte(nil^):=0;
   {$ifdef fpc}
{     GetMemoryManager(Mm);
     Mm.NeedLock:=false;   //does it help?.. I do not use any threads...
     SetMemoryManager(Mm);
}
   {$endif}

    DecimalSeparator:= '.';

    InitUnicode;
    
    InitTimer;

    {$include mo_exported_func.inc}

    try
      _ValidateVersion(m, n, b); AfterEfCheck;
      _ValidateTypesets(ord(MI_CORE_MIDs_END), 0); AfterEfCheck;
      _ValidateTypesets(ord(Re_OnUnload){Re_Stub)}, 1); AfterEfCheck;
//      _ValidateTypesets(sizeof(TiCharArray), 2); AfterEfCheck;
      _ValidateTypesetsLe('TOsType', ord(MotherState^.OS), ord(high(TOSType))); AfterEfCheck;
      _ValidateTypesetsLe('TMotherState', sizeof(TMotherState), MotherState^.dwSize); AfterEfCheck;

      AddLog(MI_VERSION_INFO, logparams);
      
      {$ifdef cpu32}
        SetLength(LineInfoPaths, 1);
        LineInfoPaths[0]:= PCharToString(MotherState^.DebugInfopath);
        if true //MotherState^.DeveloperMode
        then begin
        //  AddLog(RuEn('Загрузка информации для самоотладки...','Loading the self-debugging info...'));
          if not InitLineInfo(nil) then Die(MI_DEBUG_INFO_NOT_FOUND, [LineInfoError]);
  {        if not InitLineInfo(nil)
              then Die(MI_ERROR_PROGRAMMER_NO_BAKA, [RuEn(
                 'Информация о номерах строк в формате dwarf 2 не найдена.'#10#13
                +'  (' + LineInfoError + ')'#10#13
                +' Убедитесь, что модуль был откомпилирован с ключом -gw.',
                 'The line number info in dwarf 2 format not found'#10#13
                +'  (' + LineInfoError + ').'#10#13
                +' Make sure the module is compiled with the -gw key.')]);}
        end;
      {$endif}
      {$ifdef windows}
        if MotherState^.DebugMode then AddLog('Error Mode = %0', [IntToHex(clGetErrorMode(), 1) + 'h']);
        clSetErrorMode(SEM_NOGPFAULTERRORBOX or SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX);
        if MotherState^.DebugMode then AddLog('Error Mode = %0', [IntToHex(clGetErrorMode(), 1) + 'h']);
      {$endif}

     { OldSafeCallErrorProc:= system.SafeCallErrorProc;
      system.SafeCallErrorProc:= @MySafecallErrorProc;
     }
      ClassesRegistrationStart;

      {$include mo_gtypes.inc}

      if ((MotherState^.OGLVersionHi < 2)
        or ((MotherState^.OGLVersionHi = 2) and (MotherState^.OGLVersionMed < 0)))
      and MotherState^.ModuleRequiresOpenGL2
        then Die(MI_OPENGL_VERSION_TOO_LOW,
                  [2,
                   0,
                   MsgRaw(MI_HINT_OPENGLTOOLOW),
                   MotherState^.OGLVersionString,
                   MotherState^.OGLRenderer,
                   MotherState^.OGLVendor]);

      InitGLProcAddresses(MotherState^.ModuleRequiresOpenGL2);
      {$ifdef mo_uses_openal}
        InitALProcAddresses;
      {$endif}

      if MotherState^.DebugMode then AddLog('Opening or creating config file... ');
      Config:= TIniFile.Create(string(MotherState^.HomePath) + 'conf/' + string(MotherState^.ModulePureName) + '.ini');
      if MotherState^.DebugMode then AddLogOk;
    except
      if MotherState^.NowDying or not (ExceptObject is Exception)
        then Die ('Крах в GrandInitialize()', 'Crashed in GrandInitialize()')
        else Die(RuEn(
                'Крах в GrandInitialize(): непойманное исключение,'#10#13'  %0',
                'Crashed in GrandInitialize() with an uncaught exception,'#10#13'  %0')
                , [TellException(ExceptObject as Exception)]);
    end;
  end;

  function MsgRaw(M: TMessageId): WideString;
  begin
    if M > MI_CORE_MIDs_END then begin

      //Ask the local message manager. NOT IMPLEMENTED YET.

    end
    else begin
      Result:=PWideCharToWideString(_HostMsg(M));
      AfterEfCheck;
    end;
  end;

  function MsgFormat(M: TMessageId; Param: array of const): WideString;
  begin
    Result:=PervertedFormat(MsgRaw(M), param);
  end;


  function PCharToString(P: PAnsiChar): AnsiString;
  var
    i: integer;
    p2: PAnsiChar;
  begin
    if not Assigned(p) then Result:=''
    else begin
      p2:=p;
      i:=0;
      While p2^ <> #0 do begin
        inc(p2);
        inc(i);
      end;
      SetLength(Result, i);
      Move(p^, Result[1], i);
    end;
  end;

  function PWideCharToWideString(P: PWideChar): WideString;
  var
    i: integer;
    p2: PWideChar;
  begin
    if not Assigned(p) then Result:=''
    else begin
      p2:=p;
      i:=0;
      While p2^ <> #0 do begin
        inc(p2);
        inc(i);
      end;
      SetLength(Result, i);
      Move(p^, Result[1], i*2);
    end;
  end;
  
  function HashToString(phash: pbyte): ansistring;
  var i: integer;
  begin
    Result:='';
    For i:=0 to 15 do begin
      Result:=Result + IntToHex(phash^, 2);
      if i < 15 then Result:=Result + '-';
      phash:=phash + 1;
    end;
  end;
  
  procedure SetConfigInt (section, id: AnsiString; Value: integer);
  begin
    _SetConfigInt(PAnsiChar(section), PAnsiChar(id), value);
  end;
  
  function GetConfigInt (section, id: AnsiString): integer;
  begin
    Result:=_GetConfigInt(PAnsiChar(section), PAnsiChar(id));
  end;

  function VersionToStr(major, minor, build: integer): AnsiString;
  begin
    Result:=format('%d.%.2d.%.4d' ,[Major, minor, build]);
  end;

  function RuEn(Ru, En: WideString): WideString;
  begin
    if MotherState^.IsRussian then Result:=Ru else Result:=En;
  end;


  
    procedure AfterEfCheck; cdecl;
  {$ifdef buildmein}
    begin end;
  {$else}
    var
      CallerAddr: pointer;
    begin
      asm
        mov eax, [ebp + 4] //read the caller's IP
        mov [CallerAddr], eax
      end;
      if MotherState^.NowDying then
        if MotherState^.DyingAfterTrueException
        then  Die(RuEn(
          'Исключение коллбэк-функции модуля-матки'#10#13'  принято шлюзом %0',
          'The mother module callback function exception'#10#13'  received at %0'),
          [ExpExpAddress(CallerAddr)])
        else DieSilently;
    end;
  {$endif}

  {$ifdef windows}
//Worked around in 2010 -- see cl_seh_hack.pp
(*  procedure TrybackWrapper(p: pointer); cdecl;
  begin
    {Backwrapper is called by the mother module's wrapper
      to filter out the game module's language exceptions
      that would confuse the mother module wrapper.
     The OS exceptions cannot be caught in a DLL
       (see bug #4605 at http://bugs.freepascal.org/view.php?id=4605 ),
       so they'll go straight throgh tis try  block
       to be caught by the mother module wrapper.  }
    try
      TProcedure(p)();
    except
      if not MotherState^.NowDying then begin
        _dyell:='';
        CheckForGenericDyingYells;
        if MotherState^.DyingAfterTrueException
          then _dyell:= PervertedFormat(RuEn('При вызове %0','During call to %0'),
                                          [ExpExpAddress(p)]) +#10#13#10#13 +  _dyell;
        _HostDyellW(PWideChar(_dyell));
        SetDying(yes);
      end;
    end;
  end; *)

{$endif}

(*
  procedure TryWrap(p: Tprocedure); cdecl;
  begin
    CgeTryWrap(@TrybackWrapper, @p);
    if MotherState^.NowDying and MotherState^.DyingAfterTrueException
      then Die(RuEn('При вызове %0',  'During call to %0'), [ExpExpAddress(@p)]);
  end;
  {$else}
  procedure TryWrap(p: Tprocedure); cdecl;
  begin
    try
      p
    except
      if not MotherState^.NowDying
        then Die(RuEn('При вызове %0', 'During call to %0'),  [ExpExpAddress(@p)]);
    end
  end;
  {$endif} *)

 // GET RID OF THIS OBSOLETE STUFF!  ***************************************************

 { procedure TryWrap(p: Tprocedure); cdecl;
  begin
    try
      p
    except
      if not MotherState^.NowDying
        then Die(RuEn('При вызове %0', 'During call to %0'),  [ExpExpAddress(@p)]);
    end
  end; }

operator = (a, u: TResourceHash) b: System.boolean;
begin
  b:= (a.Stamp = u.Stamp) and (a.DateTime = u.DateTime);
end;


function ParseHotKeyString(s: AnsiString): TKeySetArray;
var
  a, b: AnsiStringArray;
  v, u: AnsiString;
  i, j, n: integer;
  k: TKey;
  fuck: boolean;
begin
  Result:= nil;
  a:= Explode(',', s, true);
  for j:= 0 to High(a) do begin
    if a[j] = '' then begin
      if MotherState^.VerboseLog then AddLog('NOTICE: Empty position #%0 in the hotkey definition "%1"',[j, s]);
      continue;
    end;
    SetLength(Result, Length(Result) + 1);
    b:= Explode('+', a[j], true);
    for i:= 0 to high(b) do begin
      v:= UpperCase(b[i]);
      fuck:= true;
      for k in TKey do begin
        u:= uppercase(GetEnumName(typeinfo(TKey), ord(k)));
        if (v = u) or ('KEY_' + v = u) then begin
          Include(Result[High(Result)], k);
          fuck:= false;
          break;
        end;
      end;
      if fuck then begin
        Die(RuEn(
          '"%0" - нет такой клавиши.'#10#13'  (в строке настроек "%1")'#10#13'Все доступные значения перечислены в  файле'#10#13'  %2modules/chentrah/src/un_keys.h',
          'There is no such key as "%0"'#10#13'  (in config string "%1")'#10#13'All valid key names are listed in the file'#10#13'  %2modules/chentrah/src/un_keys.h'
          ),[v, s, MotherState^.InstallPath]);
       // Die(MI_INVALID_HOST_HOTKEY_NAME, [u, MotherState^.InstallPath]);
      end;
    end;
  end;
end;

function GetOneHotKeyName(var s: TKeySet): WideString;
var
  k: TKey;
  a: WideStringArray;
  w: WideString;
begin
  Result:='';
  for k in s do begin
    if MotherState^.IsRussian and (KeyNames[k, 0] <> '') then w:= KeyNames[k, 0]
    else begin
      if KeyNames[k, 1] <> ''
        then w:= KeyNames[k, 1]
        else w:= COPY(GetEnumName(typeinfo(TKey), ord(k)), 5, MaxInt);
    end;
    SetLength(a, Length(a) + 1);
    a[High(a)]:= w;
  end;
  Result:= Implode('+', a);
end;


function HotKeyStringDescription(var def: TKeySetArray): WideString;
var
  i: integer;
  w: WideStringArray;
begin
  if Length(def) < 2 then Exit(GetOneHotkeyName(def[0]));
  SetLength(w, Length(def));
  for i:= 0 to High(def) do w[i]:= GetOneHotkeyName(def[i]);
  Result:= Implode(RuEn(' или ', ' or '), w);
end;

end.


