unit uFunc;

interface

uses Rubies;

procedure Init_Func;

implementation

uses
  SysUtils, Classes,
{$IFDEF VCL}
  Graphics, Controls, Menus,
  FileCtrl,
  Windows,  // GetRValue
{$ELSE}
  QGraphics, QControls, QMenus,
{$ENDIF}
  uStrUtils, uDefUtils, uDebug, uPhi, uConv, uError;

function Phi_color_to_rgb(This, col: Tvalue): Tvalue; cdecl;
begin
  result := ap_Integer(ColorToRGB(dl_Integer(col)));
end;

function Phi_color_to_rgb3(This, col: Tvalue): Tvalue; cdecl;
var
  rgb : longint;
begin
  rgb := ColorToRGB(dl_Integer(col));
  result := rb_ary_new;
  rb_ary_push(result, ap_Integer(GetRValue(rgb)));
  rb_ary_push(result, ap_Integer(GetGValue(rgb)));
  rb_ary_push(result, ap_Integer(GetBValue(rgb)));
end;

function Phi_color_to_string(This, col: Tvalue): Tvalue; cdecl;
var
  color: Integer;
  S: string;
begin
  color := FIX2INT(col);
  S := ColorToString(color);
  if S[1] = '$' then
    S := '0x' + LowerCase(Copy(S, 2, Length(S)-1))
  else
    S := UpperCase1(S)
  ;
  result := rb_str_new2(PChar(S));
end;

function Phi_cursor_to_string(This, cur: Tvalue): Tvalue; cdecl;
var
  S: string;
begin
  S := CursorToString(FIX2INT(cur));
  if S[1] = '$' then
    S := '0x' + LowerCase(Copy(S, 2, Length(S)-1))
  else
    S := UpperCase1(S)
  ;
  result := rb_str_new2(PChar(S));
end;

function Phi_string_to_cursor(This, str: Tvalue): Tvalue; cdecl;
var
  S: string;
begin
  S := dl_String(str);
  if S[1] = '0' then
  case S[2] of
  'x', 'X':
    S := '$' + Copy(S, 3, Length(S)-2);
  end;
  result := INT2FIX(StringToCursor(S));
end;

function Phi_set_capture_control(This, v: Tvalue): Tvalue; cdecl;
var
  control: TControl;
begin
  ap_data_get_object(v, TControl, control);
  SetCaptureControl(control);
  result := Qnil;
end;

function Phi_get_capture_control(This: Tvalue): Tvalue; cdecl;
begin
  result := GetCaptureControl.tag;
end;

function Phi_strip_hot_key(This, str: Tvalue): Tvalue; cdecl;
begin
  result := rb_str_new2(PChar(StripHotKey(dl_String(str))));
end;

function Phi_downcase(This, str: Tvalue): Tvalue; cdecl;
begin
  result := rb_str_new2(PChar(LowerCase1(dl_String(str))));
end;

function Phi_upcase(This, str: Tvalue): Tvalue; cdecl;
begin
  result := rb_str_new2(PChar(UpperCase1(dl_String(str))));
end;

function Phi_capitalize(This, str: Tvalue): Tvalue; cdecl;
begin
  result := rb_str_new2(PChar(Capitalize1(dl_String(str))));
end;

