unit lowlevelunit; {$mode objfpc}{$H+} interface uses math, Classes, SysUtils, gmp, RegExpr, process, FPimage; type generic tArray = array of T; tLongintArray = specialize tArray; pTLongintArray = ^tLongintArray; tSingleArray = specialize tArray; pTSingleArray = ^tSingleArray; tIntPoint = array['x'..'y'] of longint; tExtPoint = array['x'..'y'] of extended; t2x2Longint = array['x'..'y','x'..'y'] of longint; t2x2Extended = array['x'..'y','x'..'y'] of extended; tExtPointArray = specialize tArray; pTExtPointArray = ^tExtPointArray; tExtendedArray = specialize tArray; pTExtendedArray = ^tExtendedArray; tDoubleArray = specialize tArray; tInt32Array = specialize tArray; tByteArray = specialize tArray; tStringArray = specialize tArray; tIntPointArray = specialize tArray; tRGB = record rgbBlue : byte; rgbGreen: byte; rgbRed : byte; end; tRgbArray = specialize tArray; tKodierung = (kUnbekannt,k32BitSignedInteger); tWarnstufe = (wsStreng,wsLasch); tGenauigkeit = (gSingle,gDouble,gExtended); function signSqr(x: extended): extended; inline; function mpfToStr(f: mpf_t): string; function myTimeToStr(t: extended): string; function cpuUtilization: extended; function numCpus: int64; function momentanFreieCpus: int64; function mpfMyRoot(rad: mpf_t; wzlExp: int64): extended; function belegterSpeicher: int64; function minCache: int64; function cmpStr(s1,s2: string): longint; function mitte(s1,s2: string): string; function myFloatToStr(x: extended): string; overload; function myFloatToStr(x: extended; ex: string): string; overload; function myStrToFloat(s: string): extended; function myIntToStr(i,dg: longint): string; overload; function myIntToStr(i,dg: longint; fill: string): string; overload; function max(g1,g2: tGenauigkeit): tGenauigkeit; overload; function wertGroesze(g: tGenauigkeit): longint; function floattostrtrunc(f: extended; dig: longint; laessig: boolean): string; function binOpPos(op: char; s: string): integer; function fktPos(fkt,s: string): integer; procedure gibAus(s: string; ausgaben: byte); function strToGen(out gen: tGenauigkeit; s: string): boolean; function orFarben(a,b: tRGB): tRGB; function andFarben(a,b: tRGB): tRGB; function wertZuFarbe(x: extended; p: tRGBArray): tRGB; function tFPColor2tRgb(c: tFPColor): tRGB; function tRgb2tFPColor(c: tRGB): tFPColor; procedure myDebugLnThreadLog(s: string); function belegterSpeicher: longint; procedure cleanupLogs; procedure cleanupLog(tid: PtrUInt); procedure raiseAndDumpExceptionCallStack(msg: string); procedure dumpExceptionCallStack(E: Exception); function startetMit(start: string; var s: string): boolean; function endetMit(ende: string; var s: string): boolean; function trimAll(s: string): string; function erstesArgument(var s: string): string; overload; inline; function erstesArgument(var s: string; Trenner: string): string; overload; inline; function mydatetimetostr(t: tDateTime): string; function tExtPointToStr(p: tExtPoint): string; function tIntPointToStr(p: tIntPoint): string; procedure fehler(s: string); function hexDump(p: pointer; cnt: longint): string; function base64ToBin(var s: string): boolean; function base64Decode(const s: string; out i: qword): boolean; overload; function base64Decode(const s: string; out i: longword): boolean; overload; function base64Encode(i: longword): string; overload; function base64Encode(i,siz: longword): string; overload; function mirrorBits(qw: qword): qword; overload; function mirrorBits(lw: longword): longword; overload; function mirrorBits(w: word): word; overload; function mirrorBits(b: byte): byte; overload; function zusammenfassen(s1,s2: string): string; function intervallAusrollen(s: string): string; function myUtf8Encode(s: string): string; var base64Chars: array[0..63] of char; base64CharsInvers: array[char] of byte; const __ausgabenMaske: byte = 0; implementation uses matheunit; var _cpuLastUsed,_cpuLastIdle: int64; // allgemeine Funktionen ******************************************************* function signSqr(x: extended): extended; begin result:=sign(x)*sqr(x); end; function mpfToStr(f: mpf_t): string; var ex: mp_exp_t; off: byte; begin result:=mpf_get_str(nil,ex,10,0,f); off:=1+byte(pos('-',result)=1); if result='' then result:='0' else if ex=1 then result:=copy(result,1,off)+','+copy(result,off+1,length(result)-off) else result:=copy(result,1,off)+','+copy(result,off+1,length(result)-off)+' * 10^'+inttostr(ex-1); end; function myTimeToStr(t: extended): string; var tim: int64; begin tim:=floor(t*24*60*60); result:=inttostr(tim mod 10)+'s'; tim:=tim div 10; if tim=0 then exit; result:=inttostr(tim mod 6)+result; tim:=tim div 6; if tim=0 then exit; result:=inttostr(tim mod 10)+'min '+result; tim:=tim div 10; if tim=0 then exit; result:=inttostr(tim mod 6)+result; tim:=tim div 6; if tim=0 then exit; result:=inttostr(tim mod 24)+'h '+result; tim:=tim div 24; if tim=0 then exit; result:=' '+result; if (tim mod 7)<>1 then result:='e'+result; result:=inttostr(tim mod 7)+'Tag'+result; tim:=tim div 7; if tim=0 then exit; result:=' '+result; if tim<>1 then result:='n'+result; result:=inttostr(tim)+'Woche'+result; end; function cpuUtilization: extended; var procstat: textfile; s: string; used,idle: int64; i: integer; begin result:=0; s:=''; assignfile(procstat,'/proc/stat'); reset(procstat); while not eof(procstat) do begin readln(procstat,s); if pos('cpu ',s)=1 then break; end; closefile(procstat); if pos('cpu ',s)<>1 then exit; delete(s,1,pos(' ',s)); s:=trim(s); used:=0; idle:=0; for i:=0 to 3 do begin used:=used+idle; idle:=strtoint(copy(s,1,pos(' ',s)-1)); delete(s,1,pos(' ',s)); s:=trim(s); end; result:=(used-_cpuLastUsed)/max(1,used-_cpuLastUsed + idle-_cpuLastIdle); _cpuLastUsed:=used; _cpuLastIdle:=idle; end; function numCpus: int64; var procstat: textfile; s: string; begin result:=0; s:=''; assignfile(procstat,'/proc/stat'); reset(procstat); while not eof(procstat) do begin readln(procstat,s); if (pos('cpu',s)=1) and (pos('cpu ',s)<>1) then inc(result); end; closefile(procstat); end; function momentanFreieCpus: int64; begin result:=floor(numCpus*(1-cpuUtilization)); end; function mpfMyRoot(rad: mpf_t; wzlExp: int64): extended; var ex: mp_exp_t; begin result:=power(mpf_get_d_2exp(ex,rad),1/wzlExp); result:=result*power(2,ex/wzlExp); end; function belegterSpeicher: int64; var f: textFile; s: string; begin s:='/proc/'+inttostr(getProcessId)+'/smaps'; result:=0; if not fileexists(s) then exit; assignfile(f,s); reset(f); while not eof(f) do begin readln(f,s); if (leftStr(s,4)='Rss:') and (rightStr(s,3)=' kB') then begin delete(s,1,4); delete(s,length(s)-2,3); s:=trim(s); result:=result+strtoint(s); end; end; closefile(f); end; function minCache: int64; var f: textFile; s: string; begin s:='/proc/cpuinfo'; result:=0; if not fileexists(s) then exit; assignfile(f,s); reset(f); while not eof(f) do begin readln(f,s); if (leftStr(s,10)='cache size') and (rightStr(s,3)=' kB') then begin delete(s,1,pos(':',s)); delete(s,length(s)-2,3); s:=trim(s); if result=0 then result:=strtoint(s) else result:=min(result,strtoint(s)); end; end; closefile(f); end; function cmpStr(s1,s2: string): longint; var i: longint; begin for i:=1 to min(length(s1),length(s2)) do if s1[i]<>s2[i] then begin result:=2*byte(s1[i]>s2[i])-1; exit; end; if length(s1)<>length(s2) then begin result:=2*byte(length(s1)>length(s2))-1; exit; end; result:=0; end; function mitte(s1,s2: string): string; var i: longint; w,nw: word; begin setlength(result,max(length(s1),length(s2))); w:=0; for i:=length(result) downto 1 do begin // result:= "s1+s2"; if i<=length(s1) then w:=w+byte(s1[i]); if i<=length(s2) then w:=w+byte(s2[i]); result[i]:=char(w and $ff); w:=w shr 8; end; result:=char(w)+result; w:=0; for i:=1 to length(result) do begin nw:=byte(odd(byte(result[i])+w)); result[i]:=char((byte(result[i])+w) div 2); w:=nw shl 8; end; if w<>0 then result:=result+char(w div 2); if result[1]<>#0 then begin writeln('Fehler bei der Mittenfindeung!'); halt; end; delete(result,1,1); end; function myFloatToStr(x: extended): string; begin result:=myFloatToStr(x,'E'); end; function myFloatToStr(x: extended; ex: string): string; var i,e: longint; begin e:=0; if x<0 then begin result:='-'; x:=-x; end else result:=''; if x=0 then begin result:='0'; exit; end; while x<1 do begin dec(e); x:=x*10; end; while x>=10 do begin inc(e); x:=x/10; end; result:=result+char(ord('0')+floor(x))+'.'; for i:=0 to 20 do begin x:=(x-floor(x))*10; result:=result+char(ord('0')+floor(x)); end; if e<>0 then result:=result+ex+inttostr(e); end; function myStrToFloat(s: string): extended; var i,e: longint; neg: boolean; begin if pos('E',s)>0 then begin e:=strtoint(rightStr(s,length(s)-pos('E',s))); delete(s,pos('E',s),length(s)); end else e:=0; if pos('.',s)=0 then begin result:=strtoint(s)*power(10,e); exit; end; neg:=leftStr(s,1)='-'; if neg then delete(s,1,1); if pos('.',s)=2 then begin result:=0; for i:=length(s) downto 3 do result:=result/10 + ord(s[i])-ord('0'); result:=result/10 + ord(s[1])-ord('0'); end else result:=strtofloat(s); result:=result*power(10,e); if neg then result:=-result; end; function myIntToStr(i,dg: longint): string; begin result:=myIntToStr(i,dg,' '); end; function myIntToStr(i,dg: longint; fill: string): string; begin result:=inttostr(i); while length(result)g2 then result:=g1 else result:=g2; end; function wertGroesze(g: tGenauigkeit): longint; begin case g of gSingle: result:=sizeof(single); gDouble: result:=sizeof(double); gExtended: result:=sizeof(extended); else begin gibAus('Unbekannter Genauigkeitstyp!',3); raise exception.create('Unbekannter Genauigkeitstyp!'); end; end; end; // allgemeine Funktionen ******************************************************* function floattostrtrunc(f: extended; dig: longint; laessig: boolean): string; begin result:=inttostr(round(f*power(10,dig))); result:=copy(result,1,length(result)-dig)+'.'+copy(result,length(result)-dig+1,dig); if laessig then while result[length(result)]='0' do delete(result,length(result),1); if result[length(result)]='.' then delete(result,length(result),1); end; function ZeitDarstellen(t: extended): string; var schreibe: boolean; begin result:='('; schreibe:=t>=1; if schreibe then begin result:=result+inttostr(floor(t))+' Tage '; t:=t-floor(t); end; t:=t*24; schreibe:=schreibe or (t>=1); if schreibe then begin result:=inttostr(floor(t))+':'; t:=t-floor(t); end; t:=t*60; schreibe:=schreibe or (t>=1); if schreibe then begin result:=inttostr(floor(t))+':'; t:=t-floor(t); end; t:=t*60; result:=result+inttostr(round(t))+' s)'; end; function binOpPos(op: char; s: string): integer; begin result:=0; repeat result:=result+max(1,pos(op,copy(s,result+1,length(s)-result))); until ((result>1) and not (s[result-1] in ['+','-','*','/','(','E','e','^'])) or (result>length(s)) or (s[result]<>op); if (result>length(s)) or (s[result]<>op) then result:=0; end; function fktPos(fkt,s: string): integer; var tmp: longint; begin result:=pos(fkt,s); while (result<>0) and ((result+length(fkt)>length(s)) or not (s[result+length(fkt)] in [' ','('])) do begin tmp:=pos(fkt,copy(s,result+1,length(s))); if tmp=0 then result:=0 else result:=result + tmp; end; end; procedure gibAus(s: string; ausgaben: byte); begin if odd(ausgaben) and not odd(__ausgabenMaske) then myDebugLnThreadLog(s); if odd(ausgaben div 2) and not odd(__ausgabenMaske div 2) then writeln(s); end; function strToGen(out gen: tGenauigkeit; s: string): boolean; begin result:=true; if (s='float') or (s='single') then begin gen:=gSingle; exit; end; if s='double' then begin gen:=gDouble; exit; end; if s='extended' then begin gen:=gExtended; exit; end; gibAus('Kenne Genauigkeitstyp '''+s+''' nicht!',3); result:=false; end; function mischeFarben(a,b: tRGB; x: extended): tRGB; begin result.rgbRed:=min(255,max(0,round(a.rgbRed*(1-x)+b.rgbRed*x))); result.rgbGreen:=min(255,max(0,round(a.rgbGreen*(1-x)+b.rgbGreen*x))); result.rgbBlue:=min(255,max(0,round(a.rgbBlue*(1-x)+b.rgbBlue*x))); end; function orFarben(a,b: tRGB): tRGB; begin result.rgbRed:=a.rgbRed or b.rgbRed; result.rgbGreen:=a.rgbGreen or b.rgbGreen; result.rgbBlue:=a.rgbBlue or b.rgbBlue; end; function andFarben(a,b: tRGB): tRGB; begin result.rgbRed:=a.rgbRed and b.rgbRed; result.rgbGreen:=a.rgbGreen and b.rgbGreen; result.rgbBlue:=a.rgbBlue and b.rgbBlue; end; function wertZuFarbe(x: extended; p: tRGBArray): tRGB; var i: longint; begin x:=min(1,max(0,x))*(length(p)-1); i:=floor(x); if i>=(length(p)-1) then begin result.rgbRed:=p[length(p)-1].rgbRed; result.rgbGreen:=p[length(p)-1].rgbGreen; result.rgbBlue:=p[length(p)-1].rgbBlue; exit; end; if i<0 then begin result.rgbRed:=p[0].rgbRed; result.rgbGreen:=p[0].rgbGreen; result.rgbBlue:=p[0].rgbBlue; exit; end; x:=x-i; result:=mischeFarben(p[i],p[i+1],x); end; function tFPColor2tRgb(c: tFPColor): tRGB; begin result.rgbRed:=c.red; result.rgbGreen:=c.green; result.rgbBlue:=c.blue; end; function tRgb2tFPColor(c: tRGB): tFPColor; begin result.red:=c.rgbRed; result.green:=c.rgbGreen; result.blue:=c.rgbBlue; end; procedure myDebugLnThreadLog(s: string); var f: textfile; id: PtrUInt; begin id:=getThreadID; assignfile(f,'Log'+inttostr(id)); try if fileexists('Log'+inttostr(id)) then append(f) else rewrite(f); except exit; end; writeln(f,inttostr(id)+': '+s); closefile(f); end; function belegterSpeicher: longint; var f: textFile; s: string; begin s:='/proc/'+inttostr(getProcessId)+'/smaps'; result:=0; if not fileexists(s) then exit; assignfile(f,s); reset(f); while not eof(f) do begin readln(f,s); if (leftStr(s,4)='Rss:') and (rightStr(s,3)=' kB') then begin delete(s,1,4); delete(s,length(s)-2,3); s:=trim(s); result:=result+strtoint(s); end; end; closefile(f); end; procedure cleanupLogs; var sr: tSearchRec; err: longint; begin err:=findfirst('Log*',$3f,sr); while err=0 do begin deletefile(sr.name); err:=findnext(sr); end; findclose(sr); end; procedure cleanupLog(tid: PtrUInt); var s: string; Zeit: extended; begin s:='Log'+inttostr(tid); Zeit:=now+1/24/60/60; while (not fileexists(s)) and (Zeit>now) do sleep(100); if fileexists(s) then deletefile(s) else begin gibAus('Datei '''+s+''' kann nicht gelöscht werden, da sie nicht existiert!',3); raise exception.create('Datei '''+s+''' kann nicht gelöscht werden, da sie nicht existiert!'); end; end; procedure raiseAndDumpExceptionCallStack(msg: string); var e: exception; begin e:=exception.create(msg); dumpExceptionCallStack(e); raise e; end; procedure dumpExceptionCallStack(E: Exception); var I: Integer; Frames: PPointer; Report: string; begin Report := 'Program exception! ' + LineEnding + 'Stacktrace:' + LineEnding + LineEnding; if E <> nil then begin Report := Report + 'Exception class: ' + E.ClassName + LineEnding + 'Message: ' + E.Message + LineEnding; end; Report := Report + BackTraceStrFunc(ExceptAddr); Frames := ExceptFrames; for I := 0 to ExceptFrameCount - 1 do Report := Report + LineEnding + BackTraceStrFunc(Frames[I]); gibAus(Report,3); end; function startetMit(start: string; var s: string): boolean; begin result:=leftStr(s,length(start))=start; if result then s:=trim(rightStr(s,length(s)-length(start))); end; function endetMit(ende: string; var s: string): boolean; begin result:=rightStr(s,length(ende))=ende; if result then s:=trim(leftStr(s,length(s)-length(ende))); end; function trimAll(s: string): string; begin result:=s; while pos(' ',result)>0 do delete(result,pos(' ',result),1); end; function erstesArgument(var s: string): string; begin result:=erstesArgument(s,' '); end; function erstesArgument(var s: string; Trenner: string): string; begin result:=copy(s,1,pos(Trenner,s+Trenner)-1); delete(s,1,length(result)+length(Trenner)); s:=trim(s); result:=trim(result); end; function mydatetimetostr(t: tDateTime): string; begin result:=formatDateTime('YYYY.MM.DD_hh.mm.ss',t); end; function tExtPointToStr(p: tExtPoint): string; begin result:=floattostr(p['x'])+';'+floattostr(p['y']); end; function tIntPointToStr(p: tIntPoint): string; begin result:=inttostr(p['x'])+';'+inttostr(p['y']); end; procedure fehler(s: string); begin gibAus(s,1); raise exception.create(s); end; function hexDump(p: pointer; cnt: longint): string; var i: longint; begin result:=''; for i:=cnt-1 downto 0 do result:=result+inttohex((pByte(p)+i)^,2); end; function base64ToBin(var s: string): boolean; var i,j: longint; t: string; b: byte; begin t:=''; result:=false; for i:=1 to length(s) do begin b:=base64CharsInvers[s[i]]; if b=255 then exit; for j:=5 downto 0 do t:=t+char(ord('0')+byte(odd(b shr j))); end; s:=t; result:=true; end; function base64Decode(const s: string; out i: qword): boolean; var j: longint; b: byte; begin i:=0; result:=false; for j:=1 to length(s) do begin b:=base64CharsInvers[s[j]]; if b=255 then exit; i:=(i shl 6) or b; end; result:=true; end; function base64Decode(const s: string; out i: longword): boolean; var j: qword; begin result:=base64Decode(s,j); if result then i:=j else i:=0; end; function base64Encode(i: longword): string; begin result:=base64Encode(i,(8*sizeof(i)+7) div 6); end; function base64Encode(i,siz: longword): string; var j: longint; begin result:=''; for j:=0 to siz-1 do begin result:=base64Chars[i and $3f]+result; i:=i shr 6; end; end; function mirrorBits(qw: qword): qword; begin result:= (mirrorBits(longword(qw and $ffffffff)) shl 32) or mirrorBits(longword(qw shr 32)); end; function mirrorBits(lw: longword): longword; begin result:= (mirrorBits(word(lw and $ffff)) shl 16) or mirrorBits(word(lw shr 16)); end; function mirrorBits(w: word): word; begin result:= (mirrorBits(byte(w and $ff)) shl 8) or mirrorBits(byte(w shr 8)); end; function mirrorBits(b: byte): byte; begin result:= byte(odd(b shr 7)) or (byte(odd(b shr 6)) shl 1) or (byte(odd(b shr 5)) shl 2) or (byte(odd(b shr 4)) shl 3) or (byte(odd(b shr 3)) shl 4) or (byte(odd(b shr 2)) shl 5) or (byte(odd(b shr 1)) shl 6) or (byte(odd(b)) shl 7); end; function zusammenfassen(s1,s2: string): string; var i: longint; begin if istGanzZahl(s1) and istGanzZahl(s2) then begin i:=strtoint(s1)+strtoint(s2); result:=inttostr(i); if (startetMit('+',s1) or startetMit('+',s2)) and (i>=0) then result:='+'+result; end else if s1=s2 then result:=s1 else raise exception.create('Ich kann '''+s1+''' und '''+s2+''' nicht zusammenfassen!'); end; function intervallAusrollen(s: string): string; var i: longint; begin i:=strtoint(erstesArgument(s,'..')); result:=''; while i<=strtoint(s) do begin result:=result+' '+myinttostr(i,length(s),'0'); inc(i); end; result:=trim(result); end; function myUtf8Encode(s: string): string; const falsch: string = #$c4#$d6#$dc#$df#$e4#$f6#$fc; richtig: array[1..7] of string = ('Ä','Ö','Ü','ß','ä','ö','ü'); var i: longint; begin result:=s; for i:=1 to length(richtig) do while pos(falsch[i],result)>0 do result:=leftStr(result,pos(falsch[i],result)-1)+richtig[i]+rightStr(result,length(result)-pos(falsch[i],result)); end; var b: byte; begin _cpuLastUsed:=0; _cpuLastIdle:=0; cpuUtilization; for b:=0 to 25 do begin base64Chars[b]:= char(b+ord('A')); base64Chars[b+26]:=char(b+ord('a')); end; for b:=0 to 9 do base64Chars[52+b]:=char(b+ord('0')); base64Chars[62]:='+'; base64Chars[63]:='/'; for b:=0 to 255 do base64CharsInvers[char(b)]:=255; for b:=0 to 63 do base64CharsInvers[base64Chars[b]]:=b; end.