From 0d86a79ad303441af3080f1c744da0c556927425 Mon Sep 17 00:00:00 2001 From: tobigun Date: Thu, 24 Apr 2008 12:47:09 +0000 Subject: - reverted some stuff that was erroneously commited by one of the last commits. - moved DEBUG define from config-*.inc back to switches.inc - APPTYPE is needed by FPC (for Windows) too. Fixed some crashes with Writeln in FPC (Win) if no console is available. - Moved thread-safe ULog.SafeWriteln() to UCommon.ConsoleWriteln(), this is used by DebugWriteln() now, so this is thread-safe too - Added log-levels (sorted by severity): DEBUG, INFO, STATUS, WARN, ERROR, CRITICAL. Default log-level is LOG_LEVEL_ERROR, so warnings and less important logs are not printed by default. You can change this by LOG_LEVEL_DEFAULT or Log.SetLogLevel(Level). Please use Log.LogError/Warn/Status/Info/Debug/... instead of DebugWriteln() to avoid spamming the console. See ULog.pas for further info. git-svn-id: svn://svn.code.sf.net/p/ultrastardx/svn/trunk@1036 b956fd51-792f-4845-bead-9b4dfca2ff2c --- Game/Code/Classes/UAudioDecoder_FFMpeg.pas | 28 +- Game/Code/Classes/UCommon.pas | 1092 ++++++++++++++++------------ Game/Code/Classes/ULog.pas | 398 +++++----- Game/Code/Classes/UMain.pas | 2 +- Game/Code/Classes/UTexture.pas | 51 +- 5 files changed, 859 insertions(+), 712 deletions(-) (limited to 'Game/Code/Classes') diff --git a/Game/Code/Classes/UAudioDecoder_FFMpeg.pas b/Game/Code/Classes/UAudioDecoder_FFMpeg.pas index 8903bc09..209e1838 100644 --- a/Game/Code/Classes/UAudioDecoder_FFMpeg.pas +++ b/Game/Code/Classes/UAudioDecoder_FFMpeg.pas @@ -372,7 +372,7 @@ begin if(url_feof(pbIOCtx) <> 0) then begin {$IFDEF DebugFFMpegDecode} - SafeWriteLn('feof'); + DebugWriteln('feof'); {$ENDIF} eofState := true; continue; @@ -382,7 +382,7 @@ begin if(url_ferror(pbIOCtx) = 0) then begin {$IFDEF DebugFFMpegDecode} - SafeWriteLn('Errorf'); + DebugWriteln('Errorf'); {$ENDIF} // no error -> wait for user input SDL_Delay(100); @@ -397,11 +397,11 @@ begin end; end; - //SafeWriteLn( 'ffmpeg - av_read_frame' ); + //DebugWriteln( 'ffmpeg - av_read_frame' ); if(packet.stream_index = ffmpegStreamIndex) then begin - //SafeWriteLn( 'packet_queue_put' ); + //DebugWriteln( 'packet_queue_put' ); packetQueue.put(@packet); end else @@ -425,7 +425,7 @@ begin begin while (audio_pkt_size > 0) do begin - //SafeWriteLn( 'got audio packet' ); + //DebugWriteln( 'got audio packet' ); data_size := bufSize; {$IF LIBAVCODEC_VERSION >= 51030000} // 51.30.0 @@ -438,13 +438,13 @@ begin data_size, audio_pkt_data, audio_pkt_size); {$IFEND} - //SafeWriteLn('avcodec_decode_audio : ' + inttostr( len1 )); + //DebugWriteln('avcodec_decode_audio : ' + inttostr( len1 )); if(len1 < 0) then begin // if error, skip frame {$IFDEF DebugFFMpegDecode} - SafeWriteLn( 'Skip audio frame' ); + DebugWriteln( 'Skip audio frame' ); {$ENDIF} audio_pkt_size := 0; break; @@ -482,7 +482,7 @@ begin begin avcodec_flush_buffers(pCodecCtx); {$IFDEF DebugFFMpegDecode} - SafeWriteLn('Flush'); + DebugWriteln('Flush'); {$ENDIF} continue; end; @@ -493,13 +493,13 @@ begin // end-of-file reached -> set EOF-flag SetEOF(true); {$IFDEF DebugFFMpegDecode} - SafeWriteLn('EOF'); + DebugWriteln('EOF'); {$ENDIF} // note: buffer is not (even partially) filled -> no data to return exit; end; - //SafeWriteLn( 'Audio Packet Size - ' + inttostr(audio_pkt_size) ); + //DebugWriteln( 'Audio Packet Size - ' + inttostr(audio_pkt_size) ); end; end; @@ -522,14 +522,14 @@ begin begin // we have already sent all our data; get more audio_size := DecodeFrame(audio_buf, sizeof(TAudioBuffer)); - //SafeWriteLn('audio_decode_frame : '+ inttostr(audio_size)); + //DebugWriteln('audio_decode_frame : '+ inttostr(audio_size)); if(audio_size < 0) then begin // if error, output silence audio_buf_size := 1024; FillChar(audio_buf, audio_buf_size, #0); - //SafeWriteLn( 'Silence' ); + //DebugWriteln( 'Silence' ); end else begin @@ -731,7 +731,7 @@ begin Self.lastPkt := pkt1; inc(Self.nbPackets); - //SafeWriteLn('Put: ' + inttostr(nbPackets)); + //DebugWriteln('Put: ' + inttostr(nbPackets)); Self.size := Self.size + pkt1^.pkt.size; SDL_CondSignal(Self.cond); @@ -765,7 +765,7 @@ begin Self.lastPkt := nil; dec(Self.nbPackets); - //SafeWriteLn('Get: ' + inttostr(nbPackets)); + //DebugWriteln('Get: ' + inttostr(nbPackets)); Self.size := Self.size - pkt1^.pkt.size; pkt := pkt1^.pkt; diff --git a/Game/Code/Classes/UCommon.pas b/Game/Code/Classes/UCommon.pas index 7539a958..5af018b7 100644 --- a/Game/Code/Classes/UCommon.pas +++ b/Game/Code/Classes/UCommon.pas @@ -1,470 +1,622 @@ -unit UCommon; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - Classes, - {$IFDEF MSWINDOWS} - Windows, - Messages, - {$ENDIF} - ULog; - -{$IFNDEF DARWIN} -// FIXME: remove this if it is not needed anymore -type - hStream = THandle; - HGLRC = THandle; - TLargeInteger = Int64; - TWin32FindData = LongInt; -{$ENDIF} - -function GetResourceStream(const aName, aType : string): TStream; - -procedure ShowMessage( const msg : String ); - -{$IFDEF FPC} -function RandomRange(aMin: Integer; aMax: Integer) : Integer; -{$ENDIF} - -{$IF Defined(MSWINDOWS) and Defined(FPC)} -function AllocateHWnd(Method: TWndMethod): HWND; -procedure DeallocateHWnd(hWnd: HWND); -{$IFEND} - -function StringReplaceW(text : WideString; search, rep: WideChar):WideString; -function AdaptFilePaths( const aPath : widestring ): widestring; - -procedure DisableFloatingPointExceptions(); -procedure SetDefaultNumericLocale(); -procedure RestoreNumericLocale(); - -{$IFNDEF win32} - procedure ZeroMemory( Destination: Pointer; Length: DWORD ); -{$ENDIF} - -function FileExistsInsensitive(var FileName: string): boolean; - -(* - * Character classes - *) - -function IsAlphaChar(ch: WideChar): boolean; -function IsNumericChar(ch: WideChar): boolean; -function IsAlphaNumericChar(ch: WideChar): boolean; -function IsPunctuationChar(ch: WideChar): boolean; -function IsControlChar(ch: WideChar): boolean; - - -implementation - -uses - Math, - {$IFDEF Delphi} - Dialogs, - {$ENDIF} - {$IFDEF LINUX} - libc, - {$ENDIF} - UMain, - UConfig; - -var - PrevNumLocale: string; - -// In Linux and maybe MacOSX some units (like cwstring) call setlocale(LC_ALL, '') -// to set the language/country specific locale (e.g. charset) for this application. -// Unfortunately, LC_NUMERIC is set by this call too. -// It defines the decimal-separator and other country-specific numeric settings. -// This parameter is used by the C string-to-float parsing functions atof() and strtod(). -// After changing LC_NUMERIC some external C-based libs (like projectM) are not -// able to parse strings correctly -// (e.g. in Germany "0.9" is not recognized as a valid number anymore but "0,9" is). -// So we reset the numeric settings to the default ('C'). -// Note: The behaviour of Pascal parsing functions (e.g. strtofloat()) is not -// changed by this because it doesn't use the locale-settings. -// TODO: -// - Check if this is needed in MacOSX (at least the locale is set in cwstring) -// - Find out which libs are concerned by this problem. -// If only projectM is concerned by this problem set and restore the numeric locale -// for each call to projectM instead of changing it globally. -procedure SetDefaultNumericLocale(); -begin - {$ifdef LINUX} - PrevNumLocale := setlocale(LC_NUMERIC, nil); - setlocale(LC_NUMERIC, 'C'); - {$endif} -end; - -procedure RestoreNumericLocale(); -begin - {$ifdef LINUX} - setlocale(LC_NUMERIC, PChar(PrevNumLocale)); - {$endif} -end; - -(* - * If an invalid floating point operation was performed the Floating-point unit (FPU) - * generates a Floating-point exception (FPE). Dependending on the settings in - * the FPU's control-register (interrupt mask) the FPE is handled by the FPU itself - * (we will call this as "FPE disabled" later on) or is passed to the application - * (FPE enabled). - * If FPEs are enabled a floating-point division by zero (e.g. 10.0 / 0.0) is - * considered an error and an exception is thrown. Otherwise the FPU will handle - * the error and return the result infinity (INF) (10.0 / 0.0 = INF) without - * throwing an error to the application. - * The same applies to a division by INF that either raises an exception - * (FPE enabled) or returns 0.0 (FPE disabled). - * Normally (as with C-programs), Floating-point exceptions (FPE) are DISABLED - * on program startup (at least with Intel CPUs), but for some strange reasons - * they are ENABLED in pascal (both delphi and FPC) by default. - * Many libs operating with floating-point values rely heavily on the C-specific - * behaviour. So using them in delphi is a ticking time-bomb because sooner or - * later they will crash because of an FPE (this problem occurs massively - * in OpenGL-based libs like projectM). In contrast to this no error will occur - * if the lib is linked to a C-program. - * - * Further info on FPUs: - * For x86 and x86_64 CPUs we have to consider two FPU instruction sets. - * The math co-processor i387 (aka 8087 or x87) set introduced with the i386 - * and SSE (Streaming SIMD Extensions) introduced with the Pentium3. - * Both of them have separate control-registers (x87: FPUControlWord, SSE: MXCSR) - * to control FPEs. Either has (among others) 6bits to enable/disable several - * exception types (Invalid,Denormalized,Zero,Overflow,Underflow,Precision). - * Those exception-types must all be masked (=1) to get the default C behaviour. - * The control-registers can be set with the asm-ops FLDCW (x87) and LDMXCSR (SSE). - * Instead of using assembler code, we can use Set8087CW() provided by delphi and - * FPC to set the x87 control-word. FPC also provides SetSSECSR() for SSE's MXCSR. - * Note that both Delphi and FPC enable FPEs (e.g. for div-by-zero) on program - * startup but only FPC enables FPEs (especially div-by-zero) for SSE too. - * So we have to mask FPEs for x87 in Delphi and FPC and for SSE in FPC only. - * FPC and Delphi both provide a SetExceptionMask() for control of the FPE - * mask. SetExceptionMask() sets the masks for x87 in Delphi and for x87 and SSE - * in FPC (seems as if Delphi [2005] is not SSE aware). So SetExceptionMask() - * is what we need and it even is plattform and CPU independent. - * - * Pascal OpenGL headers (like the Delphi standard ones or JEDI-SDL headers) - * already call Set8087CW() to disable FPEs but due to some bugs in the JEDI-SDL - * headers they do not work properly with FPC. I already patched them, so they - * work at least until they are updated the next time. In addition Set8086CW() - * does not suffice to disable FPEs because the SSE FPEs are not disabled by this. - * FPEs with SSE are a big problem with some libs because many linux distributions - * optimize code for SSE or Pentium3 (for example: int(INF) which convert the - * double value "infinity" to an integer might be automatically optimized by - * using SSE's CVTSD2SI instruction). So SSE FPEs must be turned off in any case - * to make USDX portable. - * - * Summary: - * Call this function on initialization to make sure FPEs are turned off. - * It will solve a lot of errors with FPEs in external libs. - *) -procedure DisableFloatingPointExceptions(); -begin - (* - // We will use SetExceptionMask() instead of Set8087CW()/SetSSECSR(). - // Note: Leave these lines for documentation purposes just in case - // SetExceptionMask() does not work anymore (due to bugs in FPC etc.). - {$IF Defined(CPU386) or Defined(CPUI386) or Defined(CPUX86_64)} - Set8087CW($133F); - {$IFEND} - {$IF Defined(FPC)} - if (has_sse_support) then - SetSSECSR($1F80); - {$IFEND} - *) - - // disable all of the six FPEs (x87 and SSE) to be compatible with C/C++ and - // other libs which rely on the standard FPU behaviour (no div-by-zero FPE anymore). - SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide, - exOverflow, exUnderflow, exPrecision]); -end; - -function StringReplaceW(text : WideString; search, rep: WideChar):WideString; -var - iPos : integer; -// sTemp : WideString; -begin -(* - result := text; - iPos := Pos(search, result); - while (iPos > 0) do - begin - sTemp := copy(result, iPos + length(search), length(result)); - result := copy(result, 1, iPos - 1) + rep + sTEmp; - iPos := Pos(search, result); - end; -*) - result := text; - - if search = rep then - exit; - - for iPos := 0 to length( result ) - 1 do - begin - if result[ iPos ] = search then - result[ iPos ] := rep; - end; -end; - -function AdaptFilePaths( const aPath : widestring ): widestring; -begin - result := StringReplaceW( aPath, '\', PathDelim );//, [rfReplaceAll] ); -end; - - -{$IFNDEF win32} -procedure ZeroMemory( Destination: Pointer; Length: DWORD ); -begin - FillChar( Destination^, Length, 0 ); -end; //ZeroMemory - -(* -function QueryPerformanceCounter(lpPerformanceCount:TLARGEINTEGER):Bool; - - // From http://en.wikipedia.org/wiki/RDTSC - function RDTSC: Int64; register; - asm - rdtsc - end; - -begin - // Use clock_gettime here maybe ... from libc - lpPerformanceCount := RDTSC(); - result := true; -end; - -function QueryPerformanceFrequency(lpFrequency:TLARGEINTEGER):Bool; -begin - lpFrequency := 0; - result := true; -end; -*) -{$ENDIF} - -// Checks if a regular files or directory with the given name exists. -// The comparison is case insensitive. -function FileExistsInsensitive(var FileName: string): boolean; -var - FilePath, LocalFileName: string; - SearchInfo: TSearchRec; -begin -{$IFDEF LINUX} // eddie: Changed FPC to LINUX: Windows and Mac OS X dont have case sensitive file systems - // speed up standard case - if FileExists(FileName) then - begin - Result := true; - exit; - end; - - Result := false; - - FilePath := ExtractFilePath(FileName); - if (FindFirst(FilePath+'*', faAnyFile, SearchInfo) = 0) then - begin - LocalFileName := ExtractFileName(FileName); - repeat - if (AnsiSameText(LocalFileName, SearchInfo.Name)) then - begin - FileName := FilePath + SearchInfo.Name; - Result := true; - break; - end; - until (FindNext(SearchInfo) <> 0); - end; - FindClose(SearchInfo); -{$ELSE} - Result := FileExists(FileName); -{$ENDIF} -end; - - -{$IFDEF Linux} - // include resource-file info (stored in the constant array "resources") - {$I ../resource.inc} -{$ENDIF} - -function GetResourceStream(const aName, aType: string): TStream; -{$IFDEF Linux} -var - ResIndex: integer; - Filename: string; -{$ENDIF} -begin - Result := nil; - - {$IFDEF Linux} - for ResIndex := 0 to High(resources) do - begin - if (resources[ResIndex][0] = aName ) and - (resources[ResIndex][1] = aType ) then - begin - try - Filename := ResourcesPath + resources[ResIndex][2]; - Result := TFileStream.Create(Filename, fmOpenRead); - except - Log.LogError('Failed to open: "'+ resources[ResIndex][2] +'"', 'GetResourceStream'); - end; - exit; - end; - end; - {$ELSE} - try - Result := TResourceStream.Create(HInstance, aName , PChar(aType)); - except - Log.LogError('Invalid resource: "'+ aType + ':' + aName +'"', 'GetResourceStream'); - end; - {$ENDIF} -end; - -{$IFDEF FPC} -function RandomRange(aMin: Integer; aMax: Integer) : Integer; -begin - RandomRange := Random(aMax-aMin) + aMin ; -end; -{$ENDIF} - -{$IF Defined(MSWINDOWS) and Defined(FPC)} -function AllocateHWndCallback(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -var - Msg: TMessage; - MethodPtr: ^TWndMethod; -begin - FillChar(Msg, SizeOf(Msg), 0); - Msg.msg := uMsg; - Msg.wParam := wParam; - Msg.lParam := lParam; - - MethodPtr := Pointer(GetWindowLongPtr(hwnd, GWL_USERDATA)); - if Assigned(MethodPtr) then - MethodPtr^(Msg); - - Result := DefWindowProc(hwnd, uMsg, wParam, lParam); -end; - -function AllocateHWnd(Method: TWndMethod): HWND; -var - ClassExists: Boolean; - WndClass, OldClass: TWndClass; - MethodPtr: ^TMethod; -begin - Result := 0; - - // setup class-info - FillChar(WndClass, SizeOf(TWndClass), 0); - WndClass.hInstance := HInstance; - // Important: do not enable AllocateHWndCallback before the msg-handler method is assigned, - // otherwise race-conditions might occur - WndClass.lpfnWndProc := @DefWindowProc; - WndClass.lpszClassName:= 'USDXUtilWindowClass'; - - // check if class is already registered - ClassExists := GetClassInfo(HInstance, WndClass.lpszClassName, OldClass); - // create window-class shared by all windows created by AllocateHWnd() - if (not ClassExists) or (@OldClass.lpfnWndProc <> @DefWindowProc) then - begin - if ClassExists then - UnregisterClass(WndClass.lpszClassName, HInstance); - if (RegisterClass(WndClass) = 0) then - Exit; - end; - // create window - Result := CreateWindowEx(WS_EX_TOOLWINDOW, WndClass.lpszClassName, '', - WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil); - if (Result = 0) then - Exit; - // assign individual callback procedure to the window - if Assigned(Method) then - begin - // TMethod contains two pointers but we can pass just one as USERDATA - GetMem(MethodPtr, SizeOf(TMethod)); - MethodPtr^ := TMethod(Method); - SetWindowLongPtr(Result, GWL_USERDATA, LONG_PTR(MethodPtr)); - end; - // now enable AllocateHWndCallback for this window - SetWindowLongPtr(Result, GWL_WNDPROC, LONG_PTR(@AllocateHWndCallback)); -end; - -procedure DeallocateHWnd(hWnd: HWND); -var - MethodPtr: ^TMethod; -begin - if (hWnd <> 0) then - begin - MethodPtr := Pointer(GetWindowLongPtr(hWnd, GWL_USERDATA)); - DestroyWindow(hWnd); - if Assigned(MethodPtr) then - FreeMem(MethodPtr); - end; -end; -{$IFEND} - -procedure ShowMessage( const msg : String ); -begin -{$IF Defined(MSWINDOWS)} - MessageBox(0, PChar(msg), PChar(USDXVersionStr()), MB_ICONINFORMATION); -{$ELSE} - debugwriteln(msg); -{$IFEND} -end; - -function IsAlphaChar(ch: WideChar): boolean; -begin - // TODO: add chars > 255 when unicode-fonts work? - case ch of - 'A'..'Z', // A-Z - 'a'..'z', // a-z - #170,#181,#186, - #192..#214, - #216..#246, - #248..#255: - Result := true; - else - Result := false; - end; -end; - -function IsNumericChar(ch: WideChar): boolean; -begin - case ch of - '0'..'9': - Result := true; - else - Result := false; - end; -end; - -function IsAlphaNumericChar(ch: WideChar): boolean; -begin - Result := (IsAlphaChar(ch) or IsNumericChar(ch)); -end; - -function IsPunctuationChar(ch: WideChar): boolean; -begin - // TODO: add chars outside of Latin1 basic (0..127)? - case ch of - ' '..'/',':'..'@','['..'`','{'..'~': - Result := true; - else - Result := false; - end; -end; - -function IsControlChar(ch: WideChar): boolean; -begin - case ch of - #0..#31, - #127..#159: - Result := true; - else - Result := false; - end; -end; - -end. +unit UCommon; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + SysUtils, + Classes, + {$IFDEF MSWINDOWS} + Windows, + Messages, + {$ENDIF} + ULog; + +{$IFNDEF DARWIN} +// FIXME: remove this if it is not needed anymore +type + hStream = THandle; + HGLRC = THandle; + TLargeInteger = Int64; + TWin32FindData = LongInt; +{$ENDIF} + +type + TMessageType = ( mtInfo, mtError ); + +procedure ShowMessage( const msg : String; msgType: TMessageType = mtInfo ); + +procedure ConsoleWriteLn(const msg: string); + +function GetResourceStream(const aName, aType : string): TStream; + +{$IFDEF FPC} +function RandomRange(aMin: Integer; aMax: Integer) : Integer; +{$ENDIF} + +{$IF Defined(MSWINDOWS) and Defined(FPC)} +function AllocateHWnd(Method: TWndMethod): HWND; +procedure DeallocateHWnd(hWnd: HWND); +{$IFEND} + +function StringReplaceW(text : WideString; search, rep: WideChar):WideString; +function AdaptFilePaths( const aPath : widestring ): widestring; + +procedure DisableFloatingPointExceptions(); +procedure SetDefaultNumericLocale(); +procedure RestoreNumericLocale(); + +{$IFNDEF win32} + procedure ZeroMemory( Destination: Pointer; Length: DWORD ); +{$ENDIF} + +function FileExistsInsensitive(var FileName: string): boolean; + +(* + * Character classes + *) + +function IsAlphaChar(ch: WideChar): boolean; +function IsNumericChar(ch: WideChar): boolean; +function IsAlphaNumericChar(ch: WideChar): boolean; +function IsPunctuationChar(ch: WideChar): boolean; +function IsControlChar(ch: WideChar): boolean; + + +implementation + +uses + Math, + {$IFDEF Delphi} + Dialogs, + {$ENDIF} + {$IFDEF LINUX} + libc, + {$ENDIF} + {$IFDEF FPC} + sdl, + {$ENDIF} + UMain, + UConfig; + +var + PrevNumLocale: string; + +// In Linux and maybe MacOSX some units (like cwstring) call setlocale(LC_ALL, '') +// to set the language/country specific locale (e.g. charset) for this application. +// Unfortunately, LC_NUMERIC is set by this call too. +// It defines the decimal-separator and other country-specific numeric settings. +// This parameter is used by the C string-to-float parsing functions atof() and strtod(). +// After changing LC_NUMERIC some external C-based libs (like projectM) are not +// able to parse strings correctly +// (e.g. in Germany "0.9" is not recognized as a valid number anymore but "0,9" is). +// So we reset the numeric settings to the default ('C'). +// Note: The behaviour of Pascal parsing functions (e.g. strtofloat()) is not +// changed by this because it doesn't use the locale-settings. +// TODO: +// - Check if this is needed in MacOSX (at least the locale is set in cwstring) +// - Find out which libs are concerned by this problem. +// If only projectM is concerned by this problem set and restore the numeric locale +// for each call to projectM instead of changing it globally. +procedure SetDefaultNumericLocale(); +begin + {$ifdef LINUX} + PrevNumLocale := setlocale(LC_NUMERIC, nil); + setlocale(LC_NUMERIC, 'C'); + {$endif} +end; + +procedure RestoreNumericLocale(); +begin + {$ifdef LINUX} + setlocale(LC_NUMERIC, PChar(PrevNumLocale)); + {$endif} +end; + +(* + * If an invalid floating point operation was performed the Floating-point unit (FPU) + * generates a Floating-point exception (FPE). Dependending on the settings in + * the FPU's control-register (interrupt mask) the FPE is handled by the FPU itself + * (we will call this as "FPE disabled" later on) or is passed to the application + * (FPE enabled). + * If FPEs are enabled a floating-point division by zero (e.g. 10.0 / 0.0) is + * considered an error and an exception is thrown. Otherwise the FPU will handle + * the error and return the result infinity (INF) (10.0 / 0.0 = INF) without + * throwing an error to the application. + * The same applies to a division by INF that either raises an exception + * (FPE enabled) or returns 0.0 (FPE disabled). + * Normally (as with C-programs), Floating-point exceptions (FPE) are DISABLED + * on program startup (at least with Intel CPUs), but for some strange reasons + * they are ENABLED in pascal (both delphi and FPC) by default. + * Many libs operating with floating-point values rely heavily on the C-specific + * behaviour. So using them in delphi is a ticking time-bomb because sooner or + * later they will crash because of an FPE (this problem occurs massively + * in OpenGL-based libs like projectM). In contrast to this no error will occur + * if the lib is linked to a C-program. + * + * Further info on FPUs: + * For x86 and x86_64 CPUs we have to consider two FPU instruction sets. + * The math co-processor i387 (aka 8087 or x87) set introduced with the i386 + * and SSE (Streaming SIMD Extensions) introduced with the Pentium3. + * Both of them have separate control-registers (x87: FPUControlWord, SSE: MXCSR) + * to control FPEs. Either has (among others) 6bits to enable/disable several + * exception types (Invalid,Denormalized,Zero,Overflow,Underflow,Precision). + * Those exception-types must all be masked (=1) to get the default C behaviour. + * The control-registers can be set with the asm-ops FLDCW (x87) and LDMXCSR (SSE). + * Instead of using assembler code, we can use Set8087CW() provided by delphi and + * FPC to set the x87 control-word. FPC also provides SetSSECSR() for SSE's MXCSR. + * Note that both Delphi and FPC enable FPEs (e.g. for div-by-zero) on program + * startup but only FPC enables FPEs (especially div-by-zero) for SSE too. + * So we have to mask FPEs for x87 in Delphi and FPC and for SSE in FPC only. + * FPC and Delphi both provide a SetExceptionMask() for control of the FPE + * mask. SetExceptionMask() sets the masks for x87 in Delphi and for x87 and SSE + * in FPC (seems as if Delphi [2005] is not SSE aware). So SetExceptionMask() + * is what we need and it even is plattform and CPU independent. + * + * Pascal OpenGL headers (like the Delphi standard ones or JEDI-SDL headers) + * already call Set8087CW() to disable FPEs but due to some bugs in the JEDI-SDL + * headers they do not work properly with FPC. I already patched them, so they + * work at least until they are updated the next time. In addition Set8086CW() + * does not suffice to disable FPEs because the SSE FPEs are not disabled by this. + * FPEs with SSE are a big problem with some libs because many linux distributions + * optimize code for SSE or Pentium3 (for example: int(INF) which convert the + * double value "infinity" to an integer might be automatically optimized by + * using SSE's CVTSD2SI instruction). So SSE FPEs must be turned off in any case + * to make USDX portable. + * + * Summary: + * Call this function on initialization to make sure FPEs are turned off. + * It will solve a lot of errors with FPEs in external libs. + *) +procedure DisableFloatingPointExceptions(); +begin + (* + // We will use SetExceptionMask() instead of Set8087CW()/SetSSECSR(). + // Note: Leave these lines for documentation purposes just in case + // SetExceptionMask() does not work anymore (due to bugs in FPC etc.). + {$IF Defined(CPU386) or Defined(CPUI386) or Defined(CPUX86_64)} + Set8087CW($133F); + {$IFEND} + {$IF Defined(FPC)} + if (has_sse_support) then + SetSSECSR($1F80); + {$IFEND} + *) + + // disable all of the six FPEs (x87 and SSE) to be compatible with C/C++ and + // other libs which rely on the standard FPU behaviour (no div-by-zero FPE anymore). + SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide, + exOverflow, exUnderflow, exPrecision]); +end; + +function StringReplaceW(text : WideString; search, rep: WideChar):WideString; +var + iPos : integer; +// sTemp : WideString; +begin +(* + result := text; + iPos := Pos(search, result); + while (iPos > 0) do + begin + sTemp := copy(result, iPos + length(search), length(result)); + result := copy(result, 1, iPos - 1) + rep + sTEmp; + iPos := Pos(search, result); + end; +*) + result := text; + + if search = rep then + exit; + + for iPos := 0 to length( result ) - 1 do + begin + if result[ iPos ] = search then + result[ iPos ] := rep; + end; +end; + +function AdaptFilePaths( const aPath : widestring ): widestring; +begin + result := StringReplaceW( aPath, '\', PathDelim );//, [rfReplaceAll] ); +end; + + +{$IFNDEF MSWINDOWS} +procedure ZeroMemory( Destination: Pointer; Length: DWORD ); +begin + FillChar( Destination^, Length, 0 ); +end; //ZeroMemory + +(* +function QueryPerformanceCounter(lpPerformanceCount:TLARGEINTEGER):Bool; + + // From http://en.wikipedia.org/wiki/RDTSC + function RDTSC: Int64; register; + asm + rdtsc + end; + +begin + // Use clock_gettime here maybe ... from libc + lpPerformanceCount := RDTSC(); + result := true; +end; + +function QueryPerformanceFrequency(lpFrequency:TLARGEINTEGER):Bool; +begin + lpFrequency := 0; + result := true; +end; +*) +{$ENDIF} + +// Checks if a regular files or directory with the given name exists. +// The comparison is case insensitive. +function FileExistsInsensitive(var FileName: string): boolean; +var + FilePath, LocalFileName: string; + SearchInfo: TSearchRec; +begin +{$IFDEF LINUX} // eddie: Changed FPC to LINUX: Windows and Mac OS X dont have case sensitive file systems + // speed up standard case + if FileExists(FileName) then + begin + Result := true; + exit; + end; + + Result := false; + + FilePath := ExtractFilePath(FileName); + if (FindFirst(FilePath+'*', faAnyFile, SearchInfo) = 0) then + begin + LocalFileName := ExtractFileName(FileName); + repeat + if (AnsiSameText(LocalFileName, SearchInfo.Name)) then + begin + FileName := FilePath + SearchInfo.Name; + Result := true; + break; + end; + until (FindNext(SearchInfo) <> 0); + end; + FindClose(SearchInfo); +{$ELSE} + Result := FileExists(FileName); +{$ENDIF} +end; + + +{$IFDEF Linux} + // include resource-file info (stored in the constant array "resources") + {$I ../resource.inc} +{$ENDIF} + +function GetResourceStream(const aName, aType: string): TStream; +{$IFDEF Linux} +var + ResIndex: integer; + Filename: string; +{$ENDIF} +begin + Result := nil; + + {$IFDEF Linux} + for ResIndex := 0 to High(resources) do + begin + if (resources[ResIndex][0] = aName ) and + (resources[ResIndex][1] = aType ) then + begin + try + Filename := ResourcesPath + resources[ResIndex][2]; + Result := TFileStream.Create(Filename, fmOpenRead); + except + Log.LogError('Failed to open: "'+ resources[ResIndex][2] +'"', 'GetResourceStream'); + end; + exit; + end; + end; + {$ELSE} + try + Result := TResourceStream.Create(HInstance, aName , PChar(aType)); + except + Log.LogError('Invalid resource: "'+ aType + ':' + aName +'"', 'GetResourceStream'); + end; + {$ENDIF} +end; + +{$IFDEF FPC} +function RandomRange(aMin: Integer; aMax: Integer) : Integer; +begin + RandomRange := Random(aMax-aMin) + aMin ; +end; +{$ENDIF} + +{$IF Defined(MSWINDOWS) and Defined(FPC)} +function AllocateHWndCallback(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; +var + Msg: TMessage; + MethodPtr: ^TWndMethod; +begin + FillChar(Msg, SizeOf(Msg), 0); + Msg.msg := uMsg; + Msg.wParam := wParam; + Msg.lParam := lParam; + + MethodPtr := Pointer(GetWindowLongPtr(hwnd, GWL_USERDATA)); + if Assigned(MethodPtr) then + MethodPtr^(Msg); + + Result := DefWindowProc(hwnd, uMsg, wParam, lParam); +end; + +function AllocateHWnd(Method: TWndMethod): HWND; +var + ClassExists: Boolean; + WndClass, OldClass: TWndClass; + MethodPtr: ^TMethod; +begin + Result := 0; + + // setup class-info + FillChar(WndClass, SizeOf(TWndClass), 0); + WndClass.hInstance := HInstance; + // Important: do not enable AllocateHWndCallback before the msg-handler method is assigned, + // otherwise race-conditions might occur + WndClass.lpfnWndProc := @DefWindowProc; + WndClass.lpszClassName:= 'USDXUtilWindowClass'; + + // check if class is already registered + ClassExists := GetClassInfo(HInstance, WndClass.lpszClassName, OldClass); + // create window-class shared by all windows created by AllocateHWnd() + if (not ClassExists) or (@OldClass.lpfnWndProc <> @DefWindowProc) then + begin + if ClassExists then + UnregisterClass(WndClass.lpszClassName, HInstance); + if (RegisterClass(WndClass) = 0) then + Exit; + end; + // create window + Result := CreateWindowEx(WS_EX_TOOLWINDOW, WndClass.lpszClassName, '', + WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil); + if (Result = 0) then + Exit; + // assign individual callback procedure to the window + if Assigned(Method) then + begin + // TMethod contains two pointers but we can pass just one as USERDATA + GetMem(MethodPtr, SizeOf(TMethod)); + MethodPtr^ := TMethod(Method); + SetWindowLongPtr(Result, GWL_USERDATA, LONG_PTR(MethodPtr)); + end; + // now enable AllocateHWndCallback for this window + SetWindowLongPtr(Result, GWL_WNDPROC, LONG_PTR(@AllocateHWndCallback)); +end; + +procedure DeallocateHWnd(hWnd: HWND); +var + MethodPtr: ^TMethod; +begin + if (hWnd <> 0) then + begin + MethodPtr := Pointer(GetWindowLongPtr(hWnd, GWL_USERDATA)); + DestroyWindow(hWnd); + if Assigned(MethodPtr) then + FreeMem(MethodPtr); + end; +end; +{$IFEND} + +{$IFDEF FPC} +var + MessageList: TStringList; + ConsoleHandler: TThreadID; + ConsoleMutex: PSDL_Mutex; + ConsoleCond: PSDL_Cond; + ConsoleQuit: boolean; +{$ENDIF} + +(* + * Write to console if one is available. + * It checks if a console is available before output so it will not + * crash on windows if none is available. + * Do not use this function directly because it is not thread-safe, + * use ConsoleWriteLn() instead. + *) +procedure _ConsoleWriteLn(const aString: string); {$IFDEF HasInline}inline;{$ENDIF} +begin + {$IFDEF MSWINDOWS} + // sanity check to avoid crashes with writeln() + if (IsConsole) then + begin + {$ENDIF} + Writeln(aString); + {$IFDEF MSWINDOWS} + end; + {$ENDIF} +end; + +{$IFDEF FPC} +{* + * The console-handlers main-function. + * TODO: create a quit-event on closing. + *} +function ConsoleHandlerFunc(param: pointer): PtrInt; +var + i: integer; + quit: boolean; +begin + quit := false; + while (not quit) do + begin + SDL_mutexP(ConsoleMutex); + // wait for new output or quit-request + while ((MessageList.Count = 0) and (not ConsoleQuit)) do + SDL_CondWait(ConsoleCond, ConsoleMutex); + // output pending messages + for i := 0 to MessageList.Count-1 do + begin + _ConsoleWriteLn(MessageList[i]); + end; + MessageList.Clear(); + + // use local quit-variable to avoid accessing + // ConsoleQuit outside of the critical section + if (ConsoleQuit) then + quit := true; + + SDL_mutexV(ConsoleMutex); + end; + result := 0; +end; +{$ENDIF} + +procedure InitConsoleOutput(); +begin + {$IFDEF FPC} + // init thread-safe output + MessageList := TStringList.Create(); + ConsoleMutex := SDL_CreateMutex(); + ConsoleCond := SDL_CreateCond(); + ConsoleQuit := false; + // must be a thread managed by FPC. Otherwise (e.g. SDL-thread) + // it will crash when using Writeln. + ConsoleHandler := BeginThread(@ConsoleHandlerFunc); + {$ENDIF} +end; + +procedure FinalizeConsoleOutput(); +begin + {$IFDEF FPC} + // terminate console-handler + SDL_mutexP(ConsoleMutex); + ConsoleQuit := true; + SDL_CondSignal(ConsoleCond); + SDL_mutexV(ConsoleMutex); + WaitForThreadTerminate(ConsoleHandler, 0); + // free data + SDL_DestroyCond(ConsoleCond); + SDL_DestroyMutex(ConsoleMutex); + MessageList.Free(); + {$ENDIF} +end; + +{* + * With FPC console output is not thread-safe. + * Using WriteLn() from external threads (like in SDL callbacks) + * will damage the heap and crash the program. + * Most probably FPC uses thread-local-data (TLS) to lock a mutex on + * the console-buffer. This does not work with external lib's threads + * because these do not have the TLS data and so it crashes while + * accessing unallocated memory. + * The solution is to create an FPC-managed thread which has the TLS data + * and use it to handle the console-output (hence it is called Console-Handler) + * It should be safe to do so, but maybe FPC requires the main-thread to access + * the console-buffer only. In this case output should be delegated to it. + * + * TODO: - check if it is safe if an FPC-managed thread different than the + * main-thread accesses the console-buffer in FPC. + * - check if Delphi's WriteLn is thread-safe. + * - check if we need to synchronize file-output too + * - Use TEvent and TCriticalSection instead of the SDL equivalents. + * Note: If those two objects use TLS they might crash FPC too. + *} +procedure ConsoleWriteLn(const msg: string); +begin +{$IFDEF CONSOLE} + {$IFDEF FPC} + // TODO: check for the main-thread and use a simple _ConsoleWriteLn() then? + //GetCurrentThreadThreadId(); + SDL_mutexP(ConsoleMutex); + MessageList.Add(msg); + SDL_CondSignal(ConsoleCond); + SDL_mutexV(ConsoleMutex); + {$ELSE} + _ConsoleWriteLn(msg); + {$ENDIF} +{$ENDIF} +end; + +procedure ShowMessage(const msg: String; msgType: TMessageType); +{$IFDEF MSWINDOWS} +var Flags: Cardinal; +{$ENDIF} +begin +{$IF Defined(MSWINDOWS)} + case msgType of + mtInfo: Flags := MB_ICONINFORMATION or MB_OK; + mtError: Flags := MB_ICONERROR or MB_OK; + else Flags := MB_OK; + end; + MessageBox(0, PChar(msg), PChar(USDXVersionStr()), Flags); +{$ELSE} + ConsoleWriteln(msg); +{$IFEND} +end; + +function IsAlphaChar(ch: WideChar): boolean; +begin + // TODO: add chars > 255 when unicode-fonts work? + case ch of + 'A'..'Z', // A-Z + 'a'..'z', // a-z + #170,#181,#186, + #192..#214, + #216..#246, + #248..#255: + Result := true; + else + Result := false; + end; +end; + +function IsNumericChar(ch: WideChar): boolean; +begin + case ch of + '0'..'9': + Result := true; + else + Result := false; + end; +end; + +function IsAlphaNumericChar(ch: WideChar): boolean; +begin + Result := (IsAlphaChar(ch) or IsNumericChar(ch)); +end; + +function IsPunctuationChar(ch: WideChar): boolean; +begin + // TODO: add chars outside of Latin1 basic (0..127)? + case ch of + ' '..'/',':'..'@','['..'`','{'..'~': + Result := true; + else + Result := false; + end; +end; + +function IsControlChar(ch: WideChar): boolean; +begin + case ch of + #0..#31, + #127..#159: + Result := true; + else + Result := false; + end; +end; + +initialization + InitConsoleOutput(); + +finalization + FinalizeConsoleOutput(); + +end. diff --git a/Game/Code/Classes/ULog.pas b/Game/Code/Classes/ULog.pas index 2a628792..d2664b1e 100644 --- a/Game/Code/Classes/ULog.pas +++ b/Game/Code/Classes/ULog.pas @@ -11,21 +11,52 @@ interface uses Classes; +(* + * LOG_LEVEL_[TYPE] defines the "minimum" index for logs of type TYPE. Each + * level greater than this BUT less or equal than LOG_LEVEL_[TYPE]_MAX is of this type. + * This means a level "LOG_LEVEL_ERROR >= Level <= LOG_LEVEL_ERROR_MAX" e.g. + * "Level := LOG_LEVEL_ERROR+2" is considered an error level. + * This is nice for debugging if you have more or less important debug messages. + * For example you can assign LOG_LEVEL_DEBUG+10 for the more important ones and + * LOG_LEVEL_DEBUG+20 for less important ones and so on. By changing the log-level + * you can hide the less important ones. + *) +const + LOG_LEVEL_DEBUG_MAX = MaxInt; + LOG_LEVEL_DEBUG = 50; + LOG_LEVEL_INFO_MAX = LOG_LEVEL_DEBUG-1; + LOG_LEVEL_INFO = 40; + LOG_LEVEL_STATUS_MAX = LOG_LEVEL_INFO-1; + LOG_LEVEL_STATUS = 30; + LOG_LEVEL_WARN_MAX = LOG_LEVEL_STATUS-1; + LOG_LEVEL_WARN = 20; + LOG_LEVEL_ERROR_MAX = LOG_LEVEL_WARN-1; + LOG_LEVEL_ERROR = 10; + LOG_LEVEL_CRITICAL_MAX = LOG_LEVEL_ERROR-1; + LOG_LEVEL_CRITICAL = 0; + LOG_LEVEL_NONE = -1; + + LOG_LEVEL_DEFAULT = LOG_LEVEL_ERROR; + type TLog = class + private + LogFile: TextFile; + LogFileOpened: boolean; + BenchmarkFile: TextFile; + BenchmarkFileOpened: boolean; + + LogLevel: integer; + + procedure LogToFile(const Text: string); public BenchmarkTimeStart: array[0..7] of real; BenchmarkTimeLength: array[0..7] of real;//TDateTime; - FileBenchmark: TextFile; - FileBenchmarkO: boolean; // opened - FileError: TextFile; - FileErrorO: boolean; // opened - Title: String; //Application Title - //Should Log Files be written - Enabled: Boolean; + // Write log message to log-file + FileOutputEnabled: Boolean; constructor Create; @@ -35,25 +66,30 @@ type // benchmark procedure BenchmarkStart(Number: integer); procedure BenchmarkEnd(Number: integer); - procedure LogBenchmark(Text: string; Number: integer); - - // error - procedure LogError(Text: string); overload; - + procedure LogBenchmark(const Text: string; Number: integer); + + procedure SetLogLevel(Level: integer); + function GetLogLevel(): integer; + + procedure LogMsg(const Text: string; Level: integer); overload; + procedure LogMsg(const Msg, Context: string; Level: integer); overload; {$IFDEF HasInline}inline;{$ENDIF} + procedure LogDebug(const Msg, Context: string); {$IFDEF HasInline}inline;{$ENDIF} + procedure LogInfo(const Msg, Context: string); {$IFDEF HasInline}inline;{$ENDIF} + procedure LogStatus(const Msg, Context: string); {$IFDEF HasInline}inline;{$ENDIF} + procedure LogWarn(const Msg, Context: string); {$IFDEF HasInline}inline;{$ENDIF} + procedure LogError(const Text: string); overload; {$IFDEF HasInline}inline;{$ENDIF} + procedure LogError(const Msg, Context: string); overload; {$IFDEF HasInline}inline;{$ENDIF} //Critical Error (Halt + MessageBox) - procedure CriticalError(Text: string); + procedure LogCritical(const Msg, Context: string); {$IFDEF HasInline}inline;{$ENDIF} + procedure CriticalError(const Text: string); {$IFDEF HasInline}inline;{$ENDIF} // voice procedure LogVoice(SoundNr: integer); - - // compability - procedure LogStatus(Log1, Log2: string); - procedure LogError(Log1, Log2: string); overload; - procedure LogBuffer(const buf : Pointer; const bufLength : Integer; filename : string); + // buffer + procedure LogBuffer(const buf : Pointer; const bufLength : Integer; const filename : string); end; -procedure SafeWriteLn(const msg: string); {$IFDEF HasInline}inline;{$ENDIF} -procedure debugWriteln( aString : String ); +procedure DebugWriteln(const aString: String); var Log: TLog; @@ -61,113 +97,45 @@ var implementation uses - {$IFDEF win32} - windows, - {$ENDIF} SysUtils, DateUtils, -//UFiles, URecord, UMain, UTime, -//UIni, // JB - Seems to not be needed. - {$IFDEF FPC} - sdl, - {$ENDIF} + UCommon, UCommandLine; -{$IFDEF FPC} -var - MessageList: TStringList; - ConsoleHandler: TThreadID; - ConsoleMutex: PSDL_Mutex; - ConsoleCond: PSDL_Cond; -{$ENDIF} - -{$IFDEF FPC} -{* - * The console-handlers main-function. - * TODO: create a quit-event on closing. - *} -function ConsoleHandlerFunc(param: pointer): PtrInt; -var - i: integer; +(* + * Write to console if in debug mode (Thread-safe). + * If debug-mode is disabled nothing is done. + *) +procedure DebugWriteln(const aString: string); begin - while true do + {$IFNDEF DEBUG} + if Params.Debug then begin - SDL_mutexP(ConsoleMutex); - while (MessageList.Count = 0) do - SDL_CondWait(ConsoleCond, ConsoleMutex); - for i := 0 to MessageList.Count-1 do - begin - WriteLn(MessageList[i]); - end; - MessageList.Clear(); - SDL_mutexV(ConsoleMutex); + {$ENDIF} + ConsoleWriteLn(aString); + {$IFNDEF DEBUG} end; - result := 0; -end; -{$ENDIF} - -{* - * With FPC console output is not thread-safe. - * Using WriteLn() from external threads (like in SDL callbacks) - * will damage the heap and crash the program. - * Most probably FPC uses thread-local-data (TLS) to lock a mutex on - * the console-buffer. This does not work with external lib's threads - * because these do not have the TLS data and so it crashes while - * accessing unallocated memory. - * The solution is to create an FPC-managed thread which has the TLS data - * and use it to handle the console-output (hence it is called Console-Handler) - * It should be safe to do so, but maybe FPC requires the main-thread to access - * the console-buffer only. In this case output should be delegated to it. - * - * TODO: - check if it is safe if an FPC-managed thread different than the - * main-thread accesses the console-buffer in FPC. - * - check if Delphi's WriteLn is thread-safe. - * - check if we need to synchronize file-output too - * - Use TEvent and TCriticalSection instead of the SDL equivalents. - * Note: If those two objects use TLS they might crash FPC too. - *} -procedure SafeWriteLn(const msg: string); -begin -{$IFDEF FPC} - SDL_mutexP(ConsoleMutex); - MessageList.Add(msg); - SDL_CondSignal(ConsoleCond); - SDL_mutexV(ConsoleMutex); -{$ELSE} - debugWriteln(msg); -{$ENDIF} -end; - -procedure debugWriteln( aString : String ); -begin - {$IFDEF CONSOLE} - if FindCmdLineSwitch( cDebug ) then - writeln( 'DEBUG - '+aString ); {$ENDIF} - end; constructor TLog.Create; begin -{$IFDEF FPC} - // TODO: check for the main-thread? - //GetCurrentThreadThreadId(); - MessageList := TStringList.Create(); - ConsoleMutex := SDL_CreateMutex(); - ConsoleCond := SDL_CreateCond(); - ConsoleHandler := BeginThread(@ConsoleHandlerFunc); -{$ENDIF} + LogLevel := LOG_LEVEL_DEFAULT; + FileOutputEnabled := true; end; destructor TLog.Destroy; begin - if FileBenchmarkO then CloseFile(FileBenchmark); -// if FileAnalyzeO then CloseFile(FileAnalyze); - if FileErrorO then CloseFile(FileError); + if BenchmarkFileOpened then + CloseFile(BenchmarkFile); + //if AnalyzeFileOpened then + // CloseFile(AnalyzeFile); + if LogFileOpened then + CloseFile(LogFile); end; procedure TLog.BenchmarkStart(Number: integer); @@ -180,7 +148,7 @@ begin BenchmarkTimeLength[Number] := USTime.GetTime {Time} - BenchmarkTimeStart[Number]; end; -procedure TLog.LogBenchmark(Text: string; Number: integer); +procedure TLog.LogBenchmark(const Text: string; Number: integer); var Minutes: integer; Seconds: integer; @@ -192,27 +160,31 @@ var ValueText: string; begin - if Enabled AND (Params.Benchmark) then begin - if not FileBenchmarkO then begin - FileBenchmarkO := true; - AssignFile(FileBenchmark, LogPath + 'Benchmark.log'); + if (FileOutputEnabled and Params.Benchmark) then + begin + if not BenchmarkFileOpened then + begin + BenchmarkFileOpened := true; + AssignFile(BenchmarkFile, LogPath + 'Benchmark.log'); {$I-} - Rewrite(FileBenchmark); - if IOResult = 0 then FileBenchmarkO := true; + Rewrite(BenchmarkFile); + if IOResult = 0 then + BenchmarkFileOpened := true; {$I+} //If File is opened write Date to Benchmark File - If (FileBenchmarkO) then + If (BenchmarkFileOpened) then begin - WriteLn(FileBenchmark, Title + ' Benchmark File'); - WriteLn(FileBenchmark, 'Date: ' + DatetoStr(Now) + ' Time: ' + TimetoStr(Now)); - WriteLn(FileBenchmark, '-------------------'); + WriteLn(BenchmarkFile, Title + ' Benchmark File'); + WriteLn(BenchmarkFile, 'Date: ' + DatetoStr(Now) + ' Time: ' + TimetoStr(Now)); + WriteLn(BenchmarkFile, '-------------------'); - Flush(FileBenchmark); + Flush(BenchmarkFile); end; end; - if FileBenchmarkO then begin + if BenchmarkFileOpened then + begin Miliseconds := Trunc(Frac(BenchmarkTimeLength[Number]) * 1000); Seconds := Trunc(BenchmarkTimeLength[Number]) mod 60; Minutes := Trunc((BenchmarkTimeLength[Number] - Seconds) / 60); @@ -232,7 +204,8 @@ begin if (Minutes = 0) and (Seconds >= 1) then begin MilisecondsS := IntToStr(Miliseconds); - while Length(MilisecondsS) < 3 do MilisecondsS := '0' + MilisecondsS; + while Length(MilisecondsS) < 3 do + MilisecondsS := '0' + MilisecondsS; SecondsS := IntToStr(Seconds); @@ -241,115 +214,176 @@ begin if Minutes >= 1 then begin MilisecondsS := IntToStr(Miliseconds); - while Length(MilisecondsS) < 3 do MilisecondsS := '0' + MilisecondsS; + while Length(MilisecondsS) < 3 do + MilisecondsS := '0' + MilisecondsS; SecondsS := IntToStr(Seconds); - while Length(SecondsS) < 2 do SecondsS := '0' + SecondsS; + while Length(SecondsS) < 2 do + SecondsS := '0' + SecondsS; MinutesS := IntToStr(Minutes); ValueText := MinutesS + ':' + SecondsS + ',' + MilisecondsS + ' minutes'; end; - WriteLn(FileBenchmark, Text + ': ' + ValueText); - Flush(FileBenchmark); + WriteLn(BenchmarkFile, Text + ': ' + ValueText); + Flush(BenchmarkFile); end; end; end; -procedure TLog.LogError(Text: string); +procedure TLog.LogToFile(const Text: string); begin - if Enabled AND (not FileErrorO) then begin - //FileErrorO := true; - AssignFile(FileError, LogPath + 'Error.log'); + if (FileOutputEnabled and not LogFileOpened) then + begin + AssignFile(LogFile, LogPath + 'Error.log'); {$I-} - Rewrite(FileError); - if IOResult = 0 then FileErrorO := true; + Rewrite(LogFile); + if IOResult = 0 then + LogFileOpened := true; {$I+} //If File is opened write Date to Error File - If (FileErrorO) then + if (LogFileOpened) then begin - WriteLn(FileError, Title + ' Error Log'); - WriteLn(FileError, 'Date: ' + DatetoStr(Now) + ' Time: ' + TimetoStr(Now)); - WriteLn(FileError, '-------------------'); + WriteLn(LogFile, Title + ' Error Log'); + WriteLn(LogFile, 'Date: ' + DatetoStr(Now) + ' Time: ' + TimetoStr(Now)); + WriteLn(LogFile, '-------------------'); - Flush(FileError); + Flush(LogFile); end; end; - if FileErrorO then begin + if LogFileOpened then + begin try - WriteLn(FileError, Text); - Flush(FileError); + WriteLn(LogFile, Text); + Flush(LogFile); except - FileErrorO := false; + LogFileOpened := false; end; end; - {$IFDEF DEBUG} - SafeWriteLn('Error: ' + Text); - {$ENDIF} end; -procedure TLog.LogVoice(SoundNr: integer); +procedure TLog.SetLogLevel(Level: integer); +begin + LogLevel := Level; +end; + +function TLog.GetLogLevel(): integer; +begin + Result := LogLevel; +end; + +procedure TLog.LogMsg(const Text: string; Level: integer); var -// FileVoice: File; // Auto Removed, Unused Variable - FS: TFileStream; - FileName: string; - Num: integer; + LogMsg: string; begin - for Num := 1 to 9999 do begin - FileName := IntToStr(Num); - while Length(FileName) < 4 do FileName := '0' + FileName; - FileName := LogPath + 'Voice' + FileName + '.raw'; - if not FileExists(FileName) then break + if (Level <= LogLevel) then + begin + if (Level <= LOG_LEVEL_CRITICAL_MAX) then + LogMsg := 'CRITICAL: ' + Text + else if (Level <= LOG_LEVEL_ERROR_MAX) then + LogMsg := 'ERROR: ' + Text + else if (Level <= LOG_LEVEL_WARN_MAX) then + LogMsg := 'WARN: ' + Text + else if (Level <= LOG_LEVEL_STATUS_MAX) then + LogMsg := 'STATUS: ' + Text + else if (Level <= LOG_LEVEL_INFO_MAX) then + LogMsg := 'INFO: ' + Text + else + LogMsg := 'DEBUG: ' + Text; + + // output log-message + DebugWriteLn(LogMsg); + + // actions for error- and more severe levels + if (Level <= LOG_LEVEL_ERROR_MAX) then + begin + // Write message to log-file + LogToFile(Text); + end; + + // actions for critical- and more severe levels + if (Level <= LOG_LEVEL_CRITICAL_MAX) then + begin + // Show information (window) + ShowMessage(Text, mtError); + // Exit Application + Halt; + end; end; +end; +procedure TLog.LogMsg(const Msg, Context: string; Level: integer); +begin + LogMsg(Msg + ' ['+Context+']', Level); +end; - FS := TFileStream.Create(FileName, fmCreate); +procedure TLog.LogDebug(const Msg, Context: string); +begin + LogMsg(Msg, Context, LOG_LEVEL_DEBUG); +end; - AudioInputProcessor.Sound[SoundNr].BufferLong.Seek(0, soBeginning); - FS.CopyFrom(AudioInputProcessor.Sound[SoundNr].BufferLong, AudioInputProcessor.Sound[SoundNr].BufferLong.Size); +procedure TLog.LogInfo(const Msg, Context: string); +begin + LogMsg(Msg, Context, LOG_LEVEL_INFO); +end; - FS.Free; +procedure TLog.LogStatus(const Msg, Context: string); +begin + LogMsg(Msg, Context, LOG_LEVEL_STATUS); end; -procedure TLog.LogStatus(Log1, Log2: string); +procedure TLog.LogWarn(const Msg, Context: string); begin - //Just for Debugging - //Comment for Release - //LogError(Log2 + ': ' + Log1); + LogMsg(Msg, Context, LOG_LEVEL_WARN); +end; - //If Debug => Write to Console Output - {$IFDEF DEBUG} - // SafeWriteLn(Log2 + ': ' + Log1); - {$ENDIF} +procedure TLog.LogError(const Msg, Context: string); +begin + LogMsg(Msg, Context, LOG_LEVEL_ERROR); end; -procedure TLog.LogError(Log1, Log2: string); +procedure TLog.LogError(const Text: string); begin - LogError(Log1 + ' ['+Log2+']'); + LogMsg(Text, LOG_LEVEL_ERROR); end; -procedure TLog.CriticalError(Text: string); +procedure TLog.CriticalError(const Text: string); begin - //Write Error to Logfile: - LogError (Text); - - {$IFDEF MSWINDOWS} - //Show Errormessage - Messagebox(0, PChar(Text), PChar(Title), MB_ICONERROR or MB_OK); - {$ELSE} - // TODO - JB_Linux handle critical error so user can see message. - SafeWriteLn( 'Critical ERROR :' ); - SafeWriteLn( Text ); - {$ENDIF} + LogMsg(Text, LOG_LEVEL_CRITICAL); +end; + +procedure TLog.LogCritical(const Msg, Context: string); +begin + LogMsg(Msg, Context, LOG_LEVEL_CRITICAL); +end; - //Exit Application - Halt; +procedure TLog.LogVoice(SoundNr: integer); +var + FS: TFileStream; + FileName: string; + Num: integer; +begin + for Num := 1 to 9999 do begin + FileName := IntToStr(Num); + while Length(FileName) < 4 do + FileName := '0' + FileName; + FileName := LogPath + 'Voice' + FileName + '.raw'; + if not FileExists(FileName) then + break + end; + + FS := TFileStream.Create(FileName, fmCreate); + + AudioInputProcessor.Sound[SoundNr].BufferLong.Seek(0, soBeginning); + FS.CopyFrom(AudioInputProcessor.Sound[SoundNr].BufferLong, AudioInputProcessor.Sound[SoundNr].BufferLong.Size); + + FS.Free; end; -procedure TLog.LogBuffer(const buf: Pointer; const bufLength: Integer; filename: string); +procedure TLog.LogBuffer(const buf: Pointer; const bufLength: Integer; const filename: string); var f : TFileStream; begin diff --git a/Game/Code/Classes/UMain.pas b/Game/Code/Classes/UMain.pas index 2e49ac8d..5dc03fe8 100644 --- a/Game/Code/Classes/UMain.pas +++ b/Game/Code/Classes/UMain.pas @@ -165,7 +165,7 @@ begin // Log + Benchmark Log := TLog.Create; Log.Title := WndTitle; - Log.Enabled := not Params.NoLog; + Log.FileOutputEnabled := not Params.NoLog; Log.BenchmarkStart(0); // Language diff --git a/Game/Code/Classes/UTexture.pas b/Game/Code/Classes/UTexture.pas index a56c0096..07dc309f 100644 --- a/Game/Code/Classes/UTexture.pas +++ b/Game/Code/Classes/UTexture.pas @@ -137,48 +137,7 @@ uses ULog, {$IFDEF DARWIN} MacResources, {$ENDIF} - StrUtils, - dialogs; - -const - fmt_rgba: TSDL_Pixelformat = ( - palette: nil; - BitsPerPixel: 32; - BytesPerPixel: 4; - Rloss: 0; - Gloss: 0; - Bloss: 0; - Aloss: 0; - Rshift: 0; - Gshift: 8; - Bshift: 16; - Ashift: 24; - Rmask: $000000ff; - Gmask: $0000ff00; - Bmask: $00ff0000; - Amask: $ff000000; - ColorKey: 0; - Alpha: 255 - ); - fmt_rgb: TSDL_Pixelformat = ( - palette: nil; - BitsPerPixel: 24; - BytesPerPixel: 3; - Rloss: 0; - Gloss: 0; - Bloss: 0; - Aloss: 0; - Rshift: 0; - Gshift: 8; - Bshift: 16; - Ashift: 0; - Rmask: $000000ff; - Gmask: $0000ff00; - Bmask: $00ff0000; - Amask: $00000000; - ColorKey: 0; - Alpha: 255 - ); + StrUtils; Constructor TTextureUnit.Create; begin @@ -530,7 +489,8 @@ begin {$endif} if not assigned(TexSurface) then begin - Log.LogStatus( 'ERROR Could not load texture' , Identifier +' '+ TextureTypeToStr(Typ) ); + Log.LogError('Could not load texture: "' + Identifier +' '+ TextureTypeToStr(Typ) +'"', + 'TTextureUnit.LoadTexture'); Exit; end; @@ -851,7 +811,8 @@ begin Log.LogStatus(' Error creating Cover Thumbnail',' LoadTexture('''+Name+''')'); end else - Log.LogStatus( 'ERROR Could not load texture for Cover Thumbnail: ' , name+' '+ TextureTypeToStr(Typ) ); + Log.LogError('Could not load texture for Cover Thumbnail: "' + name+' '+ TextureTypeToStr(Typ) +'"', + 'TTextureUnit.GetCoverThumbnail'); SDL_FreeSurface(TexSurface); end; @@ -1025,7 +986,7 @@ begin Exit; end; end; - Log.LogError('Unknown texture-type: "' + TypeStr + '"', 'ParseTextureType'); + Log.LogWarn('Unknown texture-type: "' + TypeStr + '"', 'ParseTextureType'); Result := TEXTURE_TYPE_PLAIN; end; -- cgit v1.2.3