unit uStrings;

interface

uses Classes, Rubies;

var
  cStrings, cStringList: Tvalue;

function ap_cStrings: Tvalue;
function ap_iStrings(real: TStrings; owner: Tvalue): Tvalue;
function dl_Strings(strings: Tvalue): TStrings;
function ap_StringList_new: Tvalue;
procedure Init_Strings;

implementation

uses SysUtils, uDefUtils, uIntern, uAlloc, uProp, uPhi, uConv, st, uPersistent;

function ap_cStrings: Tvalue;
begin
  result := cStrings;
end;

function Strings_alloc(klass: Tvalue; real: TStrings): Tvalue;
begin
  result := TmpAlloc(klass, real);
end;

function ap_iStrings(real: TStrings; owner: Tvalue): Tvalue;
begin
  result := Strings_alloc(cStrings, real);
  ap_owner(result, owner);
end;

function dl_Strings(strings: Tvalue): TStrings;
var
  len, i: Integer;
  ptr: Pvalue;

  function to_a_i(key, value, strings: Pointer): TSTRetval;
  begin
    result := stCONTINUE;
    if Tvalue(key) = Qundef then Exit;
    TStrings(strings).add(dl_String(Tvalue(key)) +'='+ dl_String(Tvalue(value)));
  end;

begin
  case RTYPE(strings) of
  T_ARRAY:
    begin
      result := dl_Strings(ap_StringList_new);
      len := ap_ary_len(strings);
      ptr := ap_ary_ptr(strings);
      for i := 0 to len-1 do
      begin
        result.add(dl_String(ptr^));
        Inc(ptr);
      end;
    end;
  T_HASH:
    begin
      result := dl_Strings(ap_StringList_new);
      st_foreach(PRHASH(strings)^.tbl, @to_a_i, result);
    end;
  T_DATA:
    ap_data_get_object(strings, TStrings, result);
  else
    ap_raise(ap_eArgError, sWrong_arg_type);
  end;
end;

