unit uProp;

interface

uses Classes, TypInfo, Rubies;

procedure Init_Prop;

function Prop_set_boolean(This, v: Tvalue): Tvalue; cdecl;
function Prop_get_boolean(This: Tvalue): Tvalue; cdecl;
function Prop_set_integer(This, v: Tvalue): Tvalue; cdecl;
function Prop_get_integer(This: Tvalue): Tvalue; cdecl;
function Prop_set_float(This, v: Tvalue): Tvalue; cdecl;
function Prop_get_float(This: Tvalue): Tvalue; cdecl;
function Prop_set_set(This, v: Tvalue): Tvalue; cdecl;
function Prop_get_set(This: Tvalue): Tvalue; cdecl;
function Prop_set_string(This, v: Tvalue): Tvalue; cdecl;
function Prop_get_string(This: Tvalue): Tvalue; cdecl;
function Prop_set_path(This, v: Tvalue): Tvalue; cdecl;
function Prop_get_path(This: Tvalue): Tvalue; cdecl;
function Prop_set_object(This, v: Tvalue): Tvalue; cdecl;
function Prop_get_object(This: Tvalue): Tvalue; cdecl;
function Prop_set_method(This, v: Tvalue): Tvalue; cdecl;
function Prop_get_method(This: Tvalue): Tvalue; cdecl;

function GetEnumName0(TypeInfo: PTypeInfo; v: Integer): string;
function GetEnumProp0(obj: TObject; PropInfo: PPropInfo): string;
function GetSetProp0(obj: TObject; PropInfo: PPropInfo; Brackets: Boolean): string;
function GetEnumProp1(obj: TObject; const PropName: string): string;
function GetSetProp1(obj: TObject; const PropName: string; Brackets: Boolean): string;
function ap_get_str_prop(obj: TObject; const PropName: string; c: Char): Tvalue;

procedure DefineAttrMethod(klass: Tvalue; name: PChar);
procedure DefineAttrMethod_retval(klass: Tvalue; name: PChar);
procedure DefineModuleAttrMethod(module: Tvalue; name: PChar);

procedure EventHandle(This, event_name: Tvalue; Handles: array of TObject);
//procedure AssignPropMethod(Obj: TObject; Handles: array of TObject);
procedure DefineProp(cClass: Tvalue; AClass: TClass);
{$IFDEF MAKE_PROFILE}
procedure OutputProfile(S: string);
{$ENDIF}
procedure DefineConstSetType(module: Tvalue; TypeInfo: PTypeInfo);

procedure OutputClassName(klass: Tvalue);
procedure OutputAttrMethod(klass: Tvalue; name: PChar);
procedure OutputAttrMethod_retval(klass: Tvalue; name: PChar);
procedure OutputProp(cClass: Tvalue; AClass: TClass);
procedure OutputConstSetType(module: Tvalue; TypeInfo: PTypeInfo);

implementation

uses
  SysUtils,
{$IFDEF MSWINDOWS}
  Windows,
{$ENDIF}
{$IFDEF LINUX}
  Types,
{$ENDIF}
  uStrUtils, uDefUtils,
  uHandle, uAlloc, uPhi, uError, uDebug, uIO, uConv,
  uPropInfo, uTypeInfo;

var
  id_event_handle: Tid;

procedure Init_Prop;
begin
  id_event_handle := rb_intern('event_handle');
end;

function last_func_name: string;
begin
  Result := rb_id2name(rb_frame_orig_func);
end;

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

