unit uAlloc;

//author: YOSHIDA Kazuhiro (moriq)
//mailto: moriq@moriq.com

interface

uses
  Classes,
{$IFDEF VCL}
  Forms, Controls,
{$ELSE}
  QForms, QControls,
{$ENDIF}
  Rubies;

function ap_owner(obj, owner: Tvalue): Tvalue;
//function ap_iv_set(obj: Tvalue; const name: PChar; val: Tvalue): Tvalue;
procedure ap_dispose(p: Pointer); cdecl;
procedure ObjFree(real: TObject); cdecl;
procedure ChildFree(real: TComponent); cdecl;
procedure CompoFree(real: TComponent); cdecl;
procedure FormRelease(real: TForm); cdecl;
function CompoAlloc(klass: Tvalue; real: TComponent): Tvalue;
function FormAlloc(klass: Tvalue; real: TComponent): Tvalue;
function ObjAlloc(klass: Tvalue; real: TObject): Tvalue;
function ChildAlloc(klass: Tvalue; real: TComponent): Tvalue;
function TmpAlloc(klass: Tvalue; real: TObject): Tvalue;

implementation

uses SysUtils, uDebug, uHandle, uIO;

function ap_owner(obj, owner: Tvalue): Tvalue;
begin
  result := rb_iv_set(obj, '@owner', owner);
end;
(*
function ap_iv_set(obj: Tvalue; const name: PChar; val: Tvalue): Tvalue;
begin
  result := rb_iv_set(obj, name, val);
  ap_owner(val, obj);
end;
*)
procedure ap_dispose(p: Pointer); cdecl;
begin
  try
//    if debug_p and Assigned(Stdout) then
//      Stdout(PChar('Dispose'+NL));
    Dispose(p);
  except
    on E: Exception do;
  end;
end;

procedure ObjFree(real: TObject); cdecl;
begin
  try
//    if debug_p and Assigned(Stdout) then
//      Stdout(PChar('ObjFree'+NL));
    PhiObjectList.Remove(real);
  except
    on E: Exception do;
  end;
end;

procedure ChildFree(real: TComponent); cdecl;
begin
  try
    if debug_p and Assigned(Stdout) then
      Stdout(PChar(Format('ChildFree: %s(%s)'+NL, [real.name, real.classname])));
    real.tag := 0;
  except
    on E: Exception do;
  end;
end;

procedure CompoFree(real: TComponent); cdecl;
var
  AControl: TWinControl;
  i: Integer;
begin
  try
    if debug_p and Assigned(Stdout) then
      Stdout(PChar(Format('CompoFree: %s(%s)'+NL, [real.name, real.classname])));
    real.tag := 0;
//    for i := 0 to real.ComponentCount-1 do
//      real.Components[i].tag := 0;
    if real is TWinControl then
    begin
      AControl := TWinControl(real);
      i := AControl.ControlCount;
      while i <> 0 do
      begin
        AControl.RemoveControl(AControl.Controls[i-1]);
        i := AControl.ControlCount;
      end;
    end;
    if csDestroying in real.ComponentState then
      PhiObjectList.Extract(real)
    else
      PhiObjectList.Remove(real);
  except
    on E: Exception do;
  end;
end;

procedure FormRelease(real: TForm); cdecl;
begin
  try
    if debug_p and Assigned(Stdout) then
      Stdout(PChar(Format('FormRelease: %s(%s)'+NL, [real.name, real.classname])));
    real.tag := 0;
    PhiObjectList.Extract(real);
    real.Release;
  except
    on E: Exception do;
  end;
end;

function CompoAlloc(klass: Tvalue; real: TComponent): Tvalue;
begin
  if real = nil then begin result := Qnil; exit; end;
  if debug_p and Assigned(Stdout) then
    Stdout(PChar(Format('CompoAlloc: %s(%s)'+NL, [real.name, real.classname])));
  PhiObjectList.Add(real);
  result := rb_data_object_alloc(klass, real, nil, @CompoFree);
  rb_iv_set(result, '@events', rb_hash_new);
  real.tag := result;
  if rb_block_given_p <> 0 then rb_obj_instance_eval(0, nil, result);
end;

function FormAlloc(klass: Tvalue; real: TComponent): Tvalue;
begin
  if real = nil then begin result := Qnil; exit; end;
  if debug_p and Assigned(Stdout) then
    Stdout(PChar(Format('FormAlloc: %s(%s)'+NL, [real.name, real.classname])));
  PhiObjectList.Add(real);
  result := rb_data_object_alloc(klass, real, nil, @FormRelease);
  rb_iv_set(result, '@events', rb_hash_new);
  real.tag := result;
end;

function ObjAlloc(klass: Tvalue; real: TObject): Tvalue;
begin
  if real = nil then begin result := Qnil; exit; end;
//  if debug_p and Assigned(Stdout) then
//    Stdout(PChar('ObjAlloc'));
  PhiObjectList.Add(real);
  result := rb_data_object_alloc(klass, real, nil, @ObjFree);
end;

function ChildAlloc(klass: Tvalue; real: TComponent): Tvalue;
begin
  if real = nil then begin result := Qnil; exit; end;
  if debug_p and Assigned(Stdout) then
    Stdout(PChar(Format('ChildAlloc: %s(%s)'+NL, [real.name, real.classname])));
  result := rb_data_object_alloc(klass, real, nil, @ChildFree);
  rb_iv_set(result, '@events', rb_hash_new);
  real.tag := result;
end;

function TmpAlloc(klass: Tvalue; real: TObject): Tvalue;
begin
  if real = nil then begin result := Qnil; exit; end;
//  if debug_p and Assigned(Stdout) then
//    Stdout(PChar('TmpAlloc'));
  result := rb_data_object_alloc(klass, real, nil, nil);
end;

end.
