unit uForm;

interface

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

var
  cForm: Tvalue;

function ap_cForm: Tvalue;
procedure Form_setup(obj: Tvalue; real: TForm);
function ap_iForm(real: TForm; owner: Tvalue): Tvalue;
function ap_iForm_v(var AControl; owner: Tvalue): Tvalue;
procedure FormSetName(real: TForm; name: String);
procedure Init_form;

implementation

uses
{$IFDEF MSWINDOWS}
  Windows,
{$ELSE}
  Libc,
{$ENDIF}
  SysUtils, Classes,
{$IFDEF VCL}
  Controls,
{$ELSE}
  QControls,
{$ENDIF}
  PhiForm,
  uIcon, uDefUtils, uIntern, uHandle, uAlloc, uProp, uPhi, uConv,
  uSizeConstraints, uFont, uCanvas, uScreen, uBitmap, uControlScrollBar,
  uPersistent, uControl;

type TMyForm = class(TPhiForm);

function ap_cForm: Tvalue;
begin
  result := cForm;
end;

procedure Form_setup(obj: Tvalue; real: TForm);
var
  ceo: Tvalue;
begin
  rb_iv_set(obj, '@icon', ap_iIcon(real.Icon, obj));
  rb_iv_set(obj, '@canvas', ap_iCanvas(real.Canvas, obj));
//  rb_iv_set(obj, '@font', ap_iFont(real.Font, obj));
  rb_iv_set(obj, '@constraints', ap_iSizeConstraints(real.Constraints, obj));
  rb_iv_set(obj, '@horz_scroll_bar', ap_iControlScrollBar(real.HorzScrollBar, obj));
  rb_iv_set(obj, '@vert_scroll_bar', ap_iControlScrollBar(real.VertScrollBar, obj));
  ceo := vScreen;
  rb_iv_set(obj, '@parent', ceo);
//    AssignPropMethod(real, [Handle]);
  if @real.OnClose = nil then real.OnClose := Handle.CloseOnClose;
end;

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

function Form_alloc(This: Tvalue; real: TForm): Tvalue;
begin
  result := ChildAlloc(This, real);
  Form_setup(result, real);
end;

function ap_iForm(real: TForm; owner: Tvalue): Tvalue;
begin
  result := Form_alloc(cForm, real);
  ap_owner(result, owner);
end;

function ap_iForm_v(var AControl; owner: Tvalue): Tvalue;
var
  real: TForm;
begin
  real := TForm(AControl);
  result := FormAlloc(cForm, real);
  Form_setup(result, real);
end;

procedure FormSetName(real: TForm; name: String);
var
  obj, ceo: Tvalue;
begin
  obj := real.tag;
  ceo := vScreen; // rb_iv_get(obj, '@parent');
  rb_iv_set(ceo, PChar('@'+name), obj);
  rb_define_attr(rb_singleton_class(ceo), PChar(name), 1, 0);
  real.name := name;
end;
(*
function FormAlloc(klass: Tvalue; real: TComponent): Tvalue;
begin
//  if real = nil then begin result := Qnil; exit; end;
  result := rb_data_object_alloc(klass, real, nil, @FormRelease);
end;
*)
function Form_allocate(This: TValue): TValue; cdecl;
var
  real: TForm;
begin
  { TPhiForm.Create の中では TPhiForm.CreateParams が呼ばれる。
    そこで yield するとき block が評価される。 }
  real := TPhiForm.Create(nil);
  result := FormAlloc(This, real);
  Form_setup(result, real);
end;

function Form_initialize(argc: integer; argv: Pointer; This: Tvalue): Tvalue; cdecl;
var
  real: TForm;
  args: Rubies.Pvalue;
  d_name: string;
