{
    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.

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

(*

//Procedure template:

procedure RP_ (PField: pointer; OP: TFieldOperation;  Tind: integer); register;
begin
  case op of
    fio_Load:
    fio_Save:
    fio_Skip:
    fio_Walk:
  end;
end;

//Since v0.9, when loading tind receives the local type index, not the global one
*)

procedure RP_Pointer (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  //Pointer in Chentrah isn't a saveable type...
  case op of
    fio_Save: Die(MI_ERROR_PROGRAMMER_NO_BAKA, [
      RuEn('Попытка сохранить поле типа указатель - упущено при парсинге.',
           'Attempt to save a pointer type field - slipped the parsing.')]);
    fio_Skip, fio_Walk:; //do nothing

    // The second role, as the Type #0, is
    //  to notify about the unloadable fields.
    fio_Load: Die(RuEn(
      'Встречено поле неизвестного неразруливаемого типа.',
      'Found a field of an unknown unresolvable type.'));
  end;
end;

procedure RP_DieInAgony (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  //Used to die on the unknown unresolvable types
  case op of
    fio_Load: Die(RuEn(
      'Встречено поле неизвестного неразруливаемого типа.',
      'Found a field of an unknown unresolvable type.'));
    fio_Save, fio_Skip, fio_Walk: //do nothing;
  end;
end;


procedure RP_Dyna (PField: pointer; OP: TFieldOperation; Tind: integer); register;
var
  o: TDyna;
begin
  case op of
    fio_Load: TDyna(PField^):=ReadDyna();
    fio_Save: WriteDyna(TDyna(PField^));
    fio_Skip: begin
                o:=ReadDyna(); //load it and destroy it. The fate is cruel.
                o.Free;
              end;
    fio_Walk: WalkDyna(TDyna(PField^));
  end;
end;

(*
procedure RP_CustomClass (PField: pointer; OP: TFieldOperation; Tind: integer); register;
var
  p: TCustomClassProc;
  o: TObject;
  i: longint;
  procedure ValidateIt(o: TObject);
  begin
    if ReadInt() <> 777 then Die(RuEn(
      'Пользовательская процедура класса %0'#10#13'  прочитала из потока неверное количество данных.',
      'The custom processing procedure of class %0'#10#13'  read a wrong amount of data from the stream.'),
      [o.ClassName]);
  end;
  procedure SafeCallCCProc(var oo: TObject; ptind: integer);
  begin
    try
      p:= Types[ptind].CustomClassProc;
//writeln('ooooo  ', IntToHex(cardinal(pointer(@p)),8));
      p(oo, OP);
    except
      Die(RuEn(
        'Крах пользовательской процедуры класса %0',
        'Error in custom processing procedure of class %0.'),
        [NameSpace[Types[ptind].Name]]);
    end;
  end;
  procedure CheckTindValid(cv: longint);
  begin
    if B_ToGtind[cv] <=0 then
      Die(RuEn(
        'Неизвестный пользовательский класс %0',
        'Unknown custom class %0'),
        [B_NameSpace[CNames[tind]]]);
  end;
begin
  case op of
    fio_Load: begin
      i:= ReadInt();
//writeln(',,,,,, ', i);//, '  ', FieldKindToStr(Types[Records[i]].Kind), '  ', ClassNameSpace[i]);
      if i=0
        then pointer(pfield^):= nil
        else begin
          if i > 0 then begin
            i:= B_RecBTinds[i];
            CheckTindValid(i);
            SafeCallCCProc(TObject(PField^), B_ToGtind[i]);
            ValidateIt(TObject(PField^));
          end
          else ReadPersistent(TManagedObject(PField^));
        end;
    end;
    fio_Skip: begin
      i:= ReadInt();
      if i > 0 then begin
        i:= B_RecBTinds[i];
        CheckTindValid(i);
        SafeCallCCProc(o, B_ToGtind[i]);
        MemoryLeakSuspected:= true;
        SuspectsAdd(o);
        ValidateIt(o);
      end
      else
        if i < 0 then SkipPersistent;
    end;
    fio_Save: begin
      if not Assigned(pointer(PField^)) then WriteInt(0)
      else begin
        i:= GetClassIndex(TObject(PField^).ClassType);
        if i = 0 then Die(RuEn(
          'Класс %0 не зарегистрирован!',
          'Class %0 is not registered!'),
          [string(TObject(PField^).ClassName)]);
//writeln(',,,,,, ', i, '  ', FieldKindToStr(Types[Records[i]].Kind), '  ', ClassNameSpace[i]);
        if Types[Records[i]].Kind <> fk_class then begin
          WriteInt(i);
          SafeCallCCProc(TObject(PField^), Records[i]);
          WriteInt(777);
        end
        else begin
          WriteInt(-1);
          WritePersistent(TManagedObject(PField^));
        end;
      end;
    end;
    fio_Walk: begin
      if Assigned(pointer(PField^)) then begin
        i:= GetClassIndex(TObject(PField^).ClassType);
        if i = 0 then Die(RuEn(
          'Класс %0 не зарегистрирован! (ожидался %1)!',
          'Class %0 is not registered! (expected %1)'),
          [string(TObject(PField^).ClassName), TypeNameSpace[tind]]);
        if Types[Records[i]].Kind = fk_class
          then WalkPersistent(TManagedObject(PField^))
          else SafeCallCCProc(TObject(PField^), Records[i]);
      end;
    end;
  else
  end;
end;

  procedure CpsProcessObject(var o: TObject; op: TFieldOperation);
  begin
    RP_CustomClass(@o, op, 0);
  end;

*)

procedure RP_Metaclass (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  case op of
    fio_Load: begin
      dword(PField^):= {$ifdef fpc} CpsStream.{$endif} ReadDword();
      if Assigned(pointer(PField^)) then begin
         {$ifdef safeloading}
          if dword(PField^) >= Length(DH.Cnums) then DieInvalidContainer(RuEn('Данные запороты: индекс класса - за пределами!','Data corrupt: class index out of bounds!'));
         {$endif}
         CManagedObject(PField^):= DH.B_Classes[dword(PField^)];
      end;
    end;
    fio_Save:
      if not Assigned(pointer(pfield^)) then WriteInt(0)
      else WriteInt(
          {$ifdef delphiworkaround}
            GetClassIndex(CTrulyPersistent(PField^))
          {$else}
            CManagedObject(PField^).ClassIndex
          {$endif} );
    fio_Skip: {$ifdef fpc} CpsStream.{$endif} ReadDword; //SkipDword;
    fio_Walk:;
  end;
end;

procedure RP_Persistent (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  case op of
    fio_Load: ReadPersistent(TManagedObject(PField^));
    fio_Save: WritePersistent(TManagedObject(PField^));
    fio_Skip: SkipPersistent;
    fio_Walk: WalkPersistent(TManagedObject(PField^));
  end;
end;


procedure RP_AnsiString (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  case op of
    fio_Load: AnsiString(PField^):=ReadAnsiString();
    fio_Save: WriteAnsiString(AnsiString(PField^));
    fio_Skip: SkipAnsiString;
  end;
end;

procedure RP_Enum (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  case op of
    fio_Load: if DH.TypeChanged[DH.B_ToGtind[tind]]
                then LoadEnum(DH.B_ToGtind[Tind], PField)
                else dword(PField^):= {$ifdef fpc} CpsStream.{$endif} ReadDword();
    fio_Save: {$ifdef fpc} CpsStream.{$endif} WriteDword(dword(PField^));
    fio_Skip: {$ifdef fpc} CpsStream.{$endif} ReadDword; //SkipDword;
  end;
end;

procedure RP_Record (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  case op of
    fio_Load, fio_Skip: LoadRecord(PField, OP, DH.B_Lrecind[tind]);
    fio_Save: SaveRecord(PField, Types[Tind].RecordInd);
    fio_Walk: WalkRecord(PField, Types[Tind].RecordInd);
  end;
end;

procedure RP_GenericDynArray (PField: pointer; OP: TFieldOperation; Tind: integer); register;
//processes *any* types that have a processing procedure.
// exploits the fact that the dynamic arrays of any type
// have a similar layout in memory:
// reference count at offset -8 (we always set it to 1) and
// High value at -4 (length = High + 1)
var
  i, s, m, t: cardinal;
  p: TCustomTypeProcessingProc;
begin
  {$ifdef safeloading}
 try
  {$endif}
  case op of
    fio_Load, fio_Skip: begin
      t:=DH.B_TBaseInds[Tind];
      s:=Types[DH.B_ToGtind[t]].Size;
      p:=Types[DH.B_ToGtind[t]].Proc;
    end
  else
    t:=Types[Tind].BaseTypeInd;
    s:=Types[t].Size;
    p:=Types[t].Proc;
  end;
  case op of
    fio_Save: begin
          if Assigned(pointer(PField^)) then begin
            WriteInt(longint(pointer(cardinal(PField^) - 4)^) {$ifdef fpc} + 1{$endif});
              //the value at -4 contains Length() in Delphi
              //and High() (i.e. Length() -1 ) in FreePascal
            for i:=0 to longint(pointer(cardinal(PField^) - 4)^) {$ifndef fpc}- 1{$endif} do
              p(pointer(cardinal(PField^) + i*s), fio_Save, t);
          end
          else WriteInt(0);
        end;
    fio_Load: begin
          m:=ReadInt;
//addlog(' -- %2 %1 %0',[ B_NameSpace[TNames[t]], B_Namespace[tnames[tind]], m]);
          if m > 0 then begin
            NewDynArray(PField, m, DH.B_ToGtind[t]);
            for i:=0 to m - 1 do
              p(pointer(cardinal(PField^) + i*s), fio_Load, t);
          end;
        end;
    fio_Skip: begin
          m:=ReadInt;
          if m > 0 then
            for i:=1 to m do
              p(nil, fio_Skip, t);
        end;
    fio_Walk:
        if Assigned(pointer(PField^)) then
          for i:=0 to longint(pointer(cardinal(PField^) - 4)^) {$ifndef fpc}- 1{$endif}
            do p(pointer(cardinal(PField^) + i*s), fio_Walk, t);
  end;
  
  {$ifdef safeloading}
 except
    case op of
      fio_Skip, fio_Load:
        Die(RuEn('При вызове RP_GenericDynArray(%0, %1, %2).','During call to RP_GenericDynArray(%0, %1, %2).')
        , [PField, GetEnumName(TypeInfo(TFieldOperation), ord(OP)), DH.B_Namespace[DH.tnames[tind]]]);
    else
        Die(RuEn('При вызове RP_GenericDynArray(%0, %1, %2).','During call to RP_GenericDynArray(%0, %1, %2).')
        , [PField, GetEnumName(TypeInfo(TFieldOperation), ord(OP)), Namespace[types[tind].name]]);
    end;
 end;
  {$endif}
end;

procedure RP_BinaryStaticArray (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  case op of
    fio_Load: ReadUnaligned(PField, Types[DH.B_ToGtind[Tind]].Size);
    fio_Save: CpsStream.Write(PField^, Types[Tind].Size);
    fio_Skip: SkipUnaligned(Types[DH.B_ToGtind[Tind]].Size);
  end;
end;

procedure RP_GenericStaticArray (PField: pointer; OP: TFieldOperation; Tind: integer); register;
var
  i, s, t: cardinal;
  p: TCustomTypeProcessingProc;
begin
  case op of
    fio_Load, fio_Skip: begin
      t:=DH.B_TBaseInds[Tind];
      s:=Types[DH.B_ToGtind[t]].Size;
      p:=Types[DH.B_ToGtind[t]].Proc;
    end
  else
    t:=Types[Tind].BaseTypeInd;
    s:=Types[t].Size;
    p:=Types[t].Proc;
  end;
  case op of
    fio_Save, fio_Walk: begin
            for i:=0 to (Types[Tind].Size div s) - 1 do
              p(pointer(cardinal(PField) + i*s), OP, t);
        end;
    fio_Load: begin
//addlog('rp_genericstatic %0  %1  %2  %3', [TSizes[Tind], s, (TSizes[Tind] div s) - 1, B_namespace[tnames[tind]]]);
            for i:=0 to (DH.TSizes[Tind] div s) - 1 do
              p(pointer(cardinal(PField) + i*s), OP, t);
        end;
    fio_Skip: begin
            for i:=1 to DH.TSizes[Tind] div s do
              p(nil, fio_Skip, t);
        end;
  end;
end;


procedure RP_Extended (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  case op of
    fio_Load: ReadUnaligned(PField, 10);
    fio_Save: CpsStream.Write(PField^, 10);
    fio_Skip: SkipUnaligned(10);
  end;
end;

procedure RP_Byte (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  case op of
    fio_Load: ReadUnaligned(PField, 1);
    fio_Save: CpsStream.Write(PField^, 1);
    fio_Skip: SkipUnaligned(1);
  end;
end;

procedure RP_ShortInt (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  case op of
    fio_Load: ReadUnaligned(PField, 1);
    fio_Save: CpsStream.Write(PField^, 1);
    fio_Skip: SkipUnaligned(1);
  end;
end;

procedure RP_Word (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  case op of
    fio_Load: ReadUnaligned(PField, 2);
    fio_Save: CpsStream.Write(PField^, 2);
    fio_Skip: SkipUnaligned(2);
  end;
end;

procedure RP_SmallInt (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  case op of
    fio_Load: ReadUnaligned(PField, 2);
    fio_Save: CpsStream.Write(PField^, 2);
    fio_Skip: SkipUnaligned(2);
  end;
end;

type
  TCBS = set of byte;
var
  cba, cbb: TCBS;

procedure ConvertSet(Tind: integer);
var
  b: integer;
begin
  FillChar(cbb, sizeof(cbb), 0);
  for b:=0 to DH.EnumConvTable[Tind].High do
    if b in cba then begin

    cbb:=cbb + [DH.EnumConvTable[Tind][b]];
//addlog('-- %0->%1',[b, EnumConvTable[Tind][b]]);
    end;

//  dword(p^):=EnumConvTable[tyi][ReadInt()];
end;

procedure LoadSet(Tind: integer; PField: pointer);
begin
  FillChar(cba, sizeof(cba), 0);
  ReadUnaligned(@cba, ReadInt());
  ConvertSet(Types[Tind].BaseTypeInd);
  MOVE(cbb, PField^, Types[Tind].size);
end;

var rpls_i: integer;
procedure RP_Set (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  case op of
    fio_Load:
       if DH.TypeChanged[DH.B_ToGtind[tind]]
         then LoadSet(DH.B_ToGtind[Tind], PField)
         else ReadUnaligned(PField, ReadInt());
    fio_Save: begin
         rpls_i:=1 + (Types[Tind].SetLen - 1) div 8;
//addlog('type = "%0", rpls = %1', [Namespace[Types[Tind].name] ,rpls_i]);
         {$ifdef fpc} CpsStream.{$endif} WriteDword(rpls_i);
         CpsStream.Write(PField^, rpls_i);
       end;
    fio_Skip:
       SkipUnaligned({$ifdef fpc} CpsStream.{$endif} ReadDword());
  end;
end;

procedure RP_UnknownSet (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  case op of
    fio_Skip:
       SkipUnaligned({$ifdef fpc} CpsStream.{$endif} ReadDword());
    fio_Load, fio_Save: Die(MI_ERROR_PROGRAMMER_NO_BAKA, [
      RuEn('Попытка сохранить поле типа chepersy_unknownset.',
           'Attempt to save a field of chepersy_unknownset.')]);
  end;
end;


procedure RP_WideString (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
   case op of
    fio_Load:
//begin
    WideString(PField^):=ReadWideString();
//addlog(WideString(PField^));
//end;
    fio_Save: WriteWideString(WideString(PField^));
    fio_Skip: SkipWideString;
  end;
end;

procedure RP_ArrayOfDWORD (PField: pointer; OP: TFieldOperation; Tind: integer); register;
// since it works with binary data, it should work
//   with *any* dynamic array whose base size is equal to 32 bits:
//   cardinal, integer, single, glUint, gl float, et cetera.
var
  s: integer;
begin
  case op of
    fio_Load: begin
        s:={$ifdef fpc} CpsStream.{$endif} ReadDword();
        pointer(pfield^):=nil;
        SetLength(Tarrayofdword(PField^), s);
        if s > 0 then
     //need to check, since an empty dynamic array is in fact a nil pointer.
          CpsStream.Read(pointer(PField^)^, s * 4);
      end;
    fio_Save: begin
        s:=Length(Tarrayofdword(PField^));
        {$ifdef fpc} CpsStream.{$endif} WriteDword(s);
        if s > 0 then CpsStream.Write(pointer(PField^)^, s * 4);
      end;
    fio_Skip: begin
        SkipUnaligned(4 * {$ifdef fpc} CpsStream.{$endif} ReadDword());//SkipBin(ReadInt());
      end;
  end;
end;

procedure RP_ArrayOfQWORD (PField: pointer; OP: TFieldOperation; Tind: integer); register;
// since it works with binary data, it should work
//   with *any* dynamic array whose base size is equal to 32 bits:
//   cardinal, integer, single, glUint, gl float, et cetera.
var
  s: integer;
begin
  case op of
    fio_Load: begin
        s:={$ifdef fpc} CpsStream.{$endif} ReadDword();
        pointer(pfield^):=nil;
        SetLength({$ifdef fpc}TarrayofQword{$else}TArrayOfInt64{$endif}(PField^), s);
        if s > 0
     //need to check, since an empty dynamic array is in fact a nil pointer.
          then CpsStream.Read(pointer(PField^)^, s * 8);//ReadBin(pointer(PField^), s*2);
      end;
    fio_Save: begin
        s:=Length({$ifdef fpc}TarrayofQword{$else}TArrayOfInt64{$endif}(PField^));
        {$ifdef fpc} CpsStream.{$endif} WriteDword(s);
        if s > 0 then CpsStream.Write(pointer(PField^)^, s * 8);
      end;
    fio_Skip: begin
        SkipUnaligned(8 * {$ifdef fpc} CpsStream.{$endif} ReadDword());//SkipBin(ReadInt()*2);
      end;
  end;
end;

procedure RP_ArrayOfEnum (PField: pointer; OP: TFieldOperation; Tind: integer); register;
var
  s, t, i: integer;
begin
  case op of
    fio_Load: begin
        s:={$ifdef fpc} CpsStream.{$endif} ReadDword();
        pointer(pfield^):= nil;
        SetLength(Tarrayofdword(PField^), s);
        if s > 0 then begin
          t:= DH.B_ToGtind[DH.B_TBaseInds[Tind]];//Types[Tind].BaseTypeInd;
     //need to check, since an empty dynamic array is in fact a nil pointer.
          if DH.TypeChanged[t]
            then
              For i:=0 to s - 1 do
                LoadEnum(t, @(Tarrayofdword(PField^)[i]))
            else
              CpsStream.Read(pointer(PField^)^, s * 4);
              //ReadBin(pointer(PField^), s);
        end;
      end;
    fio_Save: begin
        s:=Length(Tarrayofdword(PField^));
        {$ifdef fpc} CpsStream.{$endif} WriteDword(s);
        if s > 0
          then CpsStream.Write(pointer(PField^)^, s * 4);//WriteBin(pointer(PField^), s);
      end;
    fio_Skip: begin
        SkipUnaligned(4 * {$ifdef fpc} CpsStream.{$endif} ReadDword());//SkipBin(ReadInt());
      end;
  end;
end;

{$ifndef fpc}
procedure RP_LONGBOOL (PField: pointer; OP: TFieldOperation; Tind: integer); register;
begin
  case op of
    fio_Load: begin
        if ReadDword() = 0 then longbool(PField^):=false
                           else longbool(PField^):=true;
      end;
    fio_Save: begin
        if longbool(PField^) then WriteDword(1)
                             else WriteDword(0);
      end;
    fio_Skip:
        ReadDword();//ReadInt;
  end;
end;
{$endif}