function Prop_get_boolean(This: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: string;
begin
  real := ap_data_get_struct(This);
  name := last_func_name;
  if Copy(name, Length(name), 1) = '?' then
    name := chop(name);
  result := ap_bool(Boolean(GetOrdProp(real, trimUnder(name))));
end;

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

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

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

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

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

function Prop_get_set(This: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: string;
  v: Integer;
  i: Integer;
begin
  real := ap_data_get_struct(This);
  name := last_func_name;
  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: string;
  real_name, real_cstr: string;
begin
  real := ap_data_get_struct(This);
  name := last_func_name;
  real_name := chopUnder(name);
  real_cstr := dl_String(v);
  try
    SetStrProp(real, real_name, real_cstr);
  except
    on E: Exception do
      ap_raise(eDelphiError, E.message);
  end;
  result := v;
end;

function Prop_get_string(This: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: string;
  real_name, S: string;
begin
  real := ap_data_get_struct(This);
  name := last_func_name;
  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: string;
  real_name, real_cstr: string;
begin
  real := ap_data_get_struct(This);
  name := last_func_name;
  real_name := chopUnder(name);
  real_cstr := dl_Path(v);
  try
    SetStrProp(real, real_name, real_cstr);
  except
    on E: Exception do
      ap_raise(eDelphiError, E.message);
  end;
  result := v;
end;

function Prop_get_path(This: Tvalue): Tvalue; cdecl;
var
  real: TObject;
  name: string;
  real_name, S: string;
begin
  real := ap_data_get_struct(This);
  name := last_func_name;
  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: string;
  AClass: TClass;
  objv: TObject;
begin
  real := ap_data_get_struct(This);
  name := last_func_name;
  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(eDelphiError, 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: string;
  objv: TObject;
begin
  real := ap_data_get_struct(This);
  name := last_func_name;
  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(last_func_name);
  SetLength(name, Length(name)-1); // chop!
  id := rb_intern(PChar(name));
  key := ID2SYM(id);
  if rb_respond_to(This, id_event_handle) <> 0 then
       rb_funcall2(This, id_event_handle, 1, @key);
  rb_hash_aset(hash, key, v);
  result := v;
end;

function Prop_get_method(This: Tvalue): Tvalue; cdecl;
begin
  result := Qnil;
end;

procedure DefineAttrMethod(klass: Tvalue; name: PChar);
begin
  DefineAttrSet(klass, name, Prop_set_method);
  DefineMethod (klass, name, retnil);
end;

procedure DefineAttrMethod_retval(klass: Tvalue; name: PChar);
begin
  DefineAttrSet(klass, name, Prop_set_method);
  DefineMethod (klass, name, retval);
end;

procedure DefineModuleAttrMethod(module: Tvalue; name: PChar);
begin
  DefineModuleAttrSet(module, name, Prop_set_method);
  DefineModuleFunction(module, name, retnil);
end;

function GetEnumName0(TypeInfo: PTypeInfo; v: Integer): string;
begin
  case TypeInfo^.Kind of
  tkInteger, tkChar, tkEnumeration, tkWChar:
    result := UpperCase1(GetEnumName(TypeInfo, v));
  else
    result := '';
  end;
end;

function GetEnumProp0(obj: TObject; PropInfo: PPropInfo): string;
begin
  if PropInfo = nil then
    result := ''
  else
    result := GetEnumName0(PropInfo^.PropType^, GetOrdProp(obj, PropInfo));
end;

function GetEnumProp1(obj: TObject; const PropName: string): string;
var
  PropInfo: PPropInfo;
begin
  PropInfo := GetPropInfo(obj, PropName);
  if PropInfo = nil then
    result := ''
  else
    result := GetEnumProp0(obj, PropInfo);
end;

function GetSetProp0(obj: TObject; PropInfo: PPropInfo; Brackets: Boolean): string;
var
  S: TIntegerSet;
  TypeInfo: PTypeInfo;
  I: Integer;
begin
  Integer(S) := GetOrdProp(obj, PropInfo);
  TypeInfo := GetTypeData(PropInfo^.PropType^)^.CompType^;
  for I := 0 to SizeOf(Integer) * 8 - 1 do
    if I in S then
    begin
      if Result <> '' then
        Result := Result + ',';
      Result := Result + GetEnumName0(TypeInfo, I);
    end;
  if Brackets then
    Result := '[' + Result + ']';
end;

function GetSetProp1(obj: TObject; const PropName: string;
  Brackets: Boolean): string;
begin
  Result := GetSetProp0(obj, GetPropInfo(obj, PropName), Brackets);
end;

function ap_get_str_prop(obj: TObject; const PropName: string; c: Char): Tvalue;
var
  S: string;
begin
  S := GetStrProp(obj, PropName);
  if c <> #0 then S := AnsiQuotedStr(S, c);
  Result := ap_String(S);
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(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 AssignPropMethod(Obj: TObject; Handles: array of TObject);
var
  ATypeInfo: PTypeInfo;
  APropList: TPropList;
  Count, i, j: Integer;
  ATypeData: PTypeData;
  APropInfo: TPropInfo;
  AMethod: TMethod;
  AHandle: TObject;
  name: ShortString;
begin
  ATypeInfo := PTypeInfo(Obj.ClassInfo);
  ATypeData := GetTypeData(ATypeInfo);
  Count := ATypeData^.PropCount;
  GetPropInfos(ATypeInfo, @APropList);

  for i := 0 to Count-1 do
  begin
    APropInfo := APropList[i]^;
    if APropInfo.PropType^^.Kind = tkMethod then
    begin
      AMethod := GetMethodProp(Obj, APropList[i]);
      if AMethod.Code = nil then
      begin
        ATypeInfo := APropInfo.PropType^;
        name := ATypeInfo^.Name;
        name := Copy(name, 2, Length(name)-6) + APropInfo.Name;
        for j := Low(Handles) to High(Handles) do
        begin
          AHandle := Handles[j];
          AMethod.Code := AHandle.MethodAddress(name);
          AMethod.Data := AHandle;
          if AMethod.Code = nil then
          else
          begin
            SetMethodProp(Obj, APropList[i], AMethod);
            Break;
          end;
        end;
        if debug_p then
          if AMethod.Code = nil then
            Stdout('no impl: '+Obj.ClassName+'#'+name+NL);
      end;
    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;

{$IFDEF MAKE_PROFILE}
var
  FProfile: TextFile;
  FProfileBeginDateTime: TDateTime;

procedure OutputProfile(S: string);
begin
  WriteLn(FProfile, S, #9, Format('%8.8f', [Now - FProfileBeginDateTime]));
end;
{$ENDIF}

procedure DefineConstSetType(module: Tvalue; TypeInfo: PTypeInfo);
var
  TypeData: PTypeData;
  Value: Integer;
  P: ^ShortString;
  T: PTypeData;

  function ap_TypeDataType(real: PTypeInfo): Tvalue;
  begin
    result := rb_data_object_alloc(cTypeInfo, real, nil, nil);
    TypeInfo_setup_internal(result, real);
    TypeInfo_setup_TypeData(result, real);
  end;

begin
{$IFDEF MAKE_PROFILE}
  OutputProfile(TypeInfo^.Name);
{$ENDIF}
  rb_hash_aset(vTypeInfo, ap_String(string(TypeInfo^.Name)), ap_TypeDataType(TypeInfo));
  TypeData := GetTypeData(TypeInfo);
  T := GetTypeData(TypeData^.BaseType^);
  P := @T^.NameList;
  for Value := T^.MinValue to T^.MaxValue do
  begin
    ap_define_const(module, P^, INT2FIX(Value));
    Inc(Integer(P), Length(P^) + 1);
  end;
end;

{$IFDEF MAKE_PROP}
var
  FProp: TextFile;

procedure OutputClassName(klass: Tvalue);
begin
  WriteLn(FProp, '  klass := c', rb_class2name(klass)+5{Phi::}, ';');
end;

procedure OutputAlias_p(klass: Tvalue; name: PChar);
begin
  rb_define_alias(klass, PChar(name+'?'), name);
  WriteLn(FProp, '  rb_define_alias(klass, ''', name, '?'', ''', name, ''');');
end;

procedure OutputMethod(klass: Tvalue; name, func: PChar);
begin
  rb_define_method(klass, name, nil, 0);
  WriteLn(FProp, '  rb_define_method(klass, ''', name, ''', @', func, ', -1);');
end;

procedure OutputAttrGet(klass: Tvalue; name, attr: PChar);
begin
  rb_define_method(klass, name, nil, 0);
  WriteLn(FProp, '  rb_define_method(klass, ''', name, ''', @', attr, ', 0);');
end;

procedure OutputAttrSet(klass: Tvalue; name, attr: PChar);
begin
  rb_define_method(klass, PChar(joinEq(name)), nil, 0);
  WriteLn(FProp, '  rb_define_method(klass, ''', name, '='', @', attr, ', 1);');
end;

procedure OutputAttrMethod(klass: Tvalue; name: PChar);
var
  ary, defined_p: Tvalue;
  argc: Integer;
  args: array of Tvalue;
begin
  argc := 1;
  SetLength(args, argc);
  args[0] := Qtrue;
  ary := rb_class_instance_methods(argc, @args, klass);
  defined_p := rb_ary_includes(ary, rb_str_new2(name));
  if RTEST(defined_p) then
    WriteLn(FProp, '//retnil:  overwrite ', rb_class2name(klass)+5, '#', name);
  OutputAttrSet(klass, name, 'Prop_set_method');
  OutputMethod (klass, name, 'retnil');
end;

procedure OutputAttrMethod_retval(klass: Tvalue; name: PChar);
var
  ary, defined_p: Tvalue;
  argc: Integer;
  args: array of Tvalue;
begin
  argc := 1;
  SetLength(args, argc);
  args[0] := Qtrue;
  ary := rb_class_instance_methods(argc, @args, klass);
  defined_p := rb_ary_includes(ary, rb_str_new2(name));
  if RTEST(defined_p) then
    WriteLn(FProp, '//retval:  overwrite ', rb_class2name(klass)+5, '#', name);
  OutputAttrSet(klass, name, 'Prop_set_method');
  OutputMethod (klass, name, 'retval');
end;

procedure OutputProp(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);

  OutputClassName(cClass);

  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 OutputAttrSet(cClass, name, 'Prop_set_integer');
        if Readable then OutputAttrGet(cClass, name, 'Prop_get_integer');
      end;
    tkEnumeration:
      if ATypeData^.BaseType^ = TypeInfo(Boolean) then
      begin
        if Writable then OutputAttrSet(cClass, name, 'Prop_set_boolean');
        if Readable then
        begin
          OutputAttrGet(cClass, name, 'Prop_get_boolean');
          OutputAlias_p(cClass, name);
        end;
      end
      else
      begin
        if Writable then OutputAttrSet(cClass, name, 'Prop_set_integer');
        if Readable then OutputAttrGet(cClass, name, 'Prop_get_integer');
      end;
    tkSet:
      begin
        if Writable then OutputAttrSet(cClass, name, 'Prop_set_set');
        if Readable then OutputAttrGet(cClass, name, 'Prop_get_set');
      end;
    tkFloat:
      begin
        if Writable then OutputAttrSet(cClass, name, 'Prop_set_float');
        if Readable then OutputAttrGet(cClass, name, 'Prop_get_float');
      end;
    tkString, tkLString, tkWString:
      begin
        //--
        //if Writable then OutputAttrSet(cClass, name, 'Prop_set_string');
        //if Readable then OutputAttrGet(cClass, name, 'Prop_get_string');
        //++
        if ( name = 'file_name' )    // 
        or ( name = 'path' )         // 
        or ( name = 'direcroty' )    // 
        then begin
          if Writable then OutputAttrSet(cClass, name, 'Prop_set_path');
          if Readable then OutputAttrGet(cClass, name, 'Prop_get_path');
        end else begin
          if Writable then OutputAttrSet(cClass, name, 'Prop_set_string');
          if Readable then OutputAttrGet(cClass, name, 'Prop_get_string');
        end;
      end;
    tkClass:
      begin
        if Writable then OutputAttrSet(cClass, name, 'Prop_set_object');
        if Readable then OutputAttrGet(cClass, name, 'Prop_get_object');
      end;
    tkMethod:
      begin
        if Writable then OutputAttrSet(cClass, name, 'Prop_set_method');
        if Readable then OutputMethod(cClass, name, 'retnil');
      end;
    end;

    end;
  end;
end;

procedure OutputConstSetType(module: Tvalue; TypeInfo: PTypeInfo);
var
  TypeData: PTypeData;
  Value: Integer;
  P: ^ShortString;
  T: PTypeData;

begin
  TypeData := GetTypeData(TypeInfo);
  T := GetTypeData(TypeData^.BaseType^);
  P := @T^.NameList;
  for Value := T^.MinValue to T^.MaxValue do
  begin
    ap_define_const(module, P^, INT2FIX(Value));
    WriteLn(FProp, '  rb_define_const(m', rb_class2name(module), ', ''', PChar(UpperCase1(P^)), ''', ', INT2FIX(Value), ');');
    Inc(Integer(P), Length(P^) + 1);
  end;
end;
{$ELSE}
procedure OutputClassName(klass: Tvalue);
begin
// nothing
end;

procedure OutputAttrMethod(klass: Tvalue; name: PChar);
begin
// nothing
end;

procedure OutputAttrMethod_retval(klass: Tvalue; name: PChar);
begin
// nothing
end;

procedure OutputProp(cClass: Tvalue; AClass: TClass);
begin
// nothing
end;

procedure OutputConstSetType(module: Tvalue; TypeInfo: PTypeInfo);

  function ap_TypeDataType(real: PTypeInfo): Tvalue;
  begin
    result := rb_data_object_alloc(cTypeInfo, real, nil, nil);
    TypeInfo_setup_internal(result, real);
    TypeInfo_setup_TypeData(result, real);
  end;

begin
{$IFDEF MAKE_PROFILE}
  OutputProfile(TypeInfo^.Name);
{$ENDIF}
  rb_hash_aset(vTypeInfo, ap_String(string(TypeInfo^.Name)), ap_TypeDataType(TypeInfo));
end;
{$ENDIF}

initialization
{$IFDEF MAKE_PROFILE}
  AssignFile(FProfile, 'profile.txt');
  Rewrite(FProfile);
  FProfileBeginDateTime := Now;
{$ENDIF}
{$IFDEF MAKE_PROP}
  AssignFile(FProp, '..\src\PhiProp.inc');
  Rewrite(FProp);
{$ENDIF}

finalization
{$IFDEF MAKE_PROFILE}
  CloseFile(FProfile);
{$ENDIF}
{$IFDEF MAKE_PROP}
  CloseFile(FProp);
{$ENDIF}

end.
