unit uClipboard;

interface

uses
  SysUtils, Classes,
{$IFDEF VCL}
  Clipbrd,
{$ELSE}
  QClipbrd,
{$ENDIF}
  Rubies;

var
  cClipboard: Tvalue;
  vClipboard: Tvalue;

function ap_cClipboard: Tvalue;
procedure Init_Clipboard;

implementation

uses
{$IFDEF MSWINDOWS}
  Windows,
{$ENDIF}
  uConv, uStrUtils, uDefUtils, uPhi, uAlloc, uProp;

function ap_cClipboard: Tvalue;
begin
  result := cClipboard;
end;

{$IFDEF VCL}
function Clipboard_get_Formats(This: Tvalue): Tvalue; cdecl;
var
  real: TClipboard;
  I: Integer;
begin
  real := ap_data_get_struct(This);
  result := rb_ary_new;
  for I := 0 to real.FormatCount-1 do
    rb_ary_push(result, INT2FIX(real.Formats[I]));
end;

function Clipboard_get_Format_count(This: Tvalue): Tvalue; cdecl;
var
  real: TClipboard;
begin
  real := ap_data_get_struct(This);
  result := INT2FIX(real.FormatCount);
end;

function Clipboard_lock(This: Tvalue): Tvalue; cdecl;
var
  real: TClipboard;
begin
  real := ap_data_get_struct(This);
  real.Open;
  try
    result := rb_yield(Qnil);
  finally
    real.Close;
  end;
end;
{$ENDIF}

function Clipboard_clear(This: Tvalue): Tvalue; cdecl;
var
  real: TClipboard;
begin
  real := ap_data_get_struct(This);
  real.Clear;
  result := This;
end;

function Clipboard_get_text(This: Tvalue): Tvalue; cdecl;
var
  real: TClipboard;
begin
  real := ap_data_get_struct(This);
  result := Qnil;
  try
    result := rb_str_new2(PChar(real.AsText));
  except
    on E: Exception do
      ap_raise(ap_eStandardError, E.message);
  end;
end;

function Clipboard_set_text(This, v: Tvalue): Tvalue; cdecl;
var
  real: TClipboard;
begin
  real := ap_data_get_struct(This);
  real.AsText := dl_String(v);
  result := v;
end;

{$IFDEF VCL}
function Clipboard_has_format(This, format: Tvalue): Tvalue; cdecl;
var
  real: TClipboard;
begin
  real := ap_data_get_struct(This);
  result := ap_bool(real.HasFormat(FIX2INT(format)));
end;
{$ENDIF}

function Clipboard_assign(This, v: Tvalue): Tvalue; cdecl;
var
  real: TClipboard;
  source: TPersistent;
begin
  real := ap_data_get_struct(This);
  ap_data_get_object(v, TPersistent, source);
  real.Assign(source);
  result := v;
end;

function Clipboard_instance(This: Tvalue): Tvalue; cdecl;
begin
  result := vClipboard;
end;

procedure Regist_Clipboard;
var
  real: TClipboard;
  obj: Tvalue;
begin
  real := Clipboard;
  obj := TmpAlloc(cClipboard, real);
  vClipboard := obj;
  rb_define_const(mPhi, 'CLIPBOARD', obj);
end;

procedure Init_Clipboard;
begin
{$IFDEF VCL}
  rb_define_const(mPhi, 'CF_TEXT', INT2FIX(CF_TEXT));
  rb_define_const(mPhi, 'CF_BITMAP', INT2FIX(CF_BITMAP));
  rb_define_const(mPhi, 'CF_METAFILEPICT', INT2FIX(CF_METAFILEPICT));
  rb_define_const(mPhi, 'CF_PICTURE', INT2FIX(CF_PICTURE));
  rb_define_const(mPhi, 'CF_COMPONENT', INT2FIX(CF_COMPONENT));
{$ENDIF}

  cClipboard := rb_define_class_under(mPhi, 'Clipboard', ap_cObject);
  OutputProp(cClipboard, TClipboard);

  rb_undef_method(CLASS_OF(cClipboard), 'new');
  rb_define_singleton_method(cClipboard, 'instance', @Clipboard_instance, 0);

{$IFDEF VCL}
  DefineAttrGet(cClipboard, 'formats', Clipboard_get_formats);
  DefineAttrGet(cClipboard, 'format_count', Clipboard_get_format_count);

  // vcl: Open, Close
  rb_define_method(cClipboard, 'lock', @Clipboard_lock, 0);
{$ENDIF}
  rb_define_method(cClipboard, 'clear', @Clipboard_clear, 0);
  // vcl: AsText
  DefineAttrGet(cClipboard, 'text', Clipboard_get_text);
  DefineAttrSet(cClipboard, 'text', Clipboard_set_text);
{$IFDEF VCL}
  rb_define_method(cClipboard, 'has_format?', @Clipboard_has_format, 1);
{$ENDIF}
  rb_define_method(cClipboard, 'assign', @Clipboard_assign, 1);

  Regist_Clipboard;
end;

end.