function StringList_new(argc: integer; argv: Pointer; This: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
begin
  real := TStringList.Create;
  result := ObjAlloc(This, real);
  ap_obj_call_init(result, argc, argv);
end;

function ap_StringList_new: Tvalue;
begin
  result := StringList_new(0, nil, cStringList);
end;

function Strings_objects_useable(This: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
  i: Integer;
begin
  real := ap_data_get_struct(This);
  result := rb_iv_get(This,'@objects_useable');
  if result = Qnil then begin
    result := Qtrue;
    for i := 0 to real.Count-1 do begin
      if real.Objects[i] <> nil then begin
        result := Qfalse;
        break;
      end
    end;
    rb_iv_set(This,'@objects_useable', result);
  end;
end;

function Strings_aref(This, v: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
  i: Integer;
  S: string;
begin
  real := ap_data_get_struct(This);
  case RTYPE(v) of
  T_FIXNUM:
    begin
      i := FIX2INT(v);
      if i >= real.Count then
        ap_raise(ap_eIndexError, sOut_of_range);
      result := ap_String(real[i]);
    end;
  T_STRING:
    begin
      S := dl_String(v);
      result := ap_String(real.Values[S]);
    end;
  else
    ap_raise(ap_eArgError, sWrong_arg_type);
    result := Qnil; // avoid warning
  end;
end;

function Strings_aset(This, v, str: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
  i: Integer;
  S: string;
  cstr: string;
begin
  real := ap_data_get_struct(This);
  cstr := dl_String(str);
  case RTYPE(v) of
  T_FIXNUM:
    begin
      i := FIX2INT(v);
      if i >= real.Count then
        ap_raise(ap_eIndexError, sOut_of_range);
      real[i] := cstr;
    end;
  T_STRING:
    begin
      S := dl_String(v);
      real.Values[S] := cstr;
    end;
  else
    ap_raise(ap_eArgError, sWrong_arg_type);
  end;
  result := str;
end;

function Strings_get_count(This: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
begin
  real := ap_data_get_struct(This);
  result := INT2FIX(real.Count);
end;

function Strings_get_text(This: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
begin
  real := ap_data_get_struct(This);
  result := ap_String(real.Text);
end;

function Strings_set_text(This, v: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
begin
  real := ap_data_get_struct(This);
  real.Text := dl_String(v);
  result := v;
end;

function Strings_get_comma_text(This: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
begin
  real := ap_data_get_struct(This);
  result := ap_String(real.CommaText);
end;

function Strings_set_comma_text(This, v: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
begin
  real := ap_data_get_struct(This);
  real.CommaText := dl_String(v);
  result := v;
end;

function Strings_to_hash(This: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
  argc: Integer;
  i: Integer;
  name: string;
begin
  real := ap_data_get_struct(This);
  argc := real.Count;
  result := rb_hash_new;
  for i := 0 to argc-1 do
  begin
    name := real.Names[i];
    rb_hash_aset(result,
      rb_str_new2(PChar(name)),
      rb_str_new2(PChar(real.Values[name]))
    );
  end;
end;

function Strings_equals(argc: integer; argv: Pointer; This: Tvalue): Tvalue; cdecl;
var
  real, other: TStrings;
begin
  other := nil;
  case argc of
  1: other := ap_data_get_struct(Pvalue(argv)^);
  else
    ap_raise(ap_eArgError, sWrong_num_of_args);
  end;
  real := ap_data_get_struct(This);
  result := ap_bool(real.Equals(other));
end;

function Strings_add(argc: integer; argv: Pointer; This: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
  args: array of Tvalue;
  n: Integer;
  S: string;
begin
  if argc < 1 then
    ap_raise(ap_eArgError, sToo_few_args);
  SetLength(args, argc);
  args := argv;
  S := dl_String(args[0]);
  real := ap_data_get_struct(This);
  if argc > 1 then
  begin
    if (Strings_objects_useable(This) <> Qtrue) then
      ap_raise(ap_eArgError, 'objects not useable');
    n := real.AddObject(S, TObject(args[1]));
    rb_gc_mark(real.Objects[n]);
    result := INT2FIX(n)
  end
  else
    result := INT2FIX(real.Add(S));
end;

function Strings_add_strings(This, v: Tvalue): Tvalue; cdecl;
var
  real, other: TStrings;
begin
  real := ap_data_get_struct(This);
  ap_data_get_object(v, TStrings, other);
  real.AddStrings(other);
  result := This;
end;

function Strings_insert(argc: integer; argv: Pointer; This: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
  args: array of Tvalue;
  n: Integer;
  S: string;
begin
  if argc < 2 then
    ap_raise(ap_eArgError, sToo_few_args);
  SetLength(args, argc);
  args := argv;
  real := ap_data_get_struct(This);
  n := NUM2INT (args[0]);
  S := dl_String(args[1]);
  if (n < 0) or (real.Count <= n) then
    ap_raise(ap_eIndexError, sOut_of_range);
  if argc > 2 then
  begin
    if (Strings_objects_useable(This) <> Qtrue) then
      ap_raise(ap_eArgError, 'objects not useable');
    real.InsertObject(n, S, TObject(args[1]));
    rb_gc_mark(real.Objects[n]);
  end
  else
    real.Insert(n, S);
  result := This;
end;

function Strings_delete(This, index: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
begin
  real := ap_data_get_struct(This);
  real.Delete(NUM2INT(index));
  result := This;
end;

function Strings_move(This, cur, new: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
begin
  real := ap_data_get_struct(This);
  real.Move(NUM2INT(cur), NUM2INT(new));
  result := This;
end;

function Strings_clear(argc: integer; argv: Pointer; This: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
begin
  real := ap_data_get_struct(This);
  real.Clear;
  result := This;
end;

function Strings_object_at(This, index: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
begin
  real := ap_data_get_struct(This);
  if (Strings_objects_useable(This) = Qtrue)
    then result := Tvalue(real.Objects[NUM2INT(index)])
    else result := Qnil;
end;

function Strings_index_of(This, str: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
begin
  real := ap_data_get_struct(This);
  result := INT2FIX(real.IndexOf(dl_String(str)));
end;

function Strings_index_of_name(This, str: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
begin
  real := ap_data_get_struct(This);
  result := INT2FIX(real.IndexOfName(dl_String(str)));
end;

function Strings_index_of_object(This, obj: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
begin
  real := ap_data_get_struct(This);
  result := INT2FIX(real.IndexOfObject(TObject(obj)));
end;

function Strings_load(This, v: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
  stream: TStream;
begin
  real := ap_data_get_struct(This);
  case RTYPE(v) of
  T_STRING:
    try
      real.LoadFromFile(dl_String(v));
    except
      on E: EFOpenError do
        ap_raise(ap_eIOError, E.message);
    end;
  T_DATA:
    try
      ap_data_get_object(v, TStream, stream);
      real.LoadFromStream(stream);
    except
      on E: EReadError do;
    end;
  end;
  result := This;
end;

function Strings_save(This, v: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
  stream: TStream;
begin
  real := ap_data_get_struct(This);
  case RTYPE(v) of
  T_STRING:
    try
      real.SaveToFile(dl_String(v));
    except
      on E: EFCreateError do
        ap_raise(ap_eIOError, E.message);
    end;
  T_DATA:
    try
      ap_data_get_object(v, TStream, stream);
      real.SaveToStream(stream);
    except
      on E: EWriteError do;
    end;
  end;
  result := v;
end;

function ap_protect(proc: TGetValFunc; data: Tvalue; var state: Integer): Tvalue; cdecl;
begin
  result := rb_protect(proc, data, state);
end;

function ap_inspect(data: Tvalue): Tvalue; cdecl;
begin
  result := rb_inspect(data);
end;

function Strings_to_s(This: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
  S: string;
  obj, str: Tvalue;
  i: Integer;
  state: Integer;
  objects_useable: Boolean;
begin
  real := ap_data_get_struct(This);
  objects_useable := (Strings_objects_useable(This) = Qtrue);
  S := '#<' + dl_class_name_of(This) + ': ';
  for i := 0 to real.Count-1 do
  begin
    if i > 0 then S := S + ', ';
    S := S + AnsiQuotedStr(real[i], '"');
    if objects_useable and (real.Objects[i] <> nil) then
    begin
      obj := Tvalue(real.Objects[i]);
      if obj = This then
        S := S + '=>' + '(self)'
      else begin
        str := ap_protect(ap_inspect, obj, state);
        if state = 0 then S := S + '=>' + ap_str_ptr(str);
      end;
    end;
  end;
  S := S + '>';
  result := ap_String(S);
end;

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

function Strings_find(This, str: Tvalue): Tvalue; cdecl;
var
  real: TStringList;
  i: Integer;
begin
  real := TStringList(ap_data_get_struct(This));
  if real.Find(dl_String(str), i) then
    result := INT2FIX(i)
  else
    result := Qnil
  ;
end;

function Strings_update(This: Tvalue): Tvalue; cdecl;
var
  real: TStrings;
begin
  real := ap_data_get_struct(This);
  real.BeginUpdate;
  try
    result := rb_yield(Qnil);
  finally
    real.EndUpdate;
  end;
end;

procedure Init_Strings;
begin
  cStrings := rb_define_class_under(mPhi, 'Strings', cPersistent);
  OutputProp(cStrings, TStrings);

  rb_undef_method(CLASS_OF(cStrings), 'new');

  { properties }
  // vcl: strings, values
  rb_define_method(cStrings, '[]', @Strings_aref, 1);
  // vcl: strings, values
  rb_define_method(cStrings, '[]=', @Strings_aset, 2);

  DefineAttrGet(cStrings, 'count', Strings_get_count);
  DefineAttrGet(cStrings, 'text', Strings_get_text);
  DefineAttrSet(cStrings, 'text', Strings_set_text);
  DefineAttrGet(cStrings, 'comma_text', Strings_get_comma_text);
  DefineAttrSet(cStrings, 'comma_text', Strings_set_comma_text);

  // vcl: names, values
  DefineAttrGet(cStrings, 'to_hash', Strings_to_hash);
  { methods }
  DefineMethod(cStrings, 'equals', Strings_equals);
  DefineMethod(cStrings, '==', Strings_equals);
  DefineMethod(cStrings, '===', Strings_equals);
  DefineMethod(cStrings, 'add', Strings_add);
  rb_define_method(cStrings, 'add_strings', @Strings_add_strings, 1);
  DefineMethod(cStrings, 'insert', Strings_insert);
  rb_define_method(cStrings, 'delete', @Strings_delete, 1);
  rb_define_method(cStrings, 'move', @Strings_move, 2);
  DefineMethod(cStrings, 'clear', Strings_clear);
  rb_define_method(cStrings, 'object_at', @Strings_object_at, 1);
  rb_define_method(cStrings, 'index_of', @Strings_index_of, 1);
  rb_define_method(cStrings, 'index_of_name', @Strings_index_of_name, 1);
  rb_define_method(cStrings, 'index_of_object', @Strings_index_of_object, 1);
  // vcl: load_from_file, load_form_stream
  rb_define_method(cStrings, 'load', @Strings_load, 1);
  // vcl: save_to_file, save_to_stream
  rb_define_method(cStrings, 'save', @Strings_save, 1);
  rb_define_method(cStrings, 'assign', @Strings_assign, 1);
  rb_define_method(cStrings, 'find', @Strings_find, 1);
  rb_define_method(cStrings, 'update', @Strings_update, 0);
  rb_define_method(cStrings, 'objects_useable?', @Strings_objects_useable, 0);

  DefineAttrGet(cStrings, 'to_s', Strings_to_s);

  cStringList := rb_define_class_under(mPhi, 'StringList', cStrings);
  DefineSingletonMethod(cStringList, 'new', StringList_new);
end;

end.
