path: root/packages/libsee/examples/mod_stream.pp

unit mod_stream;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, libsee;

Procedure RegisterStreamModule;
Procedure RegisterWriteModule;

implementation

{ ---------------------------------------------------------------------
  General auxiliary functions
  ---------------------------------------------------------------------}

Function ValueToString(V : TSee_Value) : string;

Var
  PS : Ptcuint;
  PD : PChar;
  I : Integer;

begin
  SetLength(Result,v.u._string^.length);
  If Length(Result)<>0 then
    begin
    PD:=PChar(Result);
    PS:=v.u._string^.data;
    For I:=0 to length(Result)-1 do
      begin
      PD^:=Char(PS^ and $ff);
      Inc(PD);
      Inc(PS);
      end;
    end;
end;

Procedure CreateJSObject(Interp : PSEE_Interpreter; Parent : PSEE_Object;AName : PSEE_String; Obj : PSee_Object);

var
  V : PSEE_Value;

begin
  v:=new_see_value;
  see_set_object(V,Obj);
  see_object_put(interp,parent,AName,V,SEE_ATTR_DEFAULT);
end;

Procedure CreateJSNumber(Interp : PSEE_Interpreter; Obj : PSee_Object; AName : PSEE_String; AValue : TSEE_number_t);

var
  V : PSEE_Value;

begin
  v:=new_SEE_value;
  see_set_number(V,AValue);
  see_object_put(Interp,Obj,AName,v,SEE_ATTR_DEFAULT);
end;

Procedure CreateJSFunction(Interp : PSEE_Interpreter; Obj : PSee_Object; Func : TSEE_call_fn_t; AName : PSEE_String; Len : Integer);

var
  V : PSEE_Value;

begin
  v:=new_SEE_value;
  see_set_object(V,see_cfunction_make(interp,Func,AName,len));
  see_object_put(Interp,Obj,AName,v,SEE_ATTR_DEFAULT);
end;

{ ---------------------------------------------------------------------
  Stream module support
  ---------------------------------------------------------------------}
Var
  StreamModule : TSEE_module;
  StreamObjectDef,
  StreamPrototypeDef : PSEE_objectclass;

  WriteModule : TSEE_module;

Type
  TStreamModuleData = record
    Stream : PSEE_object;
    Prototype :  PSEE_object;
    Error : PSEE_object;
  end;
  PStreamModuleData = ^TStreamModuleData;

  TStreamObject = record
    native : TSEE_native;
    Stream : TStream;
  end;
  PSTreamObject = ^TStreamObject;

Var
  GStreamRead,
  GStreamWrite,
  GStreamSeek,
  GStreamSize,
  GStreamPosition,
  GStreamFree,
  GStreamfmCreate,
  GStreamfmOpenRead,
  GStreamfmOpenWrite,
  GStreamfmOpenReadWrite,
  GStreamStream,
  GStreamError,
  GStreamPrototype : PSEE_String;

Procedure StreamAlloc(Interp : PSEE_Interpreter); cdecl;

begin
  PPointer(see_module_private(Interp,@StreamModule))^:=new(PStreamModuleData);
end;

Function PrivateData(Interp : PSEE_Interpreter) : PStreamModuleData;
begin
  Result:=PStreamModuleData((see_module_private(Interp,@StreamModule))^)
end;

Function AsFile(i:PTSEE_interpreter; obj:PTSEE_object) : PStreamObject;

begin
  If (Not Assigned(obj)) or (Obj^.objectclass<>StreamPrototypeDef) then
      SEE_error__throw0(i,I^.TypeError,Nil);
  Result:=PStreamObject(Obj)
end;

procedure StreamSize (i:PTSEE_interpreter; obj:PTSEE_object; thisobj:PTSEE_object; argc:Tcint; argv:PPTSEE_value;
             res:PTSEE_value);cdecl;

Var
  S : PStreamObject;

begin
  S:=AsFile(I,ThisObj);
  If (S^.Stream=Nil) then
    SEE_error__throw0(i,PrivateData(I)^.Error,Nil);
  SEE_SET_NUMBER(res,S^.Stream.Size);
end;


procedure StreamWrite (i:PTSEE_interpreter; obj:PTSEE_object; thisobj:PTSEE_object; argc:Tcint; argv:PPTSEE_value;
             res:PTSEE_value);cdecl;

Var
  S : PStreamObject;
  v : TSEE_Value;
  t : string;

begin
  S:=AsFile(I,ThisObj);
  If (S^.Stream=Nil) then
    SEE_error__throw0(i,PrivateData(I)^.Error,'File is closed');
  if (ArgC=0) then
    SEE_error__throw0(i,I^.RangeError,'Missing argument');
  SEE_ToString(i,argv[0], @v);
  T:=ValueToString(V);
  If Length(T)>0 then
    S^.Stream.Write(T[1],Length(T));
end;

procedure StreamPosition (i:PTSEE_interpreter; obj:PTSEE_object; thisobj:PTSEE_object; argc:Tcint; argv:PPTSEE_value;
             res:PTSEE_value);cdecl;

Var
  S : PStreamObject;
  v : TSEE_Value;
  t : string;

begin
  S:=AsFile(I,ThisObj);
  If (S^.Stream=Nil) then
    SEE_error__throw0(i,PrivateData(I)^.Error,'File is closed');
  SEE_SET_NUMBER(res,S^.Stream.Position);
end;

procedure StreamSeek (i:PTSEE_interpreter; obj:PTSEE_object; thisobj:PTSEE_object; argc:Tcint; argv:PPTSEE_value;
             res:PTSEE_value);cdecl;

Var
  S : PStreamObject;
  v : TSEE_Value;
  newpos : integer;

begin
  S:=AsFile(I,ThisObj);
  If (S^.Stream=Nil) then
    SEE_error__throw0(i,PrivateData(I)^.Error,'File is closed');
  if (ArgC=0) then
    SEE_error__throw0(i,I^.RangeError,'Missing argument');
  newpos:=SEE_ToUint32(i,argv[0]);
  SEE_SET_NUMBER(res,S^.Stream.Seek(soFromBeginning,newpos));
end;

procedure StreamRead (i:PTSEE_interpreter; obj:PTSEE_object; thisobj:PTSEE_object; argc:Tcint; argv:PPTSEE_value;
             res:PTSEE_value);cdecl;

Var
  S : PStreamObject;
  r : PSEE_String;
  j,maxlen : integer;
  c : char;

begin
  S:=AsFile(I,ThisObj);
  If (S^.Stream=Nil) then
    SEE_error__throw0(i,PrivateData(I)^.Error,'File is closed');
  if (ArgC=0) then
    maxlen:=1024
  else
    maxlen:=see_touint32(I,argv[0]);
  r:=see_string_new(I,maxlen);
  For j:=0 to maxLen-1 do
    begin
    S^.stream.Read(c,sizeOf(c));
    SEE_string_addch(R,ord(c));
    end;
  SEE_SET_STRING(Res,r);
end;

procedure StreamFree (i:PTSEE_interpreter; obj:PTSEE_object; thisobj:PTSEE_object; argc:Tcint; argv:PPTSEE_value;
             res:PTSEE_value);cdecl;

Var
  S : PStreamObject;
  v : TSEE_Value;
  t : string;

begin
  S:=AsFile(I,ThisObj);
  If (S^.Stream=Nil) then
    SEE_error__throw0(i,PrivateData(I)^.Error,'File is closed');
  FreeAndNil(S^.Stream);
  SEE_SET_UNDEFINED(Res);
end;

procedure StreamFinalize ( i:PTSEE_interpreter; p:pointer; closure:pointer);cdecl;

begin
  FreeAndNil(PStreamObject(P)^.Stream);
end;

procedure StreamConstruct (i:PTSEE_interpreter; obj:PTSEE_object; thisobj:PTSEE_object; argc:Tcint; argv:PPTSEE_value;
             res:PTSEE_value);cdecl;

Var
  P : PChar;
  fm : Integer;
  S : TStream;
  Err : String;
  R : PTSEE_Object;

begin
  SEE_parse_args(i,argc,argv,'Z|i',@p,@fm);
  If (P=Nil) then
    SEE_error__throw0(i,I^.RangeError,'Missing argument');
  Err:='';
  try
    S:=TFileStream.Create(strpas(p),fm);
  except
    On E : Exception do
      Err:=E.Message;
  end;
  If (Err<>'') then
    SEE_error__throw0(i,PrivateData(I)^.Error,PChar(Err));
  R:=PTSEE_Object(SEE_malloc_finalize(I,SizeOf(TStreamObject),@StreamFinalize,Nil));
  SEE_Native_init(PSEE_Native(R),I,StreamPrototypeDef,PrivateData(I)^.Prototype);
  PStreamObject(r)^.Stream:=S;
  SEE_SET_OBJECT(Res,R);
end;



Procedure StreamInit(Interp : PSEE_Interpreter); cdecl;

Var
  Stream,
  StreamPrototype,
  StreamError : PSee_object;
begin
//  writeln('Initializing stream');
  // Construct Stream.prototype object
//  writeln('Creating Stream Prototype ');
  StreamPrototype:=PSEE_object(SEE_malloc(Interp,SizeOf(TSTreamObject)));
  See_native_init(PSEE_native(StreamProtoType),Interp,StreamPrototypeDef,interp^.Object_prototype);
  PSTreamObject(StreamPrototype)^.stream:=Nil;
  createJSFUnction(Interp,StreamPrototype,@StreamRead,GStreamRead,0);
  createJSFUnction(Interp,StreamPrototype,@StreamWrite,GStreamWrite,0);
  createJSFUnction(Interp,StreamPrototype,@StreamSize,GStreamSize,0);
  createJSFUnction(Interp,StreamPrototype,@StreamPosition,GStreamPosition,0);
  createJSFUnction(Interp,StreamPrototype,@StreamSeek,GStreamSeek,0);
  createJSFUnction(Interp,StreamPrototype,@StreamFree,GStreamFree,0);
//  writeln('Creating Stream');
  // Construct Stream object
  Stream:=PSEE_object(new_see_native);
  See_native_init(PSEE_native(Stream),Interp,StreamObjectDef,interp^.Object_prototype);
  CreateJSObject(Interp,Interp^.Global,GStreamStream,Stream);
  CreateJSObject(Interp,Stream,GStreamprototype,StreamPrototype);
  CreateJSNumber(Interp,Stream,GStreamfmCreate,fmCreate);
  CreateJSNumber(Interp,Stream,GStreamfmOpenRead,fmOpenRead);
  CreateJSNumber(Interp,Stream,GStreamfmOpenWrite,fmOpenWrite);
  CreateJSNumber(Interp,Stream,GStreamfmOpenReadWrite,fmOpenReadWrite);
  StreamError:=SEE_Error_make(interp, GSTreamError);
  PrivateData(Interp)^.Stream:=STream;
  PrivateData(Interp)^.Prototype:=StreamPrototype;
  PrivateData(Interp)^.Error:=StreamError;
//  writeln('Done initializing stream');
end;

Procedure AllocateStreamStrings;

begin
  GStreamRead:=SEE_intern_global('Read');
  GStreamWrite:=SEE_intern_global('Write');
  GStreamSeek:=SEE_intern_global('Seek');
  GStreamSize:=SEE_intern_global('Size');
  GStreamPosition:=SEE_intern_global('Position');
  GStreamFree:=SEE_intern_global('Free');
  GStreamfmCreate:=SEE_intern_global('fmCreate');
  GStreamfmOpenRead:=SEE_intern_global('fmOpenRead');
  GStreamfmOpenWrite:=SEE_intern_global('fmOpenWrite');
  GStreamfmOpenReadWrite:=SEE_intern_global('fmOpenReadWrite');
  GStreamStream:=SEE_intern_global('Stream');
  GStreamError:=SEE_intern_global('Error');
  GStreamPrototype:=SEE_intern_global('prototype');
end;

Function StreamInitModule : Integer; cdecl;

begin
//  writeln('Initializing module');
  StreamPrototypeDef:=new_SEE_objectclass;
  With StreamPrototypeDef^ do
    begin
    _Class:='Stream';
    get:=SEE_native_get;
    put:=SEE_native_put;
    canput:=SEE_native_canput;
    hasproperty:=SEE_native_hasproperty;
    Delete:=SEE_native_delete;
    DefaultValue:=SEE_native_defaultvalue;
    ENumerator:=SEE_native_enumerator;
    Construct:=Nil;
    Call:=Nil;
    HasInstance:=Nil;
    end;
  StreamObjectDef:=new_SEE_objectclass;
  With StreamObjectDef^ do
    begin
    _Class:='Stream';
    get:=SEE_native_get;
    put:=SEE_native_put;
    get:=SEE_native_get;
    put:=SEE_native_put;
    canput:=SEE_native_canput;
    hasproperty:=SEE_native_hasproperty;
    Delete:=SEE_native_delete;
    DefaultValue:=SEE_native_defaultvalue;
    ENumerator:=SEE_native_enumerator;
    Construct:=@StreamConstruct;
    Call:=Nil;
    HasInstance:=Nil;
    end;
  AllocateStreamStrings;
//  writeln('Done Initializing module');
  Result:=0;
end;

Procedure RegisterStreamModule;

begin
//  writeln('Registering stream module');
//  StreamModule:=new_SEE_module;
  With StreamModule do
    begin
    magic:=SEE_MODULE_MAGIC;
    name:='Stream';
    version:='1.0';
    Index:=0;
    Mod_init:=@StreamInitModule;
    alloc:=@StreamAlloc;
    init:=@StreamInit
    end;
  SEE_module_add(@StreamModule);
end;

{ ---------------------------------------------------------------------
  Write(ln) module support
  ---------------------------------------------------------------------}

procedure WriteWrite (i:PTSEE_interpreter; obj:PTSEE_object; thisobj:PTSEE_object; argc:Tcint; argv:PPTSEE_value;
             res:PTSEE_value);cdecl;

Var
  a,C : Integer;
  t : string;
  v : TSEE_Value;

begin
  if (ArgC=0) then
    SEE_error__throw0(i,I^.RangeError,'Missing argument');
  C:=0;
  For A:=0 to Argc-1 do
    begin
    SEE_ToString(i,argv[a], @v);
    T:=ValueToString(V);
    If Length(T)>0 then
      begin
      Write(T);
      C:=C+Length(T);
      end;
    end;
  SEE_SET_NUMBER(Res,C);
end;

procedure WriteWriteln (i:PTSEE_interpreter; obj:PTSEE_object; thisobj:PTSEE_object; argc:Tcint; argv:PPTSEE_value;
             res:PTSEE_value);cdecl;


begin
  if (Argc>0) then
    WriteWrite(i,obj,thisobj,argc,argv,res)
  else
    SEE_SET_NUMBER(Res,0);
  Writeln;
end;

Var
  GWriteWrite   : PSEE_STRING;
  GWriteWriteln : PSEE_STRING;

Procedure WriteInit(Interp : PSEE_Interpreter); cdecl;

begin
//  writeln('Initializing write');
  createJSFUnction(Interp,Interp^.Global,@WriteWrite,GWriteWrite,1);
  createJSFUnction(Interp,Interp^.Global,@WriteWriteln,GWriteWriteln,1);
//  writeln('Done initializing write');
end;

Procedure AllocateWriteStrings;

begin
  GWriteWrite:=SEE_intern_global('write');
  GWriteWriteln:=SEE_intern_global('writeln');
end;

Function WriteInitModule : Integer; cdecl;
begin
  Result:=0;
end;

Procedure RegisterWriteModule;

begin
//  writeln('Registering write module');
//  StreamModule:=new_SEE_module;
  With WriteModule do
    begin
    magic:=SEE_MODULE_MAGIC;
    name:='Write';
    version:='1.0';
    Index:=0;
    Mod_init:=@WriteInitModule;
    alloc:=Nil;
    init:=@WriteInit
    end;
  AllocateWriteStrings;
  SEE_module_add(@WriteModule);
end;


end.