unit uPersistent;

interface

uses Rubies, SysUtils, Classes;

var
  cPersistent: Tvalue;

function dl_Persistent(v:Tvalue):TPersistent;
function ap_cPersistent: Tvalue;
function DefinePersistentClass(module: Tvalue; AClass: TPersistentClass; super: Tvalue; func: TAllocFunc): Tvalue;
function OutputPersistentClass(module: Tvalue; AClass: TPersistentClass; super: Tvalue; func: TAllocFunc): Tvalue;
procedure Init_Persistent;

implementation

uses
  uStrUtils, uDefUtils, uHandle, uError, uPhi, uProp, uTypeInfo, uDebug, uIO;

function dl_Persistent(v:Tvalue):TPersistent;
begin
  ap_data_get_object( v, TPersistent, result);
end;

function ap_cPersistent: Tvalue;
begin
  result := cPersistent;
end;

function DefinePersistentClass(module: Tvalue; AClass: TPersistentClass; super: Tvalue; func: TAllocFunc): Tvalue;
var
  v, t: Tvalue;
  S: string;
begin
  v := cPersistent;
//  writeln(AClass.ClassName, ': ', rb_class2name(super), ' <=> ', rb_class2name(v));
  t := rb_funcall2(super, rb_intern('>'), 1, @v);
  if RTEST(t) then
    ap_raise(ap_eDelphiError, AClass.ClassName +': '+ rb_class2name(super)+ ' > ' +rb_class2name(v)+ ' in DefinePersistentClass');
  try
    RegisterClass(AClass);
  except
    on E: EFilerError do
    //if debug_p then Stdout(E.ClassName + ' in DefinePersistentClass:' + E.Message)
    ;
  end;
  S := trimPhiUnder(AClass.ClassName);
  PhiAllocFuncList.AddObject(S, @func);
  result := rb_define_class_under(module, PChar(S)+1, super);
  rb_iv_set(result, '_class', rb_data_object_alloc(ap_cObject, AClass.ClassInfo, nil, nil));
  DefineProp(result, AClass);
  rb_ary_push(vPhiComponents, result);
end;

function OutputPersistentClass(module: Tvalue; AClass: TPersistentClass; super: Tvalue; func: TAllocFunc): Tvalue;
var
  v, t: Tvalue;
  S: string;
begin
  v := cPersistent;
//  writeln(AClass.ClassName, ': ', rb_class2name(super), ' <=> ', rb_class2name(v));
  t := rb_funcall2(super, rb_intern('>'), 1, @v);
  if RTEST(t) then
    ap_raise(ap_eDelphiError, AClass.ClassName +': '+ rb_class2name(super)+ ' > ' +rb_class2name(v)+ ' in OutputPersistentClass');
  try
    RegisterClass(AClass);
  except
    on E: EFilerError do;
  end;
  S := trimPhiUnder(AClass.ClassName);
  PhiAllocFuncList.AddObject(S, @func);
  result := rb_define_class_under(module, PChar(S)+1, super);
  rb_iv_set(result, '_class', rb_data_object_alloc(ap_cObject, AClass.ClassInfo, nil, nil));
  OutputProp(result, AClass);
  rb_ary_push(vPhiComponents, result);
end;

function Persistent_event_handle(This, name: Tvalue): Tvalue; cdecl;
begin
  EventHandle(This, name, [Handle]);
  result := Qnil;
end;

function Persistent_type_info(This: Tvalue): Tvalue; cdecl;
begin
  result := TypeInfo_new(cTypeInfo, This);
end;

procedure Init_Persistent;
begin
  cPersistent := rb_define_class_under(mPhi, 'Persistent', ap_cObject);
  rb_define_method(cPersistent, 'event_handle', @Persistent_event_handle, 1);
  rb_define_singleton_method(cPersistent, 'type_info', @Persistent_type_info, 0);
end;

end.
