aboutsummaryrefslogtreecommitdiffstats
path: root/Game/Code/Classes/UCommon.pas
diff options
context:
space:
mode:
Diffstat (limited to 'Game/Code/Classes/UCommon.pas')
-rw-r--r--Game/Code/Classes/UCommon.pas1092
1 files changed, 622 insertions, 470 deletions
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.
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-07 11:35:46 +0000