unit uIO;

interface

uses Rubies;

var
  Stdout: TGetStrProc;
  gets: TRetStrFunc;
  getc: TRetChrFunc;
  cIO: Tvalue;

function Phi_write(This, str: Tvalue): Tvalue; cdecl;
function Phi_gets(This: Tvalue): Tvalue; cdecl;
function Phi_getc(This: Tvalue): Tvalue; cdecl;
function Phi_flush(This: Tvalue): Tvalue; cdecl;
function Phi_close(This: Tvalue): Tvalue; cdecl;
function Phi_undef_stdio(This: Tvalue): Tvalue; cdecl;
procedure io_stdout(S: string);
function io_gets: string;
function io_getc: Char;
procedure Init_IO;

implementation

uses
  uConv,
{$IFDEF LINUX}
  Types,
{$ENDIF}
{$IFDEF MSWINDOWS}
  Windows,
{$ENDIF}
  SysUtils, Classes, uPhi
{$IFDEF RUBY18}
  , uAlloc
{$ENDIF}
  ;

function Phi_write(This, str: Tvalue): Tvalue; cdecl;
var
  len: Integer;
begin
asm
  FInit;
end;
  len := 0;
  if @Stdout <> nil then
  begin
    if RTYPE(str) <> T_STRING then str := rb_obj_as_string(str); { to_s }
    len := ap_str_len(str);
    if len <> 0 then Stdout(dl_String(str));
  end;
  result := INT2FIX(len);
end;

function Phi_gets(This: Tvalue): Tvalue; cdecl;
var
  S: string;
begin
asm
  FInit;
end;
  result := Qnil;
  if @gets <> nil then
  begin
    S := gets;
    if Length(S) <> 0 then result := rb_str_new2(PChar(S));
  end;
  rb_lastline_set(result); // $_ set
end;

function Phi_getc(This: Tvalue): Tvalue; cdecl;
var
  c: Char;
begin
asm
  FInit;
end;
  result := Qnil;
  if @getc <> nil then
  begin
    c := getc;
    if c <> #0 then result := CHR2FIX(c);
  end;
end;

function Phi_flush(This: Tvalue): Tvalue; cdecl;
begin
{$IFDEF MSWINDOWS}
  FlushFileBuffers(GetStdHandle(STD_OUTPUT_HANDLE));
{$ENDIF}
  result := This;
end;

function Phi_close(This: Tvalue): Tvalue; cdecl;
begin
{$IFDEF MSWINDOWS}
  FlushFileBuffers(GetStdHandle(STD_OUTPUT_HANDLE));
{$ENDIF}
  result := Qnil;
end;

function Phi_undef_stdio(This: Tvalue): Tvalue; cdecl;
begin
  ap_set_stdin(Qnil);
  ap_set_stdout(Qnil);
  ap_set_stderr(Qnil);
{$IFNDEF RUBY18}
  ap_set_defout(Qnil);
{$ENDIF}
  result := Qnil;
end;

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

function Phi_readlines(This: Tvalue): Tvalue; cdecl;
var
  S: string;
begin
asm
  FInit;
end;
  Result := rb_ary_new();
  if @gets <> nil then
  begin
    S := gets;
    while Length(S) <> 0 do
    begin
      rb_ary_push(Result, rb_str_new2(PChar(S)));
      S := gets;
    end;
  end;
end;

procedure io_stdout(S: string);
{$IFDEF MSWINDOWS}
var
  Stream: TStream;
{$ENDIF}
begin
{$IFDEF LINUX}
  write(S);
{$ENDIF}
{$IFDEF MSWINDOWS}
  try
    Stream := THandleStream.Create(GetStdHandle(STD_OUTPUT_HANDLE));
  try
    Stream.WriteBuffer(Pointer(S)^, Length(S));
  finally
    Stream.Free;
  end;
  except
    on E: Exception do;
  end;
{$ENDIF}
end;

function io_gets: string;
var
  S: string;
begin
  try
    ReadLn(S);
    if Length(S) <> 0 then // 0 if \C-z. Eof cannot use This case.
      if S[1] = #4{\C-d} then SetLength(S, 0)
      else S := S + #10;
    result := S;
  except
    on E: Exception do;
  end;
end;

function io_getc: Char;
var
  c: Char;
begin
  try
    Read(c);
    result := c;
  except
    on E: Exception do result := #0;
  end;
end;

procedure Regist_IO;
var
  fnum: Tvalue;
  obj: Tvalue;
begin
  fnum := INT2FIX(0);
  obj := rb_class_new_instance(1, @fnum, cIO);
{$IFNDEF RUBY18}
  PRFile(obj)^.fptr^.mode := rb_io_mode_flags('rb+');
{$ENDIF}
  rb_define_const(mPhi, 'IO', obj);
  ap_set_stdin(obj);
  ap_set_stdout(obj);
  ap_set_stderr(obj);
{$IFNDEF RUBY18}
  ap_set_defout(obj);
{$ENDIF}
end;

{$IFDEF RUBY18}
function io_alloc(This: Tvalue): Tvalue; cdecl;
begin
  Result := ObjAlloc(This, TObject.Create);
end;

function io_initialize(argc: integer; argv: Pointer; This: Tvalue): Tvalue; cdecl;
begin
  Result := Qnil;
end;
{$ENDIF}

procedure Init_IO;
begin
  cIO := rb_define_class_under(mPhi, 'IOHook', ap_cIO);
{$IFDEF RUBY18}
  rb_define_alloc_func(cIO, io_alloc);
  rb_define_method(cIO, 'initialize', @io_initialize, -1);
{$ENDIF}
  rb_define_method(cIO, 'write', @Phi_write, 1);
  rb_define_method(cIO, 'gets', @Phi_gets, 0);
  rb_define_method(cIO, 'getc', @Phi_getc, 0);
  rb_define_method(cIO, 'flush', @Phi_flush, 0);
  rb_define_method(cIO, 'close', @Phi_close, 0);
  rb_define_method(cIO, 'binmode', @Phi_binmode, 0);
  rb_define_method(cIO, 'readlines', @Phi_readlines, 0);
  Regist_IO;
end;

end.