function Phi_get_debug(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_bool(debug_p);
end;

function Phi_set_debug(This, v: Tvalue): Tvalue; cdecl;
begin
  debug_p := RTEST(v);
  result := v;
end;

function Phi_ansi_extract_quoted_str(This, src, quote: Tvalue): Tvalue; cdecl;
var
  str: PChar;
  chr: Char;
begin
  str := PChar(dl_String(src));
  chr := NUM2CHR(quote);
  result := rb_str_new2(PChar(AnsiExtractQuotedStr(str, chr)));
end;

function Phi_get_components(This: Tvalue): Tvalue; cdecl;
begin
  result := vPhiComponents;
end;

function Phi_get_errors(This: Tvalue): Tvalue; cdecl;
begin
  result := vPhiErrors;
end;

function Phi_obj_bin_to_text(This, i, o: Tvalue): Tvalue; cdecl;
var
  istm, ostm: TStream;
begin
  ap_data_get_object(i, TStream, istm);
  ap_data_get_object(o, TStream, ostm);
  try
    ObjectBinaryToText(istm, ostm);
  except
    on E: Exception do
      ap_raise(eDelphiError, E.classname+': '+E.message);
  end;
  result := Qnil;
end;

function Phi_obj_text_to_bin(This, i, o: Tvalue): Tvalue; cdecl;
var
  istm, ostm: TStream;
begin
  ap_data_get_object(i, TStream, istm);
  ap_data_get_object(o, TStream, ostm);
  try
    ObjectTextToBinary(istm, ostm);
  except
    on E: Exception do
      ap_raise(eDelphiError, E.classname+': '+E.message);
  end;
  result := Qnil;
end;

function Phi_obj_res_to_text(This, i, o: Tvalue): Tvalue; cdecl;
var
  istm, ostm: TStream;
begin
  ap_data_get_object(i, TStream, istm);
  ap_data_get_object(o, TStream, ostm);
  try
    ObjectResourceToText(istm, ostm);
  except
    on E: Exception do
      ap_raise(eDelphiError, E.classname+': '+E.message);
  end;
  result := Qnil;
end;

function Phi_obj_text_to_res(This, i, o: Tvalue): Tvalue; cdecl;
var
  istm, ostm: TStream;
begin
  ap_data_get_object(i, TStream, istm);
  ap_data_get_object(o, TStream, ostm);
  try
    ObjectTextToResource(istm, ostm);
  except
    on E: Exception do
      ap_raise(eDelphiError, E.classname+': '+E.message);
  end;
  result := Qnil;
end;

{$IFDEF VCL}
function Phi_select_dir(This, cap, root, v: Tvalue): Tvalue; cdecl;
var
  S, RootDOS: string;
begin
  S := dl_String(v);
  RootDOS := StringReplace(dl_String(root), '/', '\', [rfReplaceAll]);
  result := ap_bool(SelectDirectory(dl_String(cap), RootDOS, S));
  rb_str_resize(v, 0);
  S := StringReplace(S, '\', '/', [rfReplaceAll]);
  ap_str_cat(v, S);
end;
{$ENDIF}

function Phi_force_dirs(This, dir: Tvalue): Tvalue; cdecl;
var
  DirDOS: string;
begin
  DirDOS := StringReplace(dl_String(dir), '/', '\', [rfReplaceAll]);
  result := Qnil;
  try
    result := ap_bool(ForceDirectories(DirDOS));
  except
    on E: Exception do
      ap_raise(ap_eRuntimeError, E.message);
  end;
end;

function Phi_set_stdin(This, v: Tvalue): Tvalue; cdecl;
begin
  ap_set_stdin(v);
  result := v;
end;

function Phi_short_cut_to_text(This, v: Tvalue): Tvalue; cdecl;
begin
  result := ap_String(ShortCutToText(TShortCut(dl_Integer(v))));
end;

function Phi_text_to_short_cut(This, v: Tvalue): Tvalue; cdecl;
begin
  result := ap_Fixnum(TextToShortCut(dl_String(v)));
end;

function Phi_short_cut_to_key(This, v: Tvalue): Tvalue; cdecl;
var
  Key: Word;
  Shift: TShiftState;
begin
  ShortCutToKey(TShortCut(dl_Integer(v)), Key, Shift);
  result := rb_assoc_new(ap_Fixnum(Key), ap_Set(Shift));
end;

procedure Init_Func;
begin
  rb_define_module_function(mPhi, 'color_to_rgb', @Phi_color_to_rgb, 1);
  rb_define_module_function(mPhi, 'color_to_rgb3', @Phi_color_to_rgb3, 1);
  rb_define_module_function(mPhi, 'color_to_string', @Phi_color_to_string, 1);
  rb_define_module_function(mPhi, 'cursor_to_string', @Phi_cursor_to_string, 1);
  rb_define_module_function(mPhi, 'string_to_cursor', @Phi_string_to_cursor, 1);
  rb_define_module_function(mPhi, 'set_capture_control', @Phi_set_capture_control, 1);
  rb_define_module_function(mPhi, 'get_capture_control', @Phi_get_capture_control, 0);
  rb_define_module_function(mPhi, 'strip_hot_key', @Phi_strip_hot_key, 1);
  rb_define_module_function(mPhi, 'downcase', @Phi_downcase, 1);
  rb_define_module_function(mPhi, 'upcase', @Phi_upcase, 1);
  rb_define_module_function(mPhi, 'capitalize', @Phi_capitalize, 1);
  DefineModuleAttrGet(mPhi, 'debug', Phi_get_debug);
  DefineModuleAttrSet(mPhi, 'debug', Phi_set_debug);
  rb_define_module_function(mPhi, 'ansi_extract_quoted_str', @Phi_ansi_extract_quoted_str, 2);
  DefineModuleAttrGet(mPhi, 'components', Phi_get_components);
  DefineModuleAttrGet(mPhi, 'errors', Phi_get_errors);

  rb_define_module_function(mPhi, 'obj_bin_to_text', @Phi_obj_bin_to_text, 2);
  rb_define_module_function(mPhi, 'obj_text_to_bin', @Phi_obj_text_to_bin, 2);
  rb_define_module_function(mPhi, 'obj_res_to_text', @Phi_obj_res_to_text, 2);
  rb_define_module_function(mPhi, 'obj_text_to_res', @Phi_obj_text_to_res, 2);

{$IFDEF VCL}
  rb_define_module_function(mPhi, 'select_dir', @Phi_select_dir, 3);
{$ENDIF}
  rb_define_module_function(mPhi, 'force_dirs', @Phi_force_dirs, 1);

  DefineModuleAttrSet(mPhi, 'stdin', Phi_set_stdin);

  rb_define_module_function(mPhi, 'short_cut_to_text', @Phi_short_cut_to_text, 1);
  rb_define_module_function(mPhi, 'text_to_short_cut', @Phi_text_to_short_cut, 1);
  rb_define_module_function(mPhi, 'short_cut_to_key', @Phi_short_cut_to_key, 1);
end;

end.