begin
  real := ap_data_get_struct(This);
  args := Rubies.Pvalue(argv);

  real.width  := 320;
  real.height := 200;
  real.left := (Screen.width  - real.width ) div 2;
  real.top  := (Screen.height - real.height) div 2;

  if (argc > 0) and (dl_class_name_of(args^) = 'Symbol') then
  begin
    d_name := dl_caption(args^);
    dec(argc);
    inc(args);
  end else if dl_Boolean(ap_const_get(mPhi, 'DELPHIAN_AUTO_NAME')) then
    d_name := dl_string(rb_funcall2(mPhi, rb_intern('delphian_auto_name'), 1, @This))
  else
    d_name := 'c_' + IntToStr(real.tag);
  FormSetName(real, d_name);

  if (argc > 0) and (dl_class_name_of(args^) = 'String') then
  begin
    rb_funcall2(This, rb_intern('caption='), 1, args);
    dec(argc);
    inc(args);
  end;

  rb_call_super(0, nil);
  result := This;
end;

function Form_close(This: Tvalue): Tvalue; cdecl;
var
  real: TForm;
begin
  real := ap_data_get_struct(This);
  real.Close;
  result := This;
end;

function Form_show(This: Tvalue): Tvalue; cdecl;
var
  real: TForm;
begin
  real := ap_data_get_struct(This);
  real.Show;
  result := This;
end;

function Form_show_modal(This: Tvalue): Tvalue; cdecl;
var
  real: TForm;
begin
  real := ap_data_get_struct(This);
  result := INT2FIX(real.ShowModal);
end;

{$IFDEF VCL}
function Form_get_bitmap(This: Tvalue): Tvalue; cdecl;
var
  real: TForm;
begin
  real := ap_data_get_struct(This);
  result := ap_iBitmap(real.GetFormImage, This);
end;
{$ENDIF}

function Form_get_active_control(This: Tvalue): Tvalue; cdecl;
var
  real: TForm;
  AControl: TWinControl;
begin
  real := ap_data_get_struct(This);
  AControl := real.ActiveControl;
  if AControl = nil then
    result := Qnil
  else
    result := AControl.tag;
end;

function Form_set_active_control(This, v: Tvalue): Tvalue; cdecl;
var
  real: TForm;
  Control: TWinControl;
begin
  real := ap_data_get_struct(This);
  Control := ap_data_get_struct(v);
  real.ActiveControl := Control;
  result := v;
end;

function Form_get_modal_result(this: Tvalue): Tvalue; cdecl;
var
  real: TForm;
begin
  real := ap_data_get_struct(this);
  result := INT2FIX(real.ModalResult);
end;

function Form_set_modal_result(this, v: Tvalue): Tvalue; cdecl;
var
  real: TForm;
begin
  real := ap_data_get_struct(this);
  real.ModalResult := FIX2INT(v);
  result := v;
end;

function Form_get_canvas(This: Tvalue): Tvalue; cdecl;
begin
  result := rb_iv_get(This, '@canvas');
end;

function Form_get_active(This: Tvalue): Tvalue; cdecl;
var
  real: TForm;
begin
  real := ap_data_get_struct(this);
  result := ap_bool(real.Active);
end;

{$IFDEF VCL}
function Form_copy_data(This, recv, str: Tvalue): Tvalue; cdecl;
var
  real: TPhiForm;
begin
  real := ap_data_get_struct(this);
  real.CopyData(FIX2INT(recv), dl_String(str));
  result := This;
end;

function Form_get_short_cut_enabled(This: Tvalue): Tvalue; cdecl;
var
  real: TPhiForm;
begin
  real := ap_data_get_struct(this);
  result := ap_bool(real.ShortCutEnabled);
end;

function Form_set_short_cut_enabled(This,v: Tvalue): Tvalue; cdecl;
var
  real: TPhiForm;
begin
  real := ap_data_get_struct(this);
  real.ShortCutEnabled := RTEST(v);
  result := This;
end;
{$ENDIF}

{$IFDEF MSWINDOWS}
{$IFDEF VCL}
function Form_bring_to_front_ex(This: Tvalue): Tvalue; cdecl;
var
  Handle: HWnd;
  real : TForm;
  nForegroundID, nTargetID: Integer;
