{
    This file is part of chepersy
    Copyright (c) 2004-2008 by Anton Rzheshevski (chebmaster@mail.ru),

    See the file COPYING.CPS, included in this distribution,
    for details about the copyright.

    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.

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


  {$include mo_cps_scenario.inc}

{$ifdef fpc}
{ class function TObject.NewInstance : tobject;
  var
    p : pointer;
  begin
    getmem(p, InstanceSize);
    if p <> nil then
      InitInstance(p);
    NewInstance:=TObject(p);
  end;
 }
{  class function TManagedObject.NewInstance : tobject;
  var
    p : pointer;
  begin
    getmem(p, InstanceSize);//ToDo: replace with custom memory manager.
   // if p <> nil then
    InitInstance(p); //ToDo: replace with custom procedure.
    NewInstance:=TObject(p);
  end; }
{$endif}

  procedure TManagedObject.RegisterFields;
  begin
    ListFields(['CpsMask', @f_cpsmask, typeinfo(dword)]);
  end;


  procedure TManagedObject.AfterConstruction;
  begin
    //do nothing
  end;

  procedure TManagedObject.AfterLoading;
  begin
    //do nothing
  end;
  
  procedure TManagedObject.BeforeSaving;
  begin
    //do nothing
  end;

  function TManagedObject.Clone(): TManagedObject;
  begin
    Result:= CManagedObject(Self.ClassType).Generate;
    CloneRecord(pointer(Self), pointer(Result), Self.ClassIndex);
  end;

  constructor TManagedObject.Register;
  {
     To calculate the field offsets we need an instance first!
     Thus, this constructor: it creates a temporary instance
       and registers the fields. Called from RegClass() procedure.
  }
  begin
    Generate;
    RegBegin(Self);
    RegisterFields;
    RegEnd;
    //Free;
  end;

  constructor TManagedObject.Generate;
  {
     We neeed to avoid the usual initialization routines
     when we load the instance from a file.
     So here is a special constructor for this. It does nothing,
     not even calls AfterConstruction.
  }
  begin
  end;
  destructor TManagedObject.TechnicalDestroy;
  begin
    inherited Destroy;
  end;
  
  {stubs for the "class fields" implemented via fake virtual methods}
  {$ifdef oldhacky}
    procedure TManagedObject._MyClassIndex(); begin AddLog('a'); end;
      //not empty and different: to prevent the compiler from using the default
      //  "abstract field" handler.
    procedure TManagedObject._MyScenarioIndex(); begin AddLog('b'); end;
    procedure TManagedObject._MyFieldsList(); begin AddLog('c'); end;
  {$endif}

  {$ifndef fpc}
    procedure RemoveMemoryWriteProtection(addr: pointer);
    var
      MBI: MEMORY_BASIC_INFORMATION;
      stub: dword;
    begin
      if not IsBadWritePtr(addr, sizeof(pointer) * 5) then Exit;
      // that's an WinAPI function, but we don't need to worry
      // because there is no such thing as Delphi for Linux.
      
      if MotherState.VerboseLog then AddLog(
        'Class VMT is write-protected. Removing the protection at %0...',[addr]);
      if (VirtualQuery(addr, MBI, SizeOf(MBI)) <> SizeOf(MBI))
      or not VirtualProtect(MBI.BaseAddress, MBI.RegionSize, PAGE_EXECUTE_READWRITE, @stub)
        then Die(PervertedFormat(RuEn(
          'Не удалось получить права на запись в память по адресу %0.',
          'Failed to gain write access rights for memory at address %0.'), [addr]));
      if MotherState.VerboseLog then AddLog('Success. Gained write access for %1 bytes at %0.',
        [MBI.AllocationBase, MBI.RegionSize]);
    end;
  {$endif}

 {$ifdef delphiworkaround}
  procedure DumbDelphiSetMyFieldsList(C: TClass; F: TObject);
  begin
    aFieldsList[CHash(C)]:=TFieldsList(F);
  end;
 {$else}
  class procedure TManagedObject._SetMyFieldsList(F: TObject);//TFieldsList);
  begin
    {$ifdef oldhacky}
    TFieldsList(pointer(Cardinal(Self)+vmtMyFieldsList)^):= TFieldsList(F);
    {$else}
    aFieldsList[CHash(ClassType())]:=TFieldsList(F);
    {$endif}
  end;
 {$endif}

{$ifdef oldhacky}
  class function TManagedObject.FieldsList(): TObject;//TFieldsList;
  begin
    Result:=TFieldsList(pointer(Cardinal(Self)+vmtMyFieldsList)^)
  end;

  class function TManagedObject.ClassIndex(): integer;
  begin
    Result:=integer(pointer(Cardinal(Self)+vmtMyClassIndex)^);
  // {$ifdef safeloading}
    if Result = InvalidClassIndex then Result:= 0;
  // {$endif}
  end;
{$else}
  {$ifdef fpc}
  class function TManagedObject.ClassIndex(): integer;
  begin
    if not CFitsIndexArrays(ClassType()) then begin Result:=0; Exit end;
    Result:=aClassInd[CHash(ClassType())];
  end;
  {$endif}
{$endif}

  function GetClassIndex(C: TClass): integer;
  begin
    if not CFitsIndexArrays(C) then begin
      Result:=0;
//writeln('--------- Notfits, ',C.ClassName);
      Exit
    end;
    Result:=aClassInd[CHash(C)];
  end;

  procedure SetClassIndex(C: TClass; index: integer);
  begin
    MakeSureClassFitsIndexArrays(C);
    aClassInd[CHash(C)]:=index;
  end;
  
{$ifndef delphiworkaround}
  class procedure TManagedObject._RegisterMyIndex(index: integer);
  var p: pointer;
  begin
    {$ifdef oldhacky}
      p:=pointer(Cardinal(Self)+vmtMyClassIndex);
      {$ifndef fpc}
       RemoveMemoryWriteProtection(p);
      {$endif}
      integer(p^):= index;
    {$else}
      MakeSureClassFitsIndexArrays(ClassType());
      aClassInd[CHash(ClassType())]:=index;
    {$endif}
  end;
 {$endif}

 {$ifdef delphiworkaround}
  procedure DumbDelphiSetScenarioIndex(C:Tclass; index: integer);
  begin
    tScenarioIndex[GetClassIndex(C)]:= index;
  end;
 {$else}
  class procedure TManagedObject._SetScenarioIndex(index: integer);
  begin
    tScenarioIndex[
      {$ifdef oldhacky}
        longint(pointer(Cardinal(Self) + vmtMyClassIndex)^)
      {$else}
        aClassInd[CHash(ClassType())]
      {$endif}
                   ]:= index;
  end;
 {$endif}

