{
    This file is part of the Cheb's persistence system (Chepersy),
    Copyright (c) 2004-2008 by Anton Rzheshevski (chebmaster@mail.ru),
      and contains most of the persistency system source code.

    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.

 **********************************************************************}
{
 ToDo:
  - CRITICAL: Add all loaded scraped objects to the graveyard!
  - BROKEN: cant read previous versions' saves: Basket optimization (caching, header UIDs et cetera)

05.07.12: corrected tkWstring/tkUstring problem. Now works in Linux but requires fpc >= 2.4
}

{$ifdef go32v2}
  {$include chepersy.inc}
  //stupid DOS and its 8.3 name limit
{$else}
  {$include chepersy_defs.inc}
{$endif}

{$rangechecks off}
{$ifdef fpc} //in FreePascal
  {$codepage utf-8} //sets the source code code page
  {$ifopt C+} //if assertions are turned on...
    {$define safeloading} //..compile with all the safeguards included
  {$endif}
{$endif}

{$asmmode intel}

unit chepersy;

interface
  uses SysUtils, Classes, typinfo, math, md5
       {$ifdef go32v2}
         , fake_cse
       {$else}
         , syncobjs
       {$endif}
       {$ifdef cge}
         ,mo_hub //originally Chepersy is an integral part of Chentrah, aka Cheb's Game Engine (cge)
       {$endif}
       {$ifdef use_chelinfo}
         ,chelinfo //line info for FreePascal
       {$endif}

       ;

const
  ChepersyVersion = '0.9.00';
  ChepersyVersionMajor = 0;
  ChepersyVersionMinor = 9;
  ChepersyVersionSubVer = 0;

{Changelog 0.8.98 -> 0.9.00:
  1. stream format updated, with header md5 now saved before the header
  2. header and scenario caching, based on the md5 checksums. For each distinct checksum, header is loaded and parsed only once.
  3. support for headerless streams
  1. (currently still stubs) fixed32 type and its converters for CGE.
  2. TManagedObject.Clone()
  3. Fixed the bug with doubling the field lists in the log.
  4. TManagedObject.Resurrect()
  5. new optional parameter OutputList in CpsLoad()
  6. Scrape made virtual

}

{$ifndef fpc}
  {$ifndef oldhacky}
    {$define delphiworkaround}
  {$endif}
{$endif}
const
  //bits of CpsMask reserved for the garbage collector. Do *NOT* use.
  CPS_SCRAPED_MASK_BIT = 31;
  CPS_ORPHANED_MASK_BIT = 30;
  CPS_SCRAPED_MASK = $80000000;
  CPS_ORPHANED_MASK = $40000000;
  CPS_RESERVED_MASK = CPS_SCRAPED_MASK or CPS_ORPHANED_MASK;


