unit uProp;

interface

uses Rubies, Classes, HPropGrid, uPropGridItem;

procedure EventHandle(This, event_name: Tvalue; Handles: array of TObject);
function DefinePersistentClass(module: Tvalue; AClass: TPersistentClass; super: Tvalue; func: TAllocFunc): Tvalue;

implementation

uses SysUtils, Pythia, TypInfo, uStrUtils, uDefUtils;

function ap_data_get_struct(This: Tvalue): TObject;
begin
  result := TObject(dl_PropGridItem(This));
end;

function Prop_set_boolean(This, v: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: PChar;
begin
  real := ap_data_get_struct(This);
  name := rb_id2name(rb_frame_orig_func);
  try
    SetOrdProp(TObject(real), chopUnder(name), Ord(RTEST(v)));
  except
    on E: Exception do
      ap_raise(ap_eDelphiError, PChar(E.message));
  end;
  result := v;
end;

function Prop_get_boolean(This: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: PChar;
begin
  real := ap_data_get_struct(This);
  name := rb_id2name(rb_frame_orig_func);
  if (StrLen(name) > 0) and
    ((StrEnd(name)-1)^ = '?') then
     (StrEnd(name)-1)^:= #0;
  result := ap_bool(Boolean(GetOrdProp(TObject(real), trimUnder(name))));
end;

function Prop_set_integer(This, v: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: PChar;
begin
  real := ap_data_get_struct(This);
  name := rb_id2name(rb_frame_orig_func);
  try
    SetOrdProp(TObject(real), chopUnder(name), NUM2INT(v));
  except
    on E: Exception do
      ap_raise(ap_eDelphiError, PChar(E.message));
  end;
  result := v;
end;

function Prop_get_integer(This: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: PChar;
begin
  real := ap_data_get_struct(This);
  name := rb_id2name(rb_frame_orig_func);
  result := rb_int2inum(GetOrdProp(TObject(real), trimUnder(name)));
end;

function Prop_set_float(This, v: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: PChar;
begin
  real := ap_data_get_struct(This);
  name := rb_id2name(rb_frame_orig_func);
  try
    SetFloatProp(TObject(real), chopUnder(name), NUM2DBL(v));
  except
    on E: Exception do
      ap_raise(ap_eDelphiError, PChar(E.message));
  end;
  result := v;
end;

function Prop_get_float(This: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: PChar;
begin
  real := ap_data_get_struct(This);
  name := rb_id2name(rb_frame_orig_func);
  result := rb_float_new(GetFloatProp(real, trimUnder(name)));
end;

function Prop_set_set(This, v: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: PChar;
begin
  real := ap_data_get_struct(This);
  name := rb_id2name(rb_frame_orig_func);
  try
    SetOrdProp(real, chopUnder(name), dl_Set(v));
  except
    on E: Exception do
      ap_raise(ap_eDelphiError, PChar(E.message));
  end;
  result := v;
end;

function Prop_get_set(This: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: PChar;
  v: Integer;
  i: Integer;
begin
  real := ap_data_get_struct(This);
  name := rb_id2name(rb_frame_orig_func);
  result := rb_ary_new;
  v := GetOrdProp(real, trimUnder(name));
  i := 0;
  while v <> 0 do
  begin
    if v mod 2 = 1 then
      rb_ary_push(result, INT2FIX(i));
    v := v div 2;
    Inc(i);
  end;
end;

function Prop_set_string(This, v: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: PChar;
  real_name, real_cstr: string;
begin
  real := ap_data_get_struct(This);
  name := rb_id2name(rb_frame_orig_func);
  real_name := chopUnder(name);
  real_cstr := dl_String(v);
  try
    SetStrProp(real, real_name, real_cstr);
  except
    on E: Exception do
      ap_raise(ap_eDelphiError, PChar(E.message));
  end;
  result := v;
end;

function Prop_get_string(This: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: PChar;
  real_name, S: string;
begin
  real := ap_data_get_struct(This);
  name := rb_id2name(rb_frame_orig_func);
  real_name := trimUnder(name);
  S := GetStrProp(real, trimUnder(name));
  result := rb_str_new2(PChar(S));
end;

function Prop_set_path(This, v: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: PChar;
  real_name, real_cstr: string;
begin
  real := ap_data_get_struct(This);
  name := rb_id2name(rb_frame_orig_func);
  real_name := chopUnder(name);
  real_cstr := dl_Path(v);
  try
    SetStrProp(real, real_name, real_cstr);
  except
    on E: Exception do
      ap_raise(ap_eDelphiError, PChar(E.message));
  end;
  result := v;
end;

function Prop_get_path(This: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: PChar;
  real_name, S: string;
begin
  real := ap_data_get_struct(This);
  name := rb_id2name(rb_frame_orig_func);
  real_name := trimUnder(name);
  S := GetStrProp(real, trimUnder(name));
  result := ap_Path(S);
end;

function Prop_set_object(This, v: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: PChar;
  AClass: TClass;
  objv: TObject;
begin
  real := ap_data_get_struct(This);
  name := rb_id2name(rb_frame_orig_func);
  AClass := GetObjectPropClass(real, chopUnder(name));
  ap_data_get_object(v, AClass, objv);
  try
    SetObjectProp(real, chopUnder(name), objv);
  except
    on E: Exception do
      ap_raise(ap_eDelphiError, PChar(E.message));
  end;
  if objv is TComponent then
    TComponent(objv).tag := v;  // no effect
  rb_iv_set(This, PChar('@'+chop(name)), v);
  result := v;
end;

function Prop_get_object(This: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: PChar;
  objv: TObject;
begin
  real := ap_data_get_struct(This);
  name := rb_id2name(rb_frame_orig_func);
  objv := GetObjectProp(real, trimUnder(name));
  if objv is TComponent then
    result := TComponent(objv).tag
  else
    result := rb_iv_get(This, PChar('@'+name));
end;

function Prop_set_method(This, v: Tvalue): Tvalue; cdecl;
var
  hash, key: Tvalue;
  name: string;
  id: Tid;
begin
  hash := rb_iv_get(This, '@events');
  name := LowerCase1(rb_id2name(rb_frame_orig_func));
  SetLength(name, Length(name)-1); // chop!
  id := rb_intern(PChar(name));
  key := ID2SYM(id);
  if rb_respond_to(This, rb_intern('event_handle')) <> 0 then
       rb_funcall2(This, rb_intern('event_handle'), 1, @key);
  rb_hash_aset(hash, key, v);
  result := v;
end;

procedure ap_data_get_object(v: Tvalue; AClass: TClass; var Ret);
var
  Obj: TObject absolute Ret;
begin
  if v = Qnil then
    TObject(ret) := nil
  else
  begin
    Obj := ap_data_get_struct(v);
    if not (Obj is AClass) then
      ap_raise(ap_eArgError,
        Format('%s %s (expected %s)', [
           sWrong_arg_type,
           chopHead(Obj.ClassName),
           chopHead(AClass.ClassName)
        ]));
//    TObject(Ret) := Obj;
  end;
end;

//Pythia経由で使えるので不要。ただし、次の dl_caption() を見よ。
function dl_String(v: Tvalue): string;
begin
  Check_Type(v, T_STRING);
  SetString(result, ap_str_ptr(v), ap_str_len(v));
end;

//Pythia経由だとなぜか rb_id2name() でこけるので再定義しておく。
function dl_caption(v: Tvalue): String;
begin
  case RTYPE(v) of
  T_STRING: result := dl_String(v);
  T_SYMBOL: result := rb_id2name(SYM2ID(v));
  else
    ap_raise(ap_eArgError,
      Format('%s %s (String or Symbol required)',
        [sWrong_arg_type, rb_class2name(CLASS_OF(v))]
      )
    );
  end;
end;

procedure EventHandle(This, event_name: Tvalue; Handles: array of TObject);
var
  Obj: TObject;
  FPropInfo: PPropInfo;
  ATypeInfo: PTypeInfo;
  AMethod: TMethod;
  AHandle: TObject;
  name: ShortString;
  i: Integer;
begin
  ap_data_get_object(This, TObject, Obj);
  FPropInfo := GetPropInfo(Obj, Capitalize1(dl_caption(event_name)));
  if FPropInfo = nil then
    Exit;
//  ap_raise(eDelphiError, 'property not found');
  ATypeInfo := FPropInfo^.PropType^;
  if ATypeInfo^.Kind <> tkMethod then
    ap_raise(ap_eDelphiError, 'not method');
  name := ATypeInfo^.Name;
  name := Copy(name, 2, Length(name)-6) + FPropInfo^.Name;
  for i := Low(Handles) to High(Handles) do
  begin
    AHandle := Handles[i];
    AMethod.Code := AHandle.MethodAddress(name);
    AMethod.Data := AHandle;
    if AMethod.Code = nil then
    else
    begin
      SetMethodProp(Obj, FPropInfo, AMethod);
      Break;
    end;
  end;
end;

procedure DefineProp(cClass: Tvalue; AClass: TClass);
var
  ATypeInfo: PTypeInfo;
  APropList: TPropList;
  Count, i: Integer;
  ATypeData: PTypeData;
  APropInfo: TPropInfo;
  name: PChar;
  ary, defined_p: Tvalue;
  argc: Integer;
  args: array of Tvalue;
  Readable, Writable: Boolean;
begin
  argc := 1;
  SetLength(args, argc);
  args[0] := Qtrue;
  ary := rb_class_instance_methods(argc, @args, cClass);

  ATypeInfo := PTypeInfo(AClass.ClassInfo);
  ATypeData := GetTypeData(ATypeInfo);
  Count := ATypeData^.PropCount;
  GetPropInfos(ATypeInfo, @APropList);

  for i := 0 to Count-1 do
  begin
    APropInfo := APropList[i]^;
    ATypeData := GetTypeData(APropInfo.PropType^);

    name := PChar(LowerCase1(APropInfo.Name));
    if name = 'tag' then continue;
    Readable := APropInfo.GetProc <> nil;
    Writable := APropInfo.SetProc <> nil;

    { cClass#name method defined? }
    defined_p := rb_ary_includes(ary, rb_str_new2(name));
    if not RTEST(defined_p) then
    begin
    case APropInfo.PropType^^.Kind of
    tkInteger, tkChar, tkWChar:
      begin
        if Writable then DefineAttrSet(cClass, name, Prop_set_integer);
        if Readable then DefineAttrGet(cClass, name, Prop_get_integer);
      end;
    tkEnumeration:
      if ATypeData^.BaseType^ = TypeInfo(Boolean) then
      begin
        if Writable then DefineAttrSet(cClass, name, Prop_set_boolean);
        if Readable then
        begin
          DefineAttrGet(cClass, name, Prop_get_boolean);
          rb_define_alias(cClass, PChar(name+'?'), name);
        end;
      end
      else
      begin
        if Writable then DefineAttrSet(cClass, name, Prop_set_integer);
        if Readable then DefineAttrGet(cClass, name, Prop_get_integer);
      end;
    tkSet:
      begin
        if Writable then DefineAttrSet(cClass, name, Prop_set_set);
        if Readable then DefineAttrGet(cClass, name, Prop_get_set);
      end;
    tkFloat:
      begin
        if Writable then DefineAttrSet(cClass, name, Prop_set_float);
        if Readable then DefineAttrGet(cClass, name, Prop_get_float);
      end;
    tkString, tkLString, tkWString:
      begin
        //--
        //if Writable then DefineAttrSet(cClass, name, Prop_set_string);
        //if Readable then DefineAttrGet(cClass, name, Prop_get_string);
        //++
        if ( name = 'file_name' )    // 
        or ( name = 'path' )         // 
        or ( name = 'direcroty' )    // 
        then begin
          if Writable then DefineAttrSet(cClass, name, Prop_set_path);
          if Readable then DefineAttrGet(cClass, name, Prop_get_path);
        end else begin
          if Writable then DefineAttrSet(cClass, name, Prop_set_string);
          if Readable then DefineAttrGet(cClass, name, Prop_get_string);
        end;
      end;
    tkClass:
      begin
        if Writable then DefineAttrSet(cClass, name, Prop_set_object);
        if Readable then DefineAttrGet(cClass, name, Prop_get_object);
      end;
    tkMethod:
      begin
        if Writable then DefineAttrSet(cClass, name, Prop_set_method);
        if Readable then DefineMethod(cClass, name, retnil);
      end;
    end;

    end;
  end;
end;

function DefinePersistentClass(module: Tvalue; AClass: TPersistentClass; super: Tvalue; func: TAllocFunc): Tvalue;
var
  v, t: Tvalue;
  S: string;
  i: Integer;
begin
  v := ap_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 := AClass.ClassName;
  PhiAllocFuncList.AddObject(S, @func);
  i := 1;
  if Copy(S, 1, 5) = 'TPhi_' then i := 5;
  result := rb_define_class_under(module, PChar(S)+i, super);
  rb_iv_set(result, '_class', rb_data_object_alloc(ap_cObject, AClass.ClassInfo, nil, nil));
  DefineProp(result, AClass);
  rb_ary_push(rb_funcall2(ap_mPhi, rb_intern('components'), 0, nil){vPhiComponents}, result);
end;

end.