begin
  result := This;
  real := ap_data_get_struct(This);
  Handle := real.Handle;//CLX: HWND -> QOpenScrollViewH
  if Handle <> 0 then
  begin
    if  IsWindowVisible(Handle)
    and IsWindowEnabled(Handle) then
    begin
      nForegroundID := GetWindowThreadProcessId(GetForegroundWindow(), nil);
      nTargetID := GetWindowThreadProcessId(Handle, nil);
      AttachThreadInput(nTargetID, nForegroundID, True);
      SetForegroundWindow(Handle);
      AttachThreadInput(nTargetID, nForegroundID, False);
    end;
  end;
end;
{$ENDIF}
{$ENDIF}

{$IFDEF VCL}
function Form_get_querying_end_session(This: Tvalue): Tvalue; cdecl;
var
  real: TPhiForm;
begin
  real := ap_data_get_struct(this);
  result := ap_bool(real.QueryingEndSession);
end;
{$ENDIF}

(**** str2 made by ap_src_maker ****)
{$IFDEF VCL}
function Form_paint(This : Tvalue): Tvalue; cdecl;
var
  real: TMyForm;
begin
  real := ap_data_get_struct(This);
  real.inherited_Paint;
  result := This;
end;
{$ENDIF}
function Form_request_align(This : Tvalue): Tvalue; cdecl;
var
  real: TMyForm;
begin
  real := ap_data_get_struct(This);
  real.RequestAlign;
  result := This;
end;

function Form_update_actions(This : Tvalue): Tvalue; cdecl;
var
  real: TMyForm;
begin
  real := ap_data_get_struct(This);
  real.UpdateActions;
  result := This;
end;
{$IFDEF VCL}
function Form_update_window_state(This : Tvalue): Tvalue; cdecl;
var
  real: TMyForm;
begin
  real := ap_data_get_struct(This);
  real.UpdateWindowState;
  result := This;
end;
{$ENDIF}
function Form_validate_rename(This, AComponent, CurName, NewName : Tvalue): Tvalue; cdecl;
var
  real: TMyForm;
  dl_AComponent : TComponent;
  dl_CurName : string;
  dl_NewName : string;
begin
  real := ap_data_get_struct(This);
  dl_AComponent := ap_data_get_struct(AComponent);
  dl_CurName := dl_String(CurName);
  dl_NewName := dl_String(NewName);
  real.ValidateRename( dl_AComponent, dl_CurName, dl_NewName );
  result := This;
end;

function Form_get_active_mdi_child(This: Tvalue): Tvalue; cdecl;
var
  real: TMyForm;
begin
  real := ap_data_get_struct(This);
  result := ap_iForm(real.ActiveMDIChild,This);
end;
{$IFDEF VCL}
function Form_get_form_image(This : Tvalue): Tvalue; cdecl;
var
  real: TMyForm;
begin
  real := ap_data_get_struct(This);
  result := ap_iBitmap(real.GetFormImage,This);
end;

function Form_make_fully_visible(This, AMonitor : Tvalue): Tvalue; cdecl;
var
  real: TMyForm;
  dl_AMonitor : TMonitor;
begin
  real := ap_data_get_struct(This);
  dl_AMonitor := ap_data_get_struct(AMonitor);
  real.MakeFullyVisible( dl_AMonitor );
  result := This;
end;

function Form_print(This : Tvalue): Tvalue; cdecl;
var
  real: TMyForm;
begin
  real := ap_data_get_struct(This);
  real.Print;
  result := This;
end;

function Form_send_cancel_mode(This, Sender : Tvalue): Tvalue; cdecl;
var
  real: TMyForm;
  dl_Sender : TControl;
begin
  real := ap_data_get_struct(This);
  dl_Sender := ap_data_get_struct(Sender);
  real.SendCancelMode( dl_Sender );
  result := This;
end;
{$ENDIF}
function Form_get_drop_target(This: Tvalue): Tvalue; cdecl;
var
  real: TMyForm;
begin
  real := ap_data_get_struct(This);
  result := ap_Bool(real.DropTarget);