type
  TManagedObject = class(TObject)
  protected
    CpsIndex: longint; // Do not touch it. Period.
    f_cpsmask: dword; //used to filter objects at saving. Gets saved.
  published
  {$ifdef oldhacky}
    { These aren't methods. These are a dirty trick to store integer values
        directly in the class VMT.
        (Why the hell aren't there such things as "class fields"?..)
      Them being not abstract is a candy for compiler crying about
             "constructing a class with abstract methods".}
    procedure _MyClassIndex(); virtual;
  {$endif}
  protected
   {$ifndef delphiworkaround}
     class function ClassIndex(): integer;
     class procedure _RegisterMyIndex(index: integer);
     class procedure _SetScenarioIndex(index: integer);
     class procedure _SetMyFieldsList(F: TObject);//TFieldsList);
   {$endif}
    constructor Register;
   {$ifdef fpc}
  //  class function NewInstance() : tobject; override;
   {$endif}
    procedure AfterConstruction(); override;
    function _GetScraped: longbool;
    {$ifdef safeloading}
      procedure _SetCpsMask(w: dword);
    {$endif}
  public
    constructor Generate;
    destructor TechnicalDestroy;
    destructor Destroy; override;

    // **** Truly public stuff. For the users of Chepersy.

    // Necessary. Needs to call all an inherited method first (see the manual)
    procedure RegisterFields; virtual;

    //      Allow to perform special actions on these two events
    procedure BeforeSaving(); virtual;
    procedure AfterLoading(); virtual; //is called after *all* the objects are loaded.

    //cloning the class instance;
    function Clone(): TManagedObject; virtual; //everything gets cloned, even the skipped fields -- except fields of type Pointer.

    //managed object functions (new in 0.8.99)
    procedure Scrape; virtual; //marks self as scraped and adds self to the garbage collector graveyard. To be used instead of Free.
    procedure Resurrect; //clears the Scraped state and removes the object from graveyard. To be used in the rollback manager.
    property Scraped: longbool read _GetScraped;
    property CpsMask: dword read f_cpsmask
      {$ifdef safeloading}
        write _SetCpsMask;
      {$else}
        write f_cpsmask;
      {$endif}
  end;

  CManagedObject = class of TManagedObject;

  TArrayOfManagedObjects = array of TManagedObject;
  T2DArrayOfManagedObjects = array of TArrayOfManagedObjects;


const
  ExtraInfoOffset = 8; { offset of the first field in TManagedObject.
    First, there is the metaclass pointer (derived from TObject) - 4 bytes,
    then there is the CpsIndex field - again, 4 bytes. 8 in total.}

var
  {When set to true, TManagedObject's Destroy always calls Scrape,
    thus handing the object to the garbage collector.
   Otherwise it destroys objects normally, except those marked as scraped}
  CpsFullManagement: longbool = {$ifdef safeloading} true {$else} false {$endif};

  CpsCriticalSection, CpsGarbageCollectorCriticalSection: TCriticalSection;

  { in FPC these are always utf-8 (see the Utf8Encode/Utf8Decode functions in SysUtils),
    in Delphi it's the result of assigning WideString to AnsiString.}
  CpsParserWarnings,
  CpsLog,
  CpsError: TStringList;
  
  CpsValid: boolean = false; //set to true when Chepersy is initialized
  CpsFinalized: boolean = false; //set to true when classes registration is finished

{$ifndef cge}
  CpsUseWriteLnInAddLog: boolean = false; //used for debugging and in the test example
{$endif}

  CpsStream: TStream = nil;

type
  TChepersyDatabaseHeader = class; //forward declaration
var
  CpsDatabaseHeaders: array of TChepersyDatabaseHeader;

// **************** SAVING / LOADING ROUTINES **********************



  function CpsStore(
    o: TManagedObject;
    {$ifdef cge}m: TMessageId;{$endif}
    Target: TStream;
    XorMask: dword = $ffffffff;
    AndMask: dword = $ffffffff;
    Headerless: boolean = false
  ): longbool;

  function CpsLoad(
    {$ifdef cge}m: TMessageId;{$endif}
    Source: TStream;
    var OutputList: TArrayOfManagedObjects = nil;
    DatabaseHeader: TChepersyDatabaseHeader = nil //if set, treats the stream as headerless!
  ): TManagedObject;



    
    //added in 0.8.2
  function ExportChepersyClassList(): TStringList; //class names per index


// ************** GRAPH WALKING FUNCTIONS **************************
  type
    TcustomWalkProc = procedure(o: TManagedObject);
  
  function CpsMarkupGraph(o: TManagedObject; SetMaskBits, ClearMaskBits: dword): longbool;
  function CpsWalkGraph(o: TManagedObject; proc: TcustomWalkProc): longbool;

//  function CpsGetNameHash(name: string): longint;
//  function CpsGetField(NameHash: integer): Variant;


  {$ifdef cge}
    {$include mo_typedefs.h}
  {$else}
    //simplified replacements for the parts of Cheb's Game Engine
    type
      float = single;
      boolean = longbool;
      {$ifndef fpc}
        //delphi
        winbool = longbool;
        dword = cardinal;
      {$endif}
     const
        Yes=True;
      No=False;
  {$ifdef chepersy_align_4}
    AlignGranularity = 4;
    BasicUnitSize = 4;
  {$else}
    {$ifdef chepersy_align_8}
      {$fatal 64-bit alignment support not implemented yet!}
      //AlignGranularity = 8;
      //BasicUnitSize = 4;
    {$endif}
  {$endif}

    type
      TMotherState = record
        VerboseLog,
        IsRussian: boolean; //controls the log and error messages
      end;
    PMotherState = ^TMotherState;
    var
      _MotherState: TMotherState;
      MotherState: PMotherState = @_MotherState;
    {$include mo_cps_tmid_public.h}
  {$endif}

type
    {$include mo_cps_dyna.h}

type
  TCpsGcAutoRun = record
    Enabled: boolean;
    NumObjectsToActivate,
    NumObjectsToIgnoreTimeConstraint: integer;
    TimeConstraint: int64;
  end;

  TGarbageCollector = class
  protected
    f_Graveyard: TAOMO;
    f_previousCollectInterrupted: boolean;
    f_prevcollectind: integer;
  public
    {This counter increases with each orphaned object destroyed.
       reset it to zero if you need.}
    ObjectsCollected: int64;
    ThreadSafe: boolean; // false by default
    AutoRun: TCpsGcAutorun;

    {root used for walking the graph. When Nil, Collect()
      does only destroy objects marked prior as orphaned.
      Autorun doesn't work too.}
    GraphRoot: TManagedObject;
    constructor Create;

    {The Collect function will interrupt its work if it takes more
      CPU clock cycles than TimeConstraint, as per RDTSC command.
      Obviously, walking the graph is most often required,
      which could *not* be interrupted, but the actual
      deleting of objects and emptying the graveyard could,
      so the next time Collect is called it will clean up the
      previously found orphaned objects first, then walk the
      graph again if there is time left.}
    procedure Collect(TimeConstraint: int64 = 0); virtual;
    procedure Add(o: TManagedObject); //doesn't do anything to its scraped state!
    function GraveyardCount: integer; virtual;
  end;

var
  GarbageCollector: TGarbageCollector;



const
  SignatureString: WideString = 'Chepersy Database File';

type
  TFieldOperation = (fio_Load, fio_Save, fio_Skip, fio_Walk);
//Removed in 0.8.96  TCustomClassProc = procedure (var o: TObject; op: TFieldOperation);

// ****************** INIT PROCEDURES ********************************
  procedure ClassesRegistrationStart;
  procedure ClassesRegistrationEnd;

{   RegClass must be called for each descendant of TManagedObject.
      The best place to do it is the initialization procedure of the module.
      Automatically calls the "Register" constructor of a class.
}
  procedure RegClass(C: CManagedObject);

  // custom classes (any other than the TManagedObject descendants)
 // introduced in 0.8.95, removed in 0.8.96 due to various problems
 // procedure RegCustomClass(C: TClass; proc: TCustomClassProc);

  //use if your custom class contains any TManagedObjects
//removed in 0.8.96  procedure CpsProcessObject(var o: TObject; op: TFieldOperation);

// ************** NEW FUNCTIONS IN v0.9 TOTALLY REPLACING THE OLD API *********

  procedure ListFields(v: array of const);

  //class or enum
  procedure RegType(info: PTypeInfo);  overload;

  //dynamic array or set
  procedure RegType(info, base: PTypeInfo);  overload;
  
  //record
  procedure RegType(tname: string; Size: longint; v: array of const);overload;
{$ifdef fpc}
  procedure RegType(info: PTypeInfo; Size: longint; v: array of const); overload;
{$endif}

  //enumerated array
  procedure RegType(Info, BaseType, IndEnum: PTypeInfo);  overload;
  procedure RegType(Info: PTypeInfo; BaseType: string; IndEnum: PTypeInfo);overload;
  procedure RegType(Info, BaseType: string; IndEnum: PTypeInfo);overload;


  //static array
  procedure RegType(tname: string; base: PTypeInfo; lohi: array of const); overload;
  procedure RegType(tname, base: string; lohi: array of const); overload;
{$ifdef fpc}
  procedure RegType(info, base: PTypeInfo; lohi: array of const); overload;
  procedure RegType(info: PTypeInfo; base: string; lohi: array of const);  overload;
{$endif}

  //dynamic array
  procedure RegType(info: PTypeInfo; n: integer; base: PTypeInfo); overload;
  procedure RegType(info: PTypeInfo; n: integer; base: string);  overload;
  procedure RegType(info: PTypeInfo; base: string);  overload;

type
  TArrayofDword = array of dword;
  T2dArrayOfDword = array of array of dword;

  TArrayOfLongint = array of integer;
  T2dArrayOfLongint = array of TArrayOfLongint;
  
  TArrayofByte = array of byte;

 {$ifdef fpc}
  //Delphi has no such type.
  //A fake info is added to the registry to emulate it
  // (sorry, but just defining it as a mirror of int64 is not possible).
  TArrayofQword = array of Qword;
  T2dArrayOfQword = array of array of Qword;
 {$endif}

  TArrayOfint64 = array of int64;
  T2dArrayOfint64 = array of int64;
  

const
  CPS_POINTER = 7777;
  CPS_METACLASS = 7778;
  CPS_MAX_MULTIDIM_ARRAY = 25; //over this, you cannot register
  


{   This bunny registers array types.
      Due to lack of RTTI it goes via string IDs.}
{DEPRECATED} procedure ObsoleteRegTypeStaticArray(StringID: ansistring; BaseType: PTypeInfo; Size: Integer);

  {$ifdef cge}
    {$include mo_fixedpoint.h}
  {$endif}

type

  TFieldInfo = packed record
    offset,
    name,
    HasPP,
    Tind: longint; // the index of its type in the global type registry
    Skip: LongBool;
    RFind, // the number of this field in the global class registry

    //this one is used only at loading,
    //  in the file it is always zero:
    NewTind: longint;

    Reserved2: longint;
  end;
  PFieldInfo = ^TFieldInfo;
  TFieldDesc = record
    Size: longint;
    Field: array of TFieldInfo;
  end;


    TCustomTypeProcessingProc = procedure
          (PField: pointer; Op: TFieldOperation; Tind: longint); register;
    TCustomConverterProc = procedure
          (PField: pointer; Tind1, Tind2: longint); register;


  TFieldKind =
  //do NOT change the order, or the data files will become incompatible!
  (fk_notsupported, fk_binary, fk_integer, fk_float, fk_string, fk_set, fk_enum, fk_Class,
        fk_Complex, //not used anymore
    fk_8bit_string, fk_CustomClass, fk_Array, fk_enumInd_Array, fk_record, fk_dynamic_array, fk_packed_record, fk_static_array,
        fk_09_custom_class, //not used anymore
    fk_metaclass);



    TTypeRecord = record
      name: integer;
      size: integer;
      Info: PTypeInfo;
      Data: PTypeData;
      Proc: TCustomTypeProcessingProc;
  //    CustomClassProc: TCustomClassProc;
      ClassName: longint;
      _class: CManagedObject;
      Kind: TFieldKind;
      BaseTypeInd,
      IndEnumInd,
      Length: integer;
      IsEnumIndArray: boolean;
      IsRecord: boolean;
     // RecFieldName, RecFieldTInd: array of integer;
      SetLen,
      DynArrayLevel,
      DynArrayBaseInd: integer;
      IsArrayOfTTP: boolean; // is some level array of truly persistent or its descendants
      StaticLow: integer;
      RecordInd: integer;
    end;

  {$include mo_cps_dyna_1.h}


type
  TStreamSignature = packed record
    sign: array [0..2] of AnsiChar;
    ver: AnsiChar;
  end;

{$ifdef support08x}
  TOldCGEHeader = packed record
    case integer of
      0: (
        stub0, StreamSize: int64;
        glUintSize,
        glFloatSize,
        PointerSize,
        AlignGranularity: shortint);
      1: (Stub1: packed array[0..31 - 1] of DWORD;) //128 bytes size
  end;
{$endif}

  TNameSpace = class (TAOS)
  public
    Alias: array of integer;
    function Ind(i_s: string; AssumedInd: integer): integer;
    function Translate(RegNS: TNameSpace): TAOI;
    function Add (a_s: string): integer; overload; override;
    function Add(s1, s2: string): integer; overload;
  end;


// Alas, no classes could allow it perform two reading/writion operations at once. Nothing coult. :(
  TChepersyDatabaseHeader = class
  protected
    class var C: record
      Sig: TStreamSignature;
     {$ifdef support08x}
      Head: TOldCGEHeader;
     {$endif}
      Read: boolean;
      Opened: boolean;
      FN: AnsiString;
    end;
    class procedure CgeFilePropByType(t: AnsiChar; name: WideString);
    procedure WriteSignatureToStream;
    class procedure ReadSignatureFromStream (var version: AnsiChar);
    {new in 0.9.0. Determines the stream format at reading:
      0 for the old one (v0.7x..0.8.x),
      1 for the new one (0.9.0 and up).
      At writing the format is always 1.}
    class var
      StreamVersion: integer;
      VersionOfLoadedFile: char;
      ReadChecksum,
      CurrentVersionChecksum: TMd5Digest;
      ReadHeaderSize,
      CurrentVersionHeaderSize: dword;

    constructor CreateForLoad; //uses global variable CpsStream

  public
    Checksum: TMd5Digest;
    HeaderSize: dword;
    //For reading. Reads stream header to determine checksum.
    //Then either calls the constructor or returns a pre-existing class instance from  CpsDatabaseHeaders array.
    class function GetInstance: TChepersyDatabaseHeader;  //uses global variable CpsStream



    constructor CreateDefaultInstance;

    procedure ReadHeader;
    procedure WriteHeader;
    procedure SkipHeader;

    procedure Parse();

    //slapdash converting from a procedural/global variable mess to classes
    var
      B_Enums, EnumConvTable: T2DAOI;
      B_Fields: TFieldInfos;
      B_NameSpace: TNameSpace;
      NameTT,
      NaToT,
      TNames,
      TSizes,
      TKinds,
      B_TBaseInds,
      B_TIndInds,
      CNames,
      B_RecBTinds,
      B_StaticLow: TAOI;
      B_ToGtind,
      B_FromGtind,
      B_Lrecind: array of integer;
      B_RecKinds: array of TFieldKind;
      TypeChanged: array of boolean;
      CAncestorNames: T2DAOI;
      CNums: array of integer; //class indices in the registrator lists.
      EnumIdentic: array of boolean;
      B_Classes: array of CManagedObject;
      b_ScenarioIndex: array of integer;
  end;

  
implementation


{$include mo_cps_body.inc}


end.
