diff options
Diffstat (limited to '')
-rw-r--r-- | Lua/src/base/UCommon.pas | 361 |
1 files changed, 98 insertions, 263 deletions
diff --git a/Lua/src/base/UCommon.pas b/Lua/src/base/UCommon.pas index a52349c0..fa0faf3c 100644 --- a/Lua/src/base/UCommon.pas +++ b/Lua/src/base/UCommon.pas @@ -39,59 +39,54 @@ uses {$IFDEF MSWINDOWS} Windows, {$ENDIF} - sdl, UConfig, - ULog; + ULog, + UPath; type - TMessageType = ( mtInfo, mtError ); + TStringDynArray = array of string; -procedure ShowMessage( const msg : String; msgType: TMessageType = mtInfo ); +const + SepWhitespace = [#9, #10, #13, ' ']; // tab, lf, cr, space -procedure ConsoleWriteLn(const msg: string); +{** + * Splits a string into pieces separated by Separators. + * MaxCount specifies the max. number of pieces. If it is <= 0 the number is + * not limited. If > 0 the last array element will hold the rest of the string + * (with leading separators removed). + * + * Examples: + * SplitString(' split me now ', 0) -> ['split', 'me', 'now'] + * SplitString(' split me now ', 1) -> ['split', 'me now'] + *} +function SplitString(const Str: string; MaxCount: integer = 0; Separators: TSysCharSet = SepWhitespace): TStringDynArray; + + +type + TMessageType = (mtInfo, mtError); -function RWopsFromStream(Stream: TStream): PSDL_RWops; +procedure ShowMessage(const msg: string; msgType: TMessageType = mtInfo); + +procedure ConsoleWriteLn(const msg: string); {$IFDEF FPC} -function RandomRange(aMin: Integer; aMax: Integer) : Integer; +function RandomRange(aMin: integer; aMax: integer): integer; {$ENDIF} -function StringReplaceW(text : WideString; search, rep: WideChar):WideString; -function AdaptFilePaths( const aPath : widestring ): widestring; - procedure DisableFloatingPointExceptions(); procedure SetDefaultNumericLocale(); procedure RestoreNumericLocale(); {$IFNDEF MSWINDOWS} - procedure ZeroMemory( Destination: Pointer; Length: DWORD ); - function MakeLong(a, b: Word): Longint; - (* - #define LOBYTE(a) (BYTE)(a) - #define HIBYTE(a) (BYTE)((a)>>8) - #define LOWORD(a) (WORD)(a) - #define HIWORD(a) (WORD)((a)>>16) - #define MAKEWORD(a,b) (WORD)(((a)&0xff)|((b)<<8)) - *) +procedure ZeroMemory(Destination: pointer; Length: dword); +function MakeLong(a, b: word): longint; {$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; - // A stable alternative to TList.Sort() (use TList.Sort() if applicable, see below) procedure MergeSort(List: TList; CompareFunc: TListSortCompare); -function GetAlignedMem(Size: cardinal; Alignment: integer): Pointer; -procedure FreeAlignedMem(P: Pointer); +function GetAlignedMem(Size: cardinal; Alignment: integer): pointer; +procedure FreeAlignedMem(P: pointer); implementation @@ -101,8 +96,63 @@ uses {$IFDEF Delphi} Dialogs, {$ENDIF} - UMain; + sdl, + UFilesystem, + UMain, + UUnicodeUtils; + +function SplitString(const Str: string; MaxCount: integer; Separators: TSysCharSet): TStringDynArray; + {* + * Adds Str[StartPos..Endpos-1] to the result array. + *} + procedure AddSplit(StartPos, EndPos: integer); + begin + SetLength(Result, Length(Result)+1); + Result[High(Result)] := Copy(Str, StartPos, EndPos-StartPos); + end; + +var + I: integer; + Start: integer; + Last: integer; +begin + Start := 0; + SetLength(Result, 0); + + for I := 1 to Length(Str) do + begin + if (Str[I] in Separators) then + begin + // end of component found + if (Start > 0) then + begin + AddSplit(Start, I); + Start := 0; + end; + end + else if (Start = 0) then + begin + // mark beginning of component + Start := I; + // check if this is the last component + if (Length(Result) = MaxCount-1) then + begin + // find last non-separator char + Last := Length(Str); + while (Str[Last] in Separators) do + Dec(Last); + // add component up to last non-separator + AddSplit(Start, Last); + Exit; + end; + end; + end; + + // last component + if (Start > 0) then + AddSplit(Start, Length(Str)+1); +end; // data used by the ...Locale() functions {$IF Defined(Linux) or Defined(FreeBSD)} @@ -224,185 +274,23 @@ begin 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 := 1 to length(result) 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 ); +procedure ZeroMemory(Destination: pointer; Length: dword); begin - FillChar( Destination^, Length, 0 ); + FillChar(Destination^, Length, 0); end; -function MakeLong(A, B: Word): Longint; +function MakeLong(A, B: word): longint; begin Result := (LongInt(B) shl 16) + A; end; -(* -function QueryPerformanceCounter(lpPerformanceCount:TLARGEINTEGER):Bool; - - // From http://en.wikipedia.org/wiki/RDTSC - function RDTSC: Int64; register; - asm - rdtsc - end; - -begin - // Use clock_gettime(CLOCK_REALTIME, ...) here (but not from the libc unit) - lpPerformanceCount := RDTSC(); - result := true; -end; - -function QueryPerformanceFrequency(lpFrequency:TLARGEINTEGER):Bool; -begin - // clock_getres(CLOCK_REALTIME, ...) - 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 -{$IF Defined(Linux) or Defined(FreeBSD)} - // 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} - // Windows and Mac OS X do not have case sensitive file systems - Result := FileExists(FileName); -{$IFEND} -end; - -// +++++++++++++++++++++ helpers for RWOpsFromStream() +++++++++++++++ -function SdlStreamSeek( context : PSDL_RWops; offset : Integer; whence : Integer ) : integer; cdecl; -var - stream : TStream; - origin : Word; -begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamSeek on nil' ); - case whence of - 0 : origin := soFromBeginning; // Offset is from the beginning of the resource. Seek moves to the position Offset. Offset must be >= 0. - 1 : origin := soFromCurrent; // Offset is from the current position in the resource. Seek moves to Position + Offset. - 2 : origin := soFromEnd; - else - origin := soFromBeginning; // just in case - end; - Result := stream.Seek( offset, origin ); -end; - -function SdlStreamRead( context : PSDL_RWops; Ptr : Pointer; size : Integer; maxnum: Integer ) : Integer; cdecl; -var - stream : TStream; -begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamRead on nil' ); - try - Result := stream.read( Ptr^, Size * maxnum ) div size; - except - Result := -1; - end; -end; - -function SDLStreamClose( context : PSDL_RWops ) : Integer; cdecl; -var - stream : TStream; -begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamClose on nil' ); - stream.Free; - Result := 1; -end; -// ----------------------------------------------- - -(* - * Creates an SDL_RWops handle from a TStream. - * The stream and RWops must be freed by the user after usage. - * Use SDL_FreeRW(...) to free the RWops data-struct. - *) -function RWopsFromStream(Stream: TStream): PSDL_RWops; -begin - Result := SDL_AllocRW(); - if (Result = nil) then - Exit; - - // set RW-callbacks - with Result^ do - begin - unknown := TUnknown(Stream); - seek := SDLStreamSeek; - read := SDLStreamRead; - write := nil; - close := SDLStreamClose; - type_ := 2; - end; -end; - - - {$IFDEF FPC} -function RandomRange(aMin: Integer; aMax: Integer) : Integer; +function RandomRange(aMin: integer; aMax: integer): integer; begin - RandomRange := Random(aMax-aMin) + aMin ; + RandomRange := Random(aMax - aMin) + aMin ; end; {$ENDIF} @@ -455,7 +343,7 @@ begin System.EnterCriticalSection(ConsoleCriticalSection); // output pending messages - for i := 0 to MessageList.Count-1 do + for i := 0 to MessageList.Count - 1 do begin _ConsoleWriteLn(MessageList[i]); end; @@ -528,7 +416,7 @@ end; procedure ShowMessage(const msg: String; msgType: TMessageType); {$IFDEF MSWINDOWS} -var Flags: Cardinal; +var Flags: cardinal; {$ENDIF} begin {$IF Defined(MSWINDOWS)} @@ -543,59 +431,6 @@ begin {$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; - (* * Recursive part of the MergeSort algorithm. * OutList will be either InList or TempList and will be swapped in each @@ -607,7 +442,7 @@ procedure _MergeSort(InList, TempList, OutList: TList; StartPos, BlockSize: inte CompareFunc: TListSortCompare); var LeftSize, RightSize: integer; // number of elements in left/right block - LeftEnd, RightEnd: integer; // Index after last element in left/right block + LeftEnd, RightEnd: integer; // Index after last element in left/right block MidPos: integer; // index of first element in right block Pos: integer; // position in output list begin @@ -683,7 +518,7 @@ end; type // stores the unaligned pointer of data allocated by GetAlignedMem() PMemAlignHeader = ^TMemAlignHeader; - TMemAlignHeader = Pointer; + TMemAlignHeader = pointer; (** * Use this function to assure that allocated memory is aligned on a specific @@ -699,9 +534,9 @@ type * alignments on 16 and 32 byte boundaries too. *) {$WARNINGS OFF} -function GetAlignedMem(Size: cardinal; Alignment: integer): Pointer; +function GetAlignedMem(Size: cardinal; Alignment: integer): pointer; var - OrigPtr: Pointer; + OrigPtr: pointer; const MIN_ALIGNMENT = 16; begin @@ -722,9 +557,9 @@ begin end; // reserve space for the header - Result := Pointer(PtrUInt(OrigPtr) + SizeOf(TMemAlignHeader)); + Result := pointer(PtrUInt(OrigPtr) + SizeOf(TMemAlignHeader)); // align memory - Result := Pointer(PtrUInt(Result) + Alignment - PtrUInt(Result) mod Alignment); + Result := pointer(PtrUInt(Result) + Alignment - PtrUInt(Result) mod Alignment); // set header with info on old pointer for FreeMem PMemAlignHeader(PtrUInt(Result) - SizeOf(TMemAlignHeader))^ := OrigPtr; @@ -732,7 +567,7 @@ end; {$WARNINGS ON} {$WARNINGS OFF} -procedure FreeAlignedMem(P: Pointer); +procedure FreeAlignedMem(P: pointer); begin if (P <> nil) then FreeMem(PMemAlignHeader(PtrUInt(P) - SizeOf(TMemAlignHeader))^); |