end;

(**** made by ap_src_maker ****)

procedure Init_Form;
begin
  RegisterClass(TPhiForm);
  PhiAllocFuncList.AddObject('TPhiForm', @ap_iForm_v);
  Init_PhiForm;

  OutputConstSetType(mPhi, TypeInfo(TWindowState));
  OutputConstSetType(mPhi, TypeInfo(TPosition));
  OutputConstSetType(mPhi, TypeInfo(TFormStyle));

  cForm := OutputPersistentClass(mPhi, TForm, cWinControl, ap_iForm_v);

  rb_define_method(cForm, 'event_handle', @Form_event_handle, 1);
  rb_define_alloc_func(cForm, @Form_allocate);
  rb_define_private_method(cForm, 'initialize', @Form_initialize, -1);
  rb_define_method(cForm, 'close', @Form_close, 0);
  rb_define_method(cForm, 'show', @Form_show, 0);
  rb_define_method(cForm, 'show_modal', @Form_show_modal, 0);
  // vcl: GetFormImage
{$IFDEF VCL}
  rb_define_method(cForm, 'get_bitmap', @Form_get_bitmap, 0);
{$ENDIF}

  DefineAttrGet(cForm, 'focus_control', Form_get_active_control);
  DefineAttrSet(cForm, 'focus_control', Form_set_active_control);
  DefineAttrGet(cForm, 'canvas', Form_get_canvas);
  DefineAttrGet(cForm, 'modal_result', Form_get_modal_result);
  DefineAttrSet(cForm, 'modal_result', Form_set_modal_result);
  DefineAttrGet(cForm, 'active', Form_get_active);
{$IFDEF VCL}
  rb_define_method(cForm, 'copy_data', @Form_copy_data, 2);
{$ENDIF}

  OutputAttrMethod_retval(cForm, 'on_close');
  OutputAttrMethod_retval(cForm, 'on_close_query');
//  OutputAttrMethod(cForm, 'on_create_params');
  OutputAttrMethod(cForm, 'on_drop_files');
  OutputAttrMethod(cForm, 'on_copy_data');
{$IFDEF VCL}
  DefineAttrGet(cForm, 'short_cut_enabled', Form_get_short_cut_enabled);
  DefineAttrSet(cForm, 'short_cut_enabled', Form_set_short_cut_enabled);
{$ENDIF}
{$IFDEF MSWINDOWS}
{$IFDEF VCL}
  rb_define_method(cForm, 'bring_to_front_ex', @Form_bring_to_front_ex, 0);
{$ENDIF}
{$ENDIF}
{$IFDEF VCL}
  DefineAttrGet(cForm, 'querying_end_session', Form_get_querying_end_session);
{$ENDIF}

(**** str3 made by ap_src_maker ****)
{$IFDEF VCL}
  rb_define_method(cForm, 'paint', @Form_paint, 0);
{$ENDIF}
  rb_define_method(cForm, 'request_align', @Form_request_align, 0);
  rb_define_method(cForm, 'update_actions', @Form_update_actions, 0);
{$IFDEF VCL}
  rb_define_method(cForm, 'update_window_state', @Form_update_window_state, 0);
{$ENDIF}
  rb_define_method(cForm, 'validate_rename', @Form_validate_rename, 3);
  DefineAttrGet(cForm, 'active_mdi_child', Form_get_active_mdi_child);
{$IFDEF VCL}
  rb_define_method(cForm, 'form_image', @Form_get_form_image, 0);
  rb_define_method(cForm, 'make_fully_visible', @Form_make_fully_visible, 1);
  rb_define_method(cForm, 'print', @Form_print, 0);
  rb_define_method(cForm, 'send_cancel_mode', @Form_send_cancel_mode, 1);
{$ENDIF}
  DefineAttrGet(cForm, 'drop_target', Form_get_drop_target);
  DefineAttrGet(cForm, 'drop_target?', Form_get_drop_target);
(**** made by ap_src_maker ****)
end;

end.
