{ MSEgui Copyright (c) 1999-2013 by Martin Schreiber

    See the file COPYING.MSE, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
}
unit msesysutils;

{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
{$ifndef FPC}{$ifdef linux} {$define UNIX} {$endif}{$endif}

interface
uses
 mclasses,sysutils,msesystypes;

type
 eoserror = class(exception)
  public
   error: integer;
   constructor create(const leadingtext: string = ''); overload;
   constructor create(const errno: integer; const leadingtext: string = ''); overload;
    //shows getlasterror
 end;

 einternalerror = class(exception)
 end;
 
{$ifdef mswindows}
type
 timeval = record
  tv_sec: longword;
  tv_usec: longword;
 end;
{$endif}

function stdinputhandle: integer;
function stdoutputhandle: integer;
function stderrorhandle: integer;
procedure writestdout(value: string; newline: boolean = false);
procedure writestderr(value: string; newline: boolean = false);
procedure errorhalt(errortext: string; exitcode: integer = 1);
procedure debugwrite(const value: string);
procedure debugwriteln(const value: string);
procedure debugwritestack(const acount: integer = 30);
procedure debugout(const sender: tcomponent; const atext: ansistring); overload;
procedure debugout(const sender: tobject; const atext: ansistring); overload;
procedure debugoutstart(out ts: longword;
                   const sender: tcomponent; const atext: ansistring); overload;
procedure debugoutend(const ts: longword;
                   const sender: tcomponent; const atext: ansistring); overload;
procedure internalerror(const text: string);

function getlasterror: integer;
function getlasterrortext: string;
function syserrortext(const aerror: syserrorty): string;
           //returns getlasterortext for sye_lasterror
           
function later(ref,act: longword): boolean;
 //true if act > ref, with overflowcorrection
function laterorsame(ref,act: longword): boolean;
 //true if act >= ref, with overflowcorrection

procedure sleepus(const us: longword);
procedure waitus(us: integer);
function timestamp: longword; //us, 0 never reported
function timestep(us: longword): longword;   //bringt aktzeit + us
function timeout(time: longword): boolean;

function createguidstring: string;

procedure reallocmemandinit(var p: pointer; const newsize: sizeint);

implementation
uses
{$ifdef mswindows}
 windows,
{$else}
 mselibc,
{$endif}
 msesysintf1,msesysintf,msestrings,mseformatstr,msetypes,msesys,
 typinfo;

function createguidstring: string;
var
 id: tguid;
begin
 createguid(id);
 result:= guidtostring(id);
end;

{ eoserror }

constructor eoserror.create(const errno: integer; const leadingtext: string = '');
begin
 error:= errno;
 inherited create(leadingtext + 'OSError ' + inttostr(error) + ': ' + 
                                                   sys_geterrortext(error));
end;

constructor eoserror.create(const leadingtext: string);
begin
 create(getlasterror,leadingtext);
end;

function timestamp: longword;
begin
 result:= sys_gettimeus;
 if result = 0 then begin
  result:= 1;
 end;
end;

 {$ifdef UNIX}
{
function timestamp: longword;
var
 t1: timeval;
begin
 gettimeofday(t1,ptimezone(nil)^);
 result:= t1.tv_sec * 1000000 + t1.tv_usec;
 if result = 0 then begin
  result:= 1;
 end;
end;
}
procedure waitus(us: integer);
var
 time: longword;
begin
 time:= timestep(us);
 repeat
 until timeout(time);
end;

{$endif unix}

{$ifdef mswindows}
{
function timestamp: longword;
begin
 result:= gettickcount * 1000;
 if result = 0 then begin
  result:= 1;
 end;
end;
}
procedure waitperformancecounter(time: int64);
var
 time1: int64;
 len: longword;

begin
 if queryperformancecounter(time1) then begin
  len:= time1 + time;
  repeat
   queryperformancecounter(time1);
  until integer(dword(time1)-len) > 0;          //rollup
 end;
end;

procedure waitus(us: integer);
var
 freq: int64;
begin
 if us > 0 then begin
  queryperformancefrequency(freq);
  waitperformancecounter((freq*us) div 1000000);
 end;
end;

{$endif}

function timestep(us: longword): longword;   //bringt aktzeit + us
begin
 result:= timestamp + us;
end;

function timeout(time: longword): boolean;
begin
 result:= laterorsame(time,timestamp);
end;

function later(ref,act: longword): boolean;
var
 ca1: longword;
begin
 ca1:= act-ref;
 result:= integer(ca1) > 0;
// result:= integer(act-ref) > 0; //FPC bug 4768
end;

function laterorsame(ref,act: longword): boolean;
var
 ca1: longword;
begin
 ca1:= act-ref;
 result:= integer(ca1) >= 0;
// result:= integer(act-ref) > 0; //FPC bug 4768
end;

procedure sleepus(const us: longword);
begin
 sys_usleep(us);
end;

{$ifdef mswindows}
function stdinputhandle: integer;
begin
 result:= getstdhandle(std_input_handle);
 if result <= 0 then begin
  result:= invalidfilehandle;
 end;
end;

function stdoutputhandle: integer;
begin
 result:= getstdhandle(std_output_handle);
 if result <= 0 then begin
  result:= invalidfilehandle;
 end;
end;

function stderrorhandle: integer;
begin
 result:= getstdhandle(std_error_handle);
 if result <= 0 then begin
  result:= invalidfilehandle;
 end;
end;

{$else}

function stdinputhandle: integer;
begin
 result:= 0;
end;

function stdoutputhandle: integer;
begin
 result:= 1;
end;

function stderrorhandle: integer;
begin
 result:= 2;
end;

{$endif}
procedure writestdout(value: string; newline: boolean = false);
 {$ifdef mswindows}
var
 ca1: longword;
 {$endif}
begin
 if newline then begin
  value:= value + lineend;
 end;
 {$ifdef UNIX}
  sys_write(1,pointer(value),length(value));
 {$else}
  if getstdhandle(std_output_handle) <= 0 then begin
   allocconsole;
  end;
  writefile(getstdhandle(std_output_handle),pointer(value)^,length(value),ca1,nil);
 {$endif}
end;

procedure writestderr(value: string; newline: boolean = false);
 {$ifdef mswindows}
var
 ca1: longword;
 {$endif}
begin
 if newline then begin
  value:= value + lineend;
 end;
 {$ifdef UNIX}
  sys_write(2,pointer(value),length(value));
 {$else}
  if getstdhandle(std_error_handle) <= 0 then begin
   allocconsole;
  end;
  writefile(getstdhandle(std_error_handle),pointer(value)^,length(value),ca1,nil);
 {$endif}
end;

procedure debugwrite(const value: string);
begin
 writestderr(value,false);
end;

procedure debugwriteln(const value: string);
begin
 writestderr(value,true);
end;

procedure debugwritestack(const acount: integer = 30);
var
 int1: integer;
begin
{$ifdef FPC}
 int1:= raisemaxframecount;
 raisemaxframecount:= acount;
 try
  raise exception.create('');
 except
  debugwriteln(ansistring(getexceptiontext(exceptobject,
                           exceptaddr,exceptframecount,exceptframes)));
 end;
 raisemaxframecount:= int1;
{$endif}
end;

procedure debugout(const sender: tcomponent; const atext: ansistring);
begin
 if sender = nil then begin
  debugwriteln('NIL '+atext);
 end
 else begin
  debugwriteln(hextostr(ptruint(sender),8)+' '+
                      sender.name+':'+sender.classname+' '+atext);
 end;
end;

procedure debugout(const sender: tobject; const atext: ansistring);
begin
 if sender = nil then begin
  debugwriteln('NIL '+atext);
 end
 else begin
  debugwriteln(hextostr(ptruint(sender),8)+' '+
                      sender.classname+' '+atext);
 end;
end;

procedure debugoutstart(out ts: longword;
                   const sender: tcomponent; const atext: ansistring);
begin
 ts:= timestamp;
 debugout(sender,'*start '+atext);
end;

procedure debugoutend(const ts: longword;
                   const sender: tcomponent; const atext: ansistring);
begin
 debugout(sender,ansistring('**end '+formatfloatmse(
                           (timestamp-ts)/1000000,'0.000000')+'s '+
                                                        msestring(atext)));
end;

procedure internalerror(const text: string);
begin
 raise einternalerror.create('Internal error '+text);
end;

procedure errorhalt(errortext: string; exitcode: integer = 1);
begin
 writestderr(errortext,true);
 halt(exitcode);
end;

function getlasterror: integer;
begin
 result:= sys_getlasterror;
end;

function getlasterrortext: string;
var
 int1: integer;
begin
 int1:= sys_getlasterror;
 result:= inttostr(int1) + ': ' + sys_geterrortext(int1);
end;

function syserrortext(const aerror: syserrorty): string;
           //returns getlasterortext for sye_lasterror
begin
 case aerror of
  sye_lasterror: begin
   result:= getlasterrortext();
  end;
  else begin
   result:= getenumname(typeinfo(syserrorty),integer(aerror));
  end;
 end;
end;

procedure reallocmemandinit(var p: pointer; const newsize: sizeint);
var
 oldsize: ptrint;
begin
 oldsize:= 0;
 if p <> nil then begin
  oldsize:= memsize(p);
 end;
 reallocmem(p,newsize);
 fillchar((p+oldsize)^,newsize-oldsize,0);
end;

end.

