From 8c9c787a1326b90490543bd50b56fce9b89d9807 Mon Sep 17 00:00:00 2001 From: jaybinks Date: Sat, 3 Nov 2007 02:31:06 +0000 Subject: Windows Lazarus Build working again... Lazarus Project file includes the DPR, so that we have a unified Uses Clause ( keep this in mind please ) added "Delphi" to switches git-svn-id: svn://svn.code.sf.net/p/ultrastardx/svn/trunk@560 b956fd51-792f-4845-bead-9b4dfca2ff2c --- Game/Code/Classes/UCommon.pas | 603 +++++---- Game/Code/Classes/UCore.pas | 1002 +++++++-------- Game/Code/Classes/USongs.pas | 2088 ++++++++++++++++---------------- Game/Code/Classes/UTexture.pas | 2286 +++++++++++++++++------------------ Game/Code/Classes/uPluginLoader.pas | 1602 ++++++++++++------------ Game/Code/UltraStar.dpr | 291 ++--- Game/Code/UltraStar.lpr | 257 +--- Game/Code/switches.inc | 89 +- Modis/SDK/ModiSDK.pas | 4 + Modis/SDK/UPartyDefs.pas | 4 + Modis/SDK/UPluginDefs.pas | 4 + 11 files changed, 4036 insertions(+), 4194 deletions(-) diff --git a/Game/Code/Classes/UCommon.pas b/Game/Code/Classes/UCommon.pas index 43017aff..65d98e30 100644 --- a/Game/Code/Classes/UCommon.pas +++ b/Game/Code/Classes/UCommon.pas @@ -1,302 +1,301 @@ -unit UCommon; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, -{$IFDEF LAZARUS} - lResources, -{$ENDIF} - ULog, -{$IFDEF DARWIN} - messages, -{$ENDIF} -{$IFDEF win32} - windows; -{$ELSE} - lcltype, - messages; -{$ENDIF} - -{$IFNDEF win32} -type - hStream = THandle; - HGLRC = THandle; - TLargeInteger = Int64; - TWin32FindData = LongInt; -{$ENDIF} - -{$IFDEF LAZARUS} - function LazFindResource( const aName, aType : String ): TLResource; -{$ENDIF} - -{$IFDEF FPC} - -function RandomRange(aMin: Integer; aMax: Integer) : Integer; - -function MaxValue(const Data: array of Double): Double; -function MinValue(const Data: array of Double): Double; - - {$IFDEF WIN32} - type - TWndMethod = procedure(var Message: TMessage) of object; - function AllocateHWnd(Method: TWndMethod): HWND; - procedure DeallocateHWnd(Wnd: HWND); - {$ENDIF} // Win32 - -{$ENDIF} // FPC Only - -function StringReplaceW(text : WideString; search, rep: WideChar):WideString; -function AdaptFilePaths( const aPath : widestring ): widestring; - - -{$IFNDEF win32} -(* - function QueryPerformanceCounter(lpPerformanceCount:TLARGEINTEGER):Bool; - function QueryPerformanceFrequency(lpFrequency:TLARGEINTEGER):Bool; -*) - procedure ZeroMemory( Destination: Pointer; Length: DWORD ); -{$ENDIF} - -{$IFDEF MSWINDOWS} - -type - TSearchRecW = record - Time: Integer; - Size: Integer; - Attr: Integer; - Name: WideString; - ExcludeAttr: Integer; - FindHandle: THandle; - FindData: TWin32FindDataW; - end; - - function FindFirstW(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer; - function FindNextW(var F: TSearchRecW): Integer; - procedure FindCloseW(var F: TSearchRecW); - function FindMatchingFileW(var F: TSearchRecW): Integer; - function DirectoryExistsW(const Directory: widestring): Boolean; -{$endif} - -implementation - -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} - - -{$IFDEF LAZARUS} - -function LazFindResource( const aName, aType : String ): TLResource; -var - iCount : Integer; -begin - result := nil; - - for iCount := 0 to LazarusResources.count -1 do - begin - if ( LazarusResources.items[ iCount ].Name = aName ) AND - ( LazarusResources.items[ iCount ].ValueType = aType ) THEN - begin - result := LazarusResources.items[ iCount ]; - exit; - end; - end; -end; -{$ENDIF} - -{$IFDEF FPC} -function MaxValue(const Data: array of Double): Double; -var - I: Integer; -begin - Result := Data[Low(Data)]; - for I := Low(Data) + 1 to High(Data) do - if Result < Data[I] then - Result := Data[I]; -end; - -function MinValue(const Data: array of Double): Double; -var - I: Integer; -begin - Result := Data[Low(Data)]; - for I := Low(Data) + 1 to High(Data) do - if Result > Data[I] then - Result := Data[I]; -end; - -function RandomRange(aMin: Integer; aMax: Integer) : Integer; -begin -RandomRange := Random(aMax-aMin) + aMin ; -end; - - -// NOTE !!!!!!!!!! -// AllocateHWnd is in lclintfh.inc - -{$IFDEF MSWINDOWS} -// TODO : JB this is dodgey and bad... find a REAL solution ! -function AllocateHWnd(Method: TWndMethod): HWND; -var - TempClass: TWndClass; - ClassRegistered: Boolean; -begin - Result := CreateWindowEx(WS_EX_TOOLWINDOW, '', '', WS_POPUP , 0, 0, 0, 0, 0, 0, HInstance, nil); -end; - -procedure DeallocateHWnd(Wnd: HWND); -var - Instance: Pointer; -begin - Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC)); - DestroyWindow(Wnd); -end; -{$ENDIF} -{$IFDEF DARWIN} -// TODO : Situation for the mac isn't better ! -function AllocateHWnd(Method: TWndMethod): HWND; -begin -end; - -procedure DeallocateHWnd(Wnd: HWND); -begin -end; -{$ENDIF} - - - - -{$ENDIF} - -{$ifdef MSWINDOWS} -function FindFirstW(const Path: widestring; Attr: Integer; var F: TSearchRecW): Integer; -const - faSpecial = faHidden or faSysFile or faVolumeID or faDirectory; -begin - F.ExcludeAttr := not Attr and faSpecial; - F.FindHandle := FindFirstFileW(PWideChar(Path), F.FindData); - if F.FindHandle <> INVALID_HANDLE_VALUE then - begin - Result := FindMatchingFileW(F); - if Result <> 0 then FindCloseW(F); - end else - Result := GetLastError; -end; - -function FindNextW(var F: TSearchRecW): Integer; -begin - if FindNextFileW(F.FindHandle, F.FindData) then - Result := FindMatchingFileW(F) - else - Result := GetLastError; -end; - -procedure FindCloseW(var F: TSearchRecW); -begin - if F.FindHandle <> INVALID_HANDLE_VALUE then - begin - Windows.FindClose(F.FindHandle); - F.FindHandle := INVALID_HANDLE_VALUE; - end; -end; - -function FindMatchingFileW(var F: TSearchRecW): Integer; -var - LocalFileTime: TFileTime; -begin - with F do - begin - while FindData.dwFileAttributes and ExcludeAttr <> 0 do - if not FindNextFileW(FindHandle, FindData) then - begin - Result := GetLastError; - Exit; - end; - FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); - FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, LongRec(Time).Lo); - Size := FindData.nFileSizeLow; - Attr := FindData.dwFileAttributes; - Name := FindData.cFileName; - end; - Result := 0; -end; - -function DirectoryExistsW(const Directory: widestring): Boolean; -var - Code: Integer; -begin - Code := GetFileAttributesW(PWideChar(Directory)); - Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); -end; -{$endif} - - - - - -end. +unit UCommon; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + SysUtils, +{$IFDEF LAZARUS} + lResources, +{$ENDIF} + ULog, +{$IFDEF DARWIN} + messages, +{$ENDIF} +{$IFDEF win32} + windows; +{$ELSE} + lcltype, + messages; +{$ENDIF} + +{$IFNDEF win32} +type + hStream = THandle; + HGLRC = THandle; + TLargeInteger = Int64; + TWin32FindData = LongInt; +{$ENDIF} + +{$IFDEF LAZARUS} + function LazFindResource( const aName, aType : String ): TLResource; +{$ENDIF} + +{$IFDEF FPC} + +function RandomRange(aMin: Integer; aMax: Integer) : Integer; + +function MaxValue(const Data: array of Double): Double; +function MinValue(const Data: array of Double): Double; + + {$IFDEF WIN32} + type + TWndMethod = procedure(var Message: TMessage) of object; + function AllocateHWnd(Method: TWndMethod): HWND; + procedure DeallocateHWnd(Wnd: HWND); + {$ENDIF} // Win32 + +{$ENDIF} // FPC Only + +function StringReplaceW(text : WideString; search, rep: WideChar):WideString; +function AdaptFilePaths( const aPath : widestring ): widestring; + + +{$IFNDEF win32} +(* + function QueryPerformanceCounter(lpPerformanceCount:TLARGEINTEGER):Bool; + function QueryPerformanceFrequency(lpFrequency:TLARGEINTEGER):Bool; +*) + procedure ZeroMemory( Destination: Pointer; Length: DWORD ); +{$ENDIF} + +{$IFNDEF FPC} +type + TSearchRecW = record + Time: Integer; + Size: Integer; + Attr: Integer; + Name: WideString; + ExcludeAttr: Integer; + FindHandle: THandle; + FindData: TWin32FindDataW; + end; + + function FindFirstW(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer; + function FindNextW(var F: TSearchRecW): Integer; + procedure FindCloseW(var F: TSearchRecW); + function FindMatchingFileW(var F: TSearchRecW): Integer; + function DirectoryExistsW(const Directory: widestring): Boolean; +{$endif} + +implementation + +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} + + +{$IFDEF LAZARUS} + +function LazFindResource( const aName, aType : String ): TLResource; +var + iCount : Integer; +begin + result := nil; + + for iCount := 0 to LazarusResources.count -1 do + begin + if ( LazarusResources.items[ iCount ].Name = aName ) AND + ( LazarusResources.items[ iCount ].ValueType = aType ) THEN + begin + result := LazarusResources.items[ iCount ]; + exit; + end; + end; +end; +{$ENDIF} + +{$IFDEF FPC} +function MaxValue(const Data: array of Double): Double; +var + I: Integer; +begin + Result := Data[Low(Data)]; + for I := Low(Data) + 1 to High(Data) do + if Result < Data[I] then + Result := Data[I]; +end; + +function MinValue(const Data: array of Double): Double; +var + I: Integer; +begin + Result := Data[Low(Data)]; + for I := Low(Data) + 1 to High(Data) do + if Result > Data[I] then + Result := Data[I]; +end; + +function RandomRange(aMin: Integer; aMax: Integer) : Integer; +begin +RandomRange := Random(aMax-aMin) + aMin ; +end; + + +// NOTE !!!!!!!!!! +// AllocateHWnd is in lclintfh.inc + +{$IFDEF MSWINDOWS} +// TODO : JB this is dodgey and bad... find a REAL solution ! +function AllocateHWnd(Method: TWndMethod): HWND; +var + TempClass: TWndClass; + ClassRegistered: Boolean; +begin + Result := CreateWindowEx(WS_EX_TOOLWINDOW, '', '', WS_POPUP , 0, 0, 0, 0, 0, 0, HInstance, nil); +end; + +procedure DeallocateHWnd(Wnd: HWND); +var + Instance: Pointer; +begin + Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC)); + DestroyWindow(Wnd); +end; +{$ENDIF} +{$IFDEF DARWIN} +// TODO : Situation for the mac isn't better ! +function AllocateHWnd(Method: TWndMethod): HWND; +begin +end; + +procedure DeallocateHWnd(Wnd: HWND); +begin +end; +{$ENDIF} + + + + +{$ENDIF} + +{$ifNdef FPC} +function FindFirstW(const Path: widestring; Attr: Integer; var F: TSearchRecW): Integer; +const + faSpecial = faHidden or faSysFile or faVolumeID or faDirectory; +begin + F.ExcludeAttr := not Attr and faSpecial; + F.FindHandle := FindFirstFileW(PWideChar(Path), F.FindData); + if F.FindHandle <> INVALID_HANDLE_VALUE then + begin + Result := FindMatchingFileW(F); + if Result <> 0 then FindCloseW(F); + end else + Result := GetLastError; +end; + +function FindNextW(var F: TSearchRecW): Integer; +begin + if FindNextFileW(F.FindHandle, F.FindData) then + Result := FindMatchingFileW(F) + else + Result := GetLastError; +end; + +procedure FindCloseW(var F: TSearchRecW); +begin + if F.FindHandle <> INVALID_HANDLE_VALUE then + begin + Windows.FindClose(F.FindHandle); + F.FindHandle := INVALID_HANDLE_VALUE; + end; +end; + +function FindMatchingFileW(var F: TSearchRecW): Integer; +var + LocalFileTime: TFileTime; +begin + with F do + begin + while FindData.dwFileAttributes and ExcludeAttr <> 0 do + if not FindNextFileW(FindHandle, FindData) then + begin + Result := GetLastError; + Exit; + end; + FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); + FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, LongRec(Time).Lo); + Size := FindData.nFileSizeLow; + Attr := FindData.dwFileAttributes; + Name := FindData.cFileName; + end; + Result := 0; +end; + +function DirectoryExistsW(const Directory: widestring): Boolean; +var + Code: Integer; +begin + Code := GetFileAttributesW(PWideChar(Directory)); + Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); +end; +{$endif} + + + + + +end. diff --git a/Game/Code/Classes/UCore.pas b/Game/Code/Classes/UCore.pas index acd9ead7..e0f9fec2 100644 --- a/Game/Code/Classes/UCore.pas +++ b/Game/Code/Classes/UCore.pas @@ -1,501 +1,501 @@ -unit UCore; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses uPluginDefs, - uCoreModule, - UHooks, - UServices, - UModules; -{********************* - TCore - Class manages all CoreModules, teh StartUp, teh MainLoop and the shutdown process - Also it does some Error Handling, and maybe sometime multithreaded Loading ;) -*********************} - -type - TModuleListItem = record - Module: TCoreModule; //Instance of the Modules Class - Info: TModuleInfo; //ModuleInfo returned by Modules Modulinfo Proc - NeedsDeInit: Boolean; //True if Module was succesful inited - end; - - TCore = class - private - //Some Hook Handles. See Plugin SDKs Hooks.txt for Infos - hLoadingFinished: THandle; - hMainLoop: THandle; - hTranslate: THandle; - hLoadTextures: THandle; - hExitQuery: THandle; - hExit: THandle; - hDebug: THandle; - hError: THandle; - sReportError: THandle; - sReportDebug: THandle; - sShowMessage: THandle; - sRetranslate: THandle; - sReloadTextures: THandle; - sGetModuleInfo: THandle; - sGetApplicationHandle: THandle; - - Modules: Array [0..High(CORE_MODULES_TO_LOAD)] of TModuleListItem; - - //Function Get all Modules and Creates them - Function GetModules: Boolean; - - //Loads Core and all Modules - Function Load: Boolean; - - //Inits Core and all Modules - Function Init: Boolean; - - //DeInits Core and all Modules - Function DeInit: Boolean; - - //Load the Core - Function LoadCore: Boolean; - - //Init the Core - Function InitCore: Boolean; - - //DeInit the Core - Function DeInitCore: Boolean; - - //Called one Time per Frame - Function MainLoop: Boolean; - - public - Hooks: THookManager; //Teh Hook Manager ;) - Services: TServiceManager;//The Service Manager - - CurExecuted: Integer; //ID of Plugin or Module curently Executed - - Name: String; //Name of this Application - Version: LongWord; //Version of this ". For Info Look PluginDefs Functions - - LastErrorReporter:String; //Who Reported the Last Error String - LastErrorString: String; //Last Error String reported - - - //--------------- - //Main Methods to control the Core: - //--------------- - Constructor Create(const cName: String; const cVersion: LongWord); - - //Starts Loading and Init Process. Then Runs MainLoop. DeInits on Shutdown - Procedure Run; - - //Method for other Classes to get Pointer to a specific Module - Function GetModulebyName(const Name: String): PCoreModule; - - //-------------- - // Hook and Service Procs: - //-------------- - Function ShowMessage(wParam, lParam: DWord): integer; //Shows a Message (lParam: PChar Text, wParam: Symbol) - Function ReportError(wParam, lParam: DWord): integer; //Shows a Message (wParam: Pchar(Message), lParam: PChar(Reportername)) - Function ReportDebug(wParam, lParam: DWord): integer; //Shows a Message (wParam: Pchar(Message), lParam: PChar(Reportername)) - Function Retranslate(wParam, lParam: DWord): integer; //Calls Translate hook - Function ReloadTextures(wParam, lParam: DWord): integer; //Calls LoadTextures hook - Function GetModuleInfo(wParam, lParam: DWord): integer; //If lParam = nil then get length of Moduleinfo Array. If lparam <> nil then write array of TModuleInfo to address at lparam - Function GetApplicationHandle(wParam, lParam: DWord): integer; //Returns Application Handle - end; - -var - Core: TCore; - -implementation - -uses {$IFDEF win32} - Windows, - {$ENDIF} - SysUtils; - -//------------- -// Create - Creates Class + Hook and Service Manager -//------------- -Constructor TCore.Create(const cName: String; const cVersion: LongWord); -begin - Name := cName; - Version := cVersion; - CurExecuted := 0; - - LastErrorReporter := ''; - LastErrorString := ''; - - Hooks := THookManager.Create(50); - Services := TServiceManager.Create; -end; - -//------------- -//Starts Loading and Init Process. Then Runs MainLoop. DeInits on Shutdown -//------------- -Procedure TCore.Run; -var - noError: Boolean; -begin - //Get Modules - Try - noError := GetModules; - Except - noError := False; - end; - - //Loading - if (noError) then - begin - Try - noError := Load; - Except - noError := False; - end; - - if (noError) then - begin //Init - Try - noError := Init; - Except - noError := False; - end; - - If noError then - begin - //Call Translate Hook - noError := (Hooks.CallEventChain(hTranslate, 0, 0) = 0); - - If noError then - begin //Calls LoadTextures Hook - noError := (Hooks.CallEventChain(hLoadTextures, 0, 0) = 0); - - if noError then - begin //Calls Loading Finished Hook - noError := (Hooks.CallEventChain(hLoadingFinished, 0, 0) = 0); - - If noError then - begin - //Start MainLoop - While noError do - begin - noError := MainLoop; - // to-do : Call Display Draw here - end; - end - else - begin - If (LastErrorString <> '') then - Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error calling LoadingFinished Hook: ' + LastErrorString))) - else - Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error calling LoadingFinished Hook'))); - end; - end - else - begin - If (LastErrorString <> '') then - Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error loading textures: ' + LastErrorString))) - else - Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error loading textures'))); - end; - end - else - begin - If (LastErrorString <> '') then - Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error translating: ' + LastErrorString))) - else - Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error translating'))); - end; - - end - else - begin - If (LastErrorString <> '') then - Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error initing Modules: ' + LastErrorString))) - else - Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error initing Modules'))); - end; - end - else - begin - If (LastErrorString <> '') then - Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error loading Modules: ' + LastErrorString))) - else - Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error loading Modules'))); - end; - end - else - begin - If (LastErrorString <> '') then - Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error Getting Modules: ' + LastErrorString))) - else - Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error Getting Modules'))); - end; - - //DeInit - DeInit; -end; - -//------------- -//Called one Time per Frame -//------------- -Function TCore.MainLoop: Boolean; -begin - Result := False; - -end; - -//------------- -//Function Get all Modules and Creates them -//------------- -Function TCore.GetModules: Boolean; -var - I: Integer; -begin - Result := False; - try - For I := 0 to high(Modules) do - begin - Modules[I].NeedsDeInit := False; - Modules[I].Module := CORE_MODULES_TO_LOAD[I].Create; - Modules[I].Module.Info(@Modules[I].Info); - end; - Result := True; - except - ReportError(Integer(PChar('Can''t get module #' + InttoStr(I) + ' "' + Modules[I].Info.Name + '"')), Integer(PChar('Core'))); - end; -end; - -//------------- -//Loads Core and all Modules -//------------- -Function TCore.Load: Boolean; -var - I: Integer; -begin - Result := LoadCore; - - I := 0; - While ((Result = True) AND (I <= High(CORE_MODULES_TO_LOAD))) do - begin - try - Result := Modules[I].Module.Load; - except - Result := False; - ReportError(Integer(PChar('Error loading module #' + InttoStr(I) + ' "' + Modules[I].Info.Name + '"')), Integer(PChar('Core'))); - end; - - Inc(I); - end; -end; - -//------------- -//Inits Core and all Modules -//------------- -Function TCore.Init: Boolean; -var - I: Integer; -begin - Result := InitCore; - - I := 0; - While ((Result = True) AND (I <= High(CORE_MODULES_TO_LOAD))) do - begin - try - Result := Modules[I].Module.Init; - except - Result := False; - ReportError(Integer(PChar('Error initing module #' + InttoStr(I) + ' "' + Modules[I].Info.Name + '"')), Integer(PChar('Core'))); - end; - - Modules[I].NeedsDeInit := Result; - Inc(I); - end; -end; - -//------------- -//DeInits Core and all Modules -//------------- -Function TCore.DeInit: Boolean; -var - I: Integer; -label Continue; -begin - I := High(CORE_MODULES_TO_LOAD); - - Continue: - Try - While (I >= 0) do - begin - If (Modules[I].NeedsDeInit) then - Modules[I].Module.DeInit; - - Dec(I); - end; - Except - - - end; - If (I >= 0) then - GoTo Continue; - - DeInitCore; -end; - -//------------- -//Load the Core -//------------- -Function TCore.LoadCore: Boolean; -begin - hLoadingFinished := Hooks.AddEvent('Core/LoadingFinished'); - hMainLoop := Hooks.AddEvent('Core/MainLoop'); - hTranslate := Hooks.AddEvent('Core/Translate'); - hLoadTextures := Hooks.AddEvent('Core/LoadTextures'); - hExitQuery := Hooks.AddEvent('Core/ExitQuery'); - hExit := Hooks.AddEvent('Core/Exit'); - hDebug := Hooks.AddEvent('Core/NewDebugInfo'); - hError := Hooks.AddEvent('Core/NewError'); - - sReportError := Services.AddService('Core/ReportError', nil, Self.ReportError); - sReportDebug := Services.AddService('Core/ReportDebug', nil, Self.ReportDebug); - sShowMessage := Services.AddService('Core/ShowMessage', nil, Self.ShowMessage); - sRetranslate := Services.AddService('Core/Retranslate', nil, Self.Retranslate); - sReloadTextures := Services.AddService('Core/ReloadTextures', nil, Self.ReloadTextures); - sGetModuleInfo := Services.AddService('Core/GetModuleInfo', nil, Self.GetModuleInfo); - sGetApplicationHandle := Services.AddService('Core/GetApplicationHandle', nil, Self.GetApplicationHandle); - - //A little Test - Hooks.AddSubscriber('Core/NewError', HookTest); -end; - -//------------- -//Init the Core -//------------- -Function TCore.InitCore: Boolean; -begin - //Dont Init s.th. atm. -end; - -//------------- -//DeInit the Core -//------------- -Function TCore.DeInitCore: Boolean; -begin - - - // to-do : write TService-/HookManager.Free and call it here -end; - -//------------- -//Method for other Classes to get Pointer to a specific Module -//------------- -Function TCore.GetModulebyName(const Name: String): PCoreModule; -var I: Integer; -begin - Result := nil; - For I := 0 to high(Modules) do - If (Modules[I].Info.Name = Name) then - begin - Result := @Modules[I].Module; - Break; - end; -end; - -//------------- -// Shows a MessageDialog (lParam: PChar Text, wParam: Symbol) -//------------- -Function TCore.ShowMessage(wParam, lParam: DWord): integer; -var Params: Cardinal; -begin - Result := -1; - - {$IFDEF MSWINDOWS} - If (ptr(lParam)<>nil) then - begin - Params := MB_OK; - Case wParam of - CORE_SM_ERROR: Params := Params or MB_ICONERROR; - CORE_SM_WARNING: Params := Params or MB_ICONWARNING; - CORE_SM_INFO: Params := Params or MB_ICONINFORMATION; - end; - - //Anzeigen: - Result := Messagebox(0, ptr(lParam), PChar(Name), Params); - end; - {$ENDIF} - - // to-do : write ShowMessage for other OSes -end; - -//------------- -// Calls NewError HookChain (wParam: Pchar(Message), lParam: PChar(Reportername)) -//------------- -Function TCore.ReportError(wParam, lParam: DWord): integer; -begin - //Update LastErrorReporter and LastErrorString - LastErrorReporter := String(PChar(Pointer(lParam))); - LastErrorString := String(PChar(Pointer(wParam))); - - Hooks.CallEventChain(hError, wParam, lParam); -end; - -//------------- -// Calls NewDebugInfo HookChain (wParam: Pchar(Message), lParam: PChar(Reportername)) -//------------- -Function TCore.ReportDebug(wParam, lParam: DWord): integer; -begin - Hooks.CallEventChain(hDebug, wParam, lParam); -end; - -//------------- -// Calls Translate hook -//------------- -Function TCore.Retranslate(wParam, lParam: DWord): integer; -begin - Hooks.CallEventChain(hTranslate, 0, 1); -end; - -//------------- -// Calls LoadTextures hook -//------------- -Function TCore.ReloadTextures(wParam, lParam: DWord): integer; -begin - Hooks.CallEventChain(hLoadTextures, 0, 1); -end; - -//------------- -// If lParam = nil then get length of Moduleinfo Array. If lparam <> nil then write array of TModuleInfo to address at lparam -//------------- -Function TCore.GetModuleInfo(wParam, lParam: DWord): integer; -begin - if (Pointer(lParam) = nil) then - begin - Result := Length(Modules); - end - else - begin - Try - For Result := 0 to High(Modules) do - begin - AModuleInfo(Pointer(lParam))[Result].Name := Modules[Result].Info.Name; - AModuleInfo(Pointer(lParam))[Result].Version := Modules[Result].Info.Version; - AModuleInfo(Pointer(lParam))[Result].Description := Modules[Result].Info.Description; - end; - Except - Result := -1; - end; - end; -end; - -//------------- -// Returns Application Handle -//------------- -Function TCore.GetApplicationHandle(wParam, lParam: DWord): integer; -begin - Result := hInstance; -end; - -end. +unit UCore; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses uPluginDefs, + uCoreModule, + UHooks, + UServices, + UModules; +{********************* + TCore + Class manages all CoreModules, teh StartUp, teh MainLoop and the shutdown process + Also it does some Error Handling, and maybe sometime multithreaded Loading ;) +*********************} + +type + TModuleListItem = record + Module: TCoreModule; //Instance of the Modules Class + Info: TModuleInfo; //ModuleInfo returned by Modules Modulinfo Proc + NeedsDeInit: Boolean; //True if Module was succesful inited + end; + + TCore = class + private + //Some Hook Handles. See Plugin SDKs Hooks.txt for Infos + hLoadingFinished: THandle; + hMainLoop: THandle; + hTranslate: THandle; + hLoadTextures: THandle; + hExitQuery: THandle; + hExit: THandle; + hDebug: THandle; + hError: THandle; + sReportError: THandle; + sReportDebug: THandle; + sShowMessage: THandle; + sRetranslate: THandle; + sReloadTextures: THandle; + sGetModuleInfo: THandle; + sGetApplicationHandle: THandle; + + Modules: Array [0..High(CORE_MODULES_TO_LOAD)] of TModuleListItem; + + //Function Get all Modules and Creates them + Function GetModules: Boolean; + + //Loads Core and all Modules + Function Load: Boolean; + + //Inits Core and all Modules + Function Init: Boolean; + + //DeInits Core and all Modules + Function DeInit: Boolean; + + //Load the Core + Function LoadCore: Boolean; + + //Init the Core + Function InitCore: Boolean; + + //DeInit the Core + Function DeInitCore: Boolean; + + //Called one Time per Frame + Function MainLoop: Boolean; + + public + Hooks: THookManager; //Teh Hook Manager ;) + Services: TServiceManager;//The Service Manager + + CurExecuted: Integer; //ID of Plugin or Module curently Executed + + Name: String; //Name of this Application + Version: LongWord; //Version of this ". For Info Look PluginDefs Functions + + LastErrorReporter:String; //Who Reported the Last Error String + LastErrorString: String; //Last Error String reported + + + //--------------- + //Main Methods to control the Core: + //--------------- + Constructor Create(const cName: String; const cVersion: LongWord); + + //Starts Loading and Init Process. Then Runs MainLoop. DeInits on Shutdown + Procedure Run; + + //Method for other Classes to get Pointer to a specific Module + Function GetModulebyName(const Name: String): PCoreModule; + + //-------------- + // Hook and Service Procs: + //-------------- + Function ShowMessage(wParam, lParam: DWord): integer; //Shows a Message (lParam: PChar Text, wParam: Symbol) + Function ReportError(wParam, lParam: DWord): integer; //Shows a Message (wParam: Pchar(Message), lParam: PChar(Reportername)) + Function ReportDebug(wParam, lParam: DWord): integer; //Shows a Message (wParam: Pchar(Message), lParam: PChar(Reportername)) + Function Retranslate(wParam, lParam: DWord): integer; //Calls Translate hook + Function ReloadTextures(wParam, lParam: DWord): integer; //Calls LoadTextures hook + Function GetModuleInfo(wParam, lParam: DWord): integer; //If lParam = nil then get length of Moduleinfo Array. If lparam <> nil then write array of TModuleInfo to address at lparam + Function GetApplicationHandle(wParam, lParam: DWord): integer; //Returns Application Handle + end; + +var + Core: TCore; + +implementation + +uses {$IFDEF win32} + Windows, + {$ENDIF} + SysUtils; + +//------------- +// Create - Creates Class + Hook and Service Manager +//------------- +Constructor TCore.Create(const cName: String; const cVersion: LongWord); +begin + Name := cName; + Version := cVersion; + CurExecuted := 0; + + LastErrorReporter := ''; + LastErrorString := ''; + + Hooks := THookManager.Create(50); + Services := TServiceManager.Create; +end; + +//------------- +//Starts Loading and Init Process. Then Runs MainLoop. DeInits on Shutdown +//------------- +Procedure TCore.Run; +var + noError: Boolean; +begin + //Get Modules + Try + noError := GetModules; + Except + noError := False; + end; + + //Loading + if (noError) then + begin + Try + noError := Load; + Except + noError := False; + end; + + if (noError) then + begin //Init + Try + noError := Init; + Except + noError := False; + end; + + If noError then + begin + //Call Translate Hook + noError := (Hooks.CallEventChain(hTranslate, 0, 0) = 0); + + If noError then + begin //Calls LoadTextures Hook + noError := (Hooks.CallEventChain(hLoadTextures, 0, 0) = 0); + + if noError then + begin //Calls Loading Finished Hook + noError := (Hooks.CallEventChain(hLoadingFinished, 0, 0) = 0); + + If noError then + begin + //Start MainLoop + While noError do + begin + noError := MainLoop; + // to-do : Call Display Draw here + end; + end + else + begin + If (LastErrorString <> '') then + Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error calling LoadingFinished Hook: ' + LastErrorString))) + else + Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error calling LoadingFinished Hook'))); + end; + end + else + begin + If (LastErrorString <> '') then + Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error loading textures: ' + LastErrorString))) + else + Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error loading textures'))); + end; + end + else + begin + If (LastErrorString <> '') then + Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error translating: ' + LastErrorString))) + else + Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error translating'))); + end; + + end + else + begin + If (LastErrorString <> '') then + Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error initing Modules: ' + LastErrorString))) + else + Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error initing Modules'))); + end; + end + else + begin + If (LastErrorString <> '') then + Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error loading Modules: ' + LastErrorString))) + else + Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error loading Modules'))); + end; + end + else + begin + If (LastErrorString <> '') then + Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error Getting Modules: ' + LastErrorString))) + else + Self.ShowMessage(CORE_SM_ERROR, Integer(PChar('Error Getting Modules'))); + end; + + //DeInit + DeInit; +end; + +//------------- +//Called one Time per Frame +//------------- +Function TCore.MainLoop: Boolean; +begin + Result := False; + +end; + +//------------- +//Function Get all Modules and Creates them +//------------- +Function TCore.GetModules: Boolean; +var + I: Integer; +begin + Result := False; + try + For I := 0 to high(Modules) do + begin + Modules[I].NeedsDeInit := False; + Modules[I].Module := CORE_MODULES_TO_LOAD[I].Create; + Modules[I].Module.Info(@Modules[I].Info); + end; + Result := True; + except + ReportError(Integer(PChar('Can''t get module #' + InttoStr(I) + ' "' + Modules[I].Info.Name + '"')), Integer(PChar('Core'))); + end; +end; + +//------------- +//Loads Core and all Modules +//------------- +Function TCore.Load: Boolean; +var + I: Integer; +begin + Result := LoadCore; + + I := 0; + While ((Result = True) AND (I <= High(CORE_MODULES_TO_LOAD))) do + begin + try + Result := Modules[I].Module.Load; + except + Result := False; + ReportError(Integer(PChar('Error loading module #' + InttoStr(I) + ' "' + Modules[I].Info.Name + '"')), Integer(PChar('Core'))); + end; + + Inc(I); + end; +end; + +//------------- +//Inits Core and all Modules +//------------- +Function TCore.Init: Boolean; +var + I: Integer; +begin + Result := InitCore; + + I := 0; + While ((Result = True) AND (I <= High(CORE_MODULES_TO_LOAD))) do + begin + try + Result := Modules[I].Module.Init; + except + Result := False; + ReportError(Integer(PChar('Error initing module #' + InttoStr(I) + ' "' + Modules[I].Info.Name + '"')), Integer(PChar('Core'))); + end; + + Modules[I].NeedsDeInit := Result; + Inc(I); + end; +end; + +//------------- +//DeInits Core and all Modules +//------------- +Function TCore.DeInit: Boolean; +var + I: Integer; +label Continue; +begin + I := High(CORE_MODULES_TO_LOAD); + + Continue: + Try + While (I >= 0) do + begin + If (Modules[I].NeedsDeInit) then + Modules[I].Module.DeInit; + + Dec(I); + end; + Except + + + end; + If (I >= 0) then + GoTo Continue; + + DeInitCore; +end; + +//------------- +//Load the Core +//------------- +Function TCore.LoadCore: Boolean; +begin + hLoadingFinished := Hooks.AddEvent('Core/LoadingFinished'); + hMainLoop := Hooks.AddEvent('Core/MainLoop'); + hTranslate := Hooks.AddEvent('Core/Translate'); + hLoadTextures := Hooks.AddEvent('Core/LoadTextures'); + hExitQuery := Hooks.AddEvent('Core/ExitQuery'); + hExit := Hooks.AddEvent('Core/Exit'); + hDebug := Hooks.AddEvent('Core/NewDebugInfo'); + hError := Hooks.AddEvent('Core/NewError'); + + sReportError := Services.AddService('Core/ReportError', nil, Self.ReportError); + sReportDebug := Services.AddService('Core/ReportDebug', nil, Self.ReportDebug); + sShowMessage := Services.AddService('Core/ShowMessage', nil, Self.ShowMessage); + sRetranslate := Services.AddService('Core/Retranslate', nil, Self.Retranslate); + sReloadTextures := Services.AddService('Core/ReloadTextures', nil, Self.ReloadTextures); + sGetModuleInfo := Services.AddService('Core/GetModuleInfo', nil, Self.GetModuleInfo); + sGetApplicationHandle := Services.AddService('Core/GetApplicationHandle', nil, Self.GetApplicationHandle); + + //A little Test + Hooks.AddSubscriber('Core/NewError', HookTest); +end; + +//------------- +//Init the Core +//------------- +Function TCore.InitCore: Boolean; +begin + //Dont Init s.th. atm. +end; + +//------------- +//DeInit the Core +//------------- +Function TCore.DeInitCore: Boolean; +begin + + + // to-do : write TService-/HookManager.Free and call it here +end; + +//------------- +//Method for other Classes to get Pointer to a specific Module +//------------- +Function TCore.GetModulebyName(const Name: String): PCoreModule; +var I: Integer; +begin + Result := nil; + For I := 0 to high(Modules) do + If (Modules[I].Info.Name = Name) then + begin + Result := @Modules[I].Module; + Break; + end; +end; + +//------------- +// Shows a MessageDialog (lParam: PChar Text, wParam: Symbol) +//------------- +Function TCore.ShowMessage(wParam, lParam: DWord): integer; +var Params: Cardinal; +begin + Result := -1; + + {$IFDEF Delphi} + If (ptr(lParam)<>nil) then + begin + Params := MB_OK; + Case wParam of + CORE_SM_ERROR: Params := Params or MB_ICONERROR; + CORE_SM_WARNING: Params := Params or MB_ICONWARNING; + CORE_SM_INFO: Params := Params or MB_ICONINFORMATION; + end; + + //Anzeigen: + Result := Messagebox(0, ptr(lParam), PChar(Name), Params); + end; + {$ENDIF} + + // to-do : write ShowMessage for other OSes +end; + +//------------- +// Calls NewError HookChain (wParam: Pchar(Message), lParam: PChar(Reportername)) +//------------- +Function TCore.ReportError(wParam, lParam: DWord): integer; +begin + //Update LastErrorReporter and LastErrorString + LastErrorReporter := String(PChar(Pointer(lParam))); + LastErrorString := String(PChar(Pointer(wParam))); + + Hooks.CallEventChain(hError, wParam, lParam); +end; + +//------------- +// Calls NewDebugInfo HookChain (wParam: Pchar(Message), lParam: PChar(Reportername)) +//------------- +Function TCore.ReportDebug(wParam, lParam: DWord): integer; +begin + Hooks.CallEventChain(hDebug, wParam, lParam); +end; + +//------------- +// Calls Translate hook +//------------- +Function TCore.Retranslate(wParam, lParam: DWord): integer; +begin + Hooks.CallEventChain(hTranslate, 0, 1); +end; + +//------------- +// Calls LoadTextures hook +//------------- +Function TCore.ReloadTextures(wParam, lParam: DWord): integer; +begin + Hooks.CallEventChain(hLoadTextures, 0, 1); +end; + +//------------- +// If lParam = nil then get length of Moduleinfo Array. If lparam <> nil then write array of TModuleInfo to address at lparam +//------------- +Function TCore.GetModuleInfo(wParam, lParam: DWord): integer; +begin + if (Pointer(lParam) = nil) then + begin + Result := Length(Modules); + end + else + begin + Try + For Result := 0 to High(Modules) do + begin + AModuleInfo(Pointer(lParam))[Result].Name := Modules[Result].Info.Name; + AModuleInfo(Pointer(lParam))[Result].Version := Modules[Result].Info.Version; + AModuleInfo(Pointer(lParam))[Result].Description := Modules[Result].Info.Description; + end; + Except + Result := -1; + end; + end; +end; + +//------------- +// Returns Application Handle +//------------- +Function TCore.GetApplicationHandle(wParam, lParam: DWord): integer; +begin + Result := hInstance; +end; + +end. diff --git a/Game/Code/Classes/USongs.pas b/Game/Code/Classes/USongs.pas index 7fd58034..2fa3ea4a 100644 --- a/Game/Code/Classes/USongs.pas +++ b/Game/Code/Classes/USongs.pas @@ -1,1043 +1,1045 @@ -unit USongs; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - {$IFDEF MSWINDOWS} - Windows, - DirWatch, - {$ELSE} - {$IFNDEF DARWIN} - oldlinux, - syscall, - {$ENDIF} - baseunix, - UnixType, - {$ENDIF} - SysUtils, - Classes, - ULog, - UTexture, - UCommon, - UCatCovers; - -type - - TBPM = record - BPM: real; - StartBeat: real; - end; - - TScore = record - Name: widestring; - Score: integer; - Length: string; - end; - - TSong = record - Path: widestring; - Folder: widestring; // for sorting by folder - FileName: widestring; - - // sorting methods - Category: array of widestring; // I think I won't need this - Genre: widestring; - Edition: widestring; - Language: widestring; // 0.5.0: new - - Title: widestring; - Artist: widestring; - - Text: widestring; - Creator: widestring; - - Cover: widestring; - CoverTex: TTexture; - Mp3: widestring; - Background: widestring; - Video: widestring; - VideoGAP: real; - VideoLoaded: boolean; // 0.5.0: true if the video has been loaded - NotesGAP: integer; - Start: real; // in seconds - Finish: integer; // in miliseconds - Relative: boolean; - Resolution: integer; - BPM: array of TBPM; - GAP: real; // in miliseconds - - Score: array[0..2] of array of TScore; - - // these are used when sorting is enabled - Visible: boolean; // false if hidden, true if visible - Main: boolean; // false for songs, true for category buttons - OrderNum: integer; // has a number of category for category buttons and songs - OrderTyp: integer; // type of sorting for this button (0=name) - CatNumber: integer; // Count of Songs in Category for Cats and Number of Song in Category for Songs - end; - - TSongs = class( TThread ) - private - BrowsePos : Cardinal; //Actual Pos in Song Array - fNotify , - fWatch : longint; - fParseSongDirectory : boolean; - fProcessing : boolean; - {$ifdef MSWINDOWS} - fDirWatch : TDirectoryWatch; - {$endif} - procedure int_LoadSongList; - procedure DoDirChanged(Sender: TObject); - protected - procedure Execute; override; - public - Song : array of TSong; // array of songs - Selected : integer; // selected song index - constructor create(); - procedure LoadSongList; // load all songs - procedure BrowseDir(Dir: widestring); // should return number of songs in the future - procedure Sort(Order: integer); - function FindSongFile(Dir, Mask: widestring): widestring; - property Processing : boolean read fProcessing; - end; - - TCatSongs = class - Song: array of TSong; // array of categories with songs - Selected: integer; // selected song index - Order: integer; // order type (0=title) - CatNumShow: integer; // Category Number being seen - CatCount: integer; //Number of Categorys - - procedure Refresh; // refreshes arrays by recreating them from Songs array -// procedure Sort(Order: integer); - procedure ShowCategory(Index: integer); // expands all songs in category - procedure HideCategory(Index: integer); // hides all songs in category - procedure ClickCategoryButton(Index: integer); // uses ShowCategory and HideCategory when needed - procedure ShowCategoryList; //Hides all Songs And Show the List of all Categorys - function FindNextVisible(SearchFrom:integer): integer; //Find Next visible Song - function VisibleSongs: integer; // returns number of visible songs (for tabs) - function VisibleIndex(Index: integer): integer; // returns visible song index (skips invisible) - - function SetFilter(FilterStr: String; const fType: Byte): Cardinal; - end; - -var - Songs: TSongs; // all songs - CatSongs: TCatSongs; // categorized songs - AktSong: TSong; // one song *unknown use) - -const - IN_ACCESS = $00000001; //* File was accessed */ - IN_MODIFY = $00000002; //* File was modified */ - IN_ATTRIB = $00000004; //* Metadata changed */ - IN_CLOSE_WRITE = $00000008; //* Writtable file was closed */ - IN_CLOSE_NOWRITE = $00000010; //* Unwrittable file closed */ - IN_OPEN = $00000020; //* File was opened */ - IN_MOVED_FROM = $00000040; //* File was moved from X */ - IN_MOVED_TO = $00000080; //* File was moved to Y */ - IN_CREATE = $00000100; //* Subfile was created */ - IN_DELETE = $00000200; //* Subfile was deleted */ - IN_DELETE_SELF = $00000400; //* Self was deleted */ - - -implementation - -uses StrUtils, - UGraphic, - UCovers, - UFiles, - UMain, - UIni; - -{$IFDEF DARWIN} -function AnsiContainsText(const AText, ASubText: string): Boolean; -begin - Result := AnsiPos(AnsiUppercase(ASubText), AnsiUppercase(AText)) > 0; -end; -{$ENDIF} - -constructor TSongs.create(); -begin - inherited create( false ); - self.freeonterminate := true; - - {$IFDEF MSWINDOWS} - fDirWatch := TDirectoryWatch.create(nil); - fDirWatch.OnChange := DoDirChanged; - fDirWatch.Directory := SongPath; - fDirWatch.WatchSubDirs := true; - fDirWatch.active := true; - {$ENDIF} - - {$IFDEF linux} - (* - Thankyou to : http://www.linuxjournal.com/article/8478 - http://www.tin.org/bin/man.cgi?section=2&topic=inotify_add_watch - *) -(* - fNotify := -1; - fWatch := -1; - - writeln( 'Calling inotify_init' ); - fNotify := Do_SysCall( syscall_nr_inotify_init ); - if ( fNotify < 0 ) then - writeln( 'Filesystem change notification - disabled' ); - writeln( 'Calling inotify_init : '+ inttostr(fNotify) ); - - writeln( 'Calling syscall_nr_inotify_init ('+SongPath+')' ); - fWatch := Do_SysCall( syscall_nr_inotify_init , TSysParam( fNotify ), longint( pchar( SongPath ) ) , IN_MODIFY AND IN_CREATE AND IN_DELETE ); - - if (fWatch < 0) then - writeln ('inotify_add_watch'); - writeln( 'Calling syscall_nr_inotify_init : '+ inttostr(fWatch) ); -*) - {$endif} - - Setlength(Song, 0); -end; - -procedure TSongs.DoDirChanged(Sender: TObject); -begin - LoadSongList(); -end; - -procedure TSongs.Execute(); -var - fChangeNotify : THandle; -begin - fParseSongDirectory := true; - - while not self.terminated do - begin - - if fParseSongDirectory then - begin - writeln( 'int_LoadSongList' ); - int_LoadSongList(); - end; - - self.suspend; - end; - -end; - -procedure TSongs.int_LoadSongList; -begin - try - fProcessing := true; - Setlength(Song, 0); - - Log.LogError('SongList', 'Searching For Songs'); - - Setlength(Song, 50); - - BrowsePos := 0; - // browse directories - BrowseDir(SongPath); - - //Set Correct SongArray Length - SetLength(Song, BrowsePos); - - if assigned( CatSongs ) then - CatSongs.Refresh; - - if assigned( CatCovers ) then - CatCovers.Load; - - if assigned( Covers ) then - Covers.Load; - - if assigned(ScreenSong) then - begin - ScreenSong.GenerateThumbnails(); - ScreenSong.OnShow; // refresh ScreenSong - end; - - - finally - Log.LogError('SongList', 'Search Complete'); - - fParseSongDirectory := false; - fProcessing := false; - end; -end; - - -procedure TSongs.LoadSongList; -begin - fParseSongDirectory := true; - self.resume; -end; - -// TODO : JB - THis whole function SUX ! and needs refactoring ! :P -procedure TSongs.BrowseDir(Dir: widestring); -var - SLen: integer; - - {$ifdef MSWINDOWS} - SR: TSearchRecW; // for parsing Songs Directory - {$ENDIF} - - // eddie: can we merge that? is baseunix working on linux? oldlinux is - // not available on mac os x. - {$IFDEF LINUX} - TheDir : oldlinux.pdir; - ADirent : oldlinux.pDirent; - Entry : Longint; - info : oldlinux.stat; - {$ENDIF} - {$IFDEF DARWIN} - TheDir : pdir; - ADirent : pDirent; - Entry : Longint; - info : stat; - {$ENDIF} -begin - {$ifdef MSWINDOWS} - if FindFirstW(Dir + '*', faDirectory, SR) = 0 then // JB_Unicode - windows - begin - repeat - if (SR.Name <> '.') and (SR.Name <> '..') then - begin - BrowseDir(Dir + Sr.Name + PathDelim); - end - until FindNextw(SR) <> 0; - end; // if - FindClosew(SR); - - if FindFirstW(Dir + '*.txt', 0, SR) = 0 then - begin - repeat - SLen := BrowsePos; - - Song[SLen].Path := Dir; - Song[SLen].Folder := Copy(Dir, Length(SongPath)+1, 10000); - Song[SLen].Folder := Copy(Song[SLen].Folder, 1, Pos( PathDelim , Song[SLen].Folder)-1); - Song[SLen].FileName := SR.Name; - - if (AnalyseFile(Song[SLen]) = false) then - Dec(BrowsePos) - else - begin - if Song[SLen].Cover = '' then - Song[SLen].Cover := FindSongFile(Dir, '*[CO].jpg'); - end; - - //Change Length Only every 50 Entrys - Inc(BrowsePos); - - if (BrowsePos mod 50 = 0) AND (BrowsePos <> 0) then - begin - SetLength(Song, Length(Song) + 50); - end; - - until FindNextW(SR) <> 0; - end; // if FindFirst - FindCloseW(SR); - {$ENDIF} - - {$IFDEF LINUX} - // Itterate the Songs Directory... ( With unicode capable functions for linux ) - TheDir := oldlinux.opendir( Dir ); // JB_Unicode - linux - if TheDir <> nil then - begin - repeat - ADirent := oldlinux.ReadDir(TheDir); - - If ADirent<>Nil then - begin - With ADirent^ do - begin - - if ( name[0] <> '.') then - BrowseDir( Dir + name + pathdelim ); - - end; - end; - Until ADirent=Nil; - end; - - - - TheDir := oldlinux.opendir( Dir ); // JB_Unicode - linux - if TheDir <> nil then - begin - repeat - ADirent := oldlinux.ReadDir(TheDir); - - if ( ADirent <> Nil ) AND - ( pos( '.txt', ADirent^.name ) > 0 ) then - begin - writeln ('***** FOUND TXT' + ADirent^.name ); - - SLen := BrowsePos; - - Song[SLen].Path := Dir; - Song[SLen].Folder := Copy(Dir, Length(SongPath)+1, 10000); - Song[SLen].Folder := Copy(Song[SLen].Folder, 1, Pos( PathDelim , Song[SLen].Folder)-1); - Song[SLen].FileName := ADirent^.name; - - if (AnalyseFile(Song[SLen]) = false) then - Dec(BrowsePos) - else - begin - if Song[SLen].Cover = '' then - Song[SLen].Cover := FindSongFile(Dir, '*[CO].jpg'); - end; - - //Change Length Only every 50 Entrys - Inc(BrowsePos); - if (BrowsePos mod 50 = 0) AND (BrowsePos <> 0) then - begin - SetLength(Song, Length(Song) + 50); - end; - end; - - Until ADirent=Nil; - end; // if FindFirst - {$endif} - - {$IFDEF DARWIN} - // Itterate the Songs Directory... ( With unicode capable functions for linux ) - TheDir := FPOpenDir( Dir ); // JB_Unicode - linux - if TheDir <> nil then - begin - repeat - ADirent := FPReadDir(TheDir); - - If ADirent<>Nil then - begin - With ADirent^ do - begin - - if ( d_name[0] <> '.') then - BrowseDir( Dir + d_name + pathdelim ); - - end; - end; - Until ADirent=Nil; - end; - - - - TheDir := FPOpenDir( Dir ); // JB_Unicode - linux - if TheDir <> nil then - begin - repeat - ADirent := FPReadDir(TheDir); - - if ( ADirent <> Nil ) AND - ( pos( '.txt', ADirent^.d_name ) > -1 ) then - begin - SLen := BrowsePos; - - Song[SLen].Path := Dir; - Song[SLen].Folder := Copy(Dir, Length(SongPath)+1, 10000); - Song[SLen].Folder := Copy(Song[SLen].Folder, 1, Pos( PathDelim , Song[SLen].Folder)-1); - Song[SLen].FileName := ADirent^.d_name; - - if (AnalyseFile(Song[SLen]) = false) then - Dec(BrowsePos) - else - begin - if Song[SLen].Cover = '' then - Song[SLen].Cover := FindSongFile(Dir, '*[CO].jpg'); - end; - - //Change Length Only every 50 Entrys - Inc(BrowsePos); - - if (BrowsePos mod 50 = 0) AND (BrowsePos <> 0) then - begin - SetLength(Song, Length(Song) + 50); - end; - end; - - Until ADirent=Nil; - end; // if FindFirst - - {$endif} - -// Log.LogStatus('Parsing directory: ' + Dir + SR.Name, 'LoadSongList'); - - -end; - -procedure TSongs.Sort(Order: integer); -var - S: integer; - S2: integer; - TempSong: TSong; -begin - case Order of - sEdition: // by edition - begin - for S2 := 0 to Length(Song)-1 do - for S := 1 to Length(Song)-1 do - if CompareText(Song[S].Edition, Song[S-1].Edition) < 0 then begin - // zamiana miejscami - TempSong := Song[S-1]; - Song[S-1] := Song[S]; - Song[S] := TempSong; - end; - end; - sGenre: // by genre - begin - for S2 := 0 to Length(Song)-1 do - for S := 1 to Length(Song)-1 do - if CompareText(Song[S].Genre, Song[S-1].Genre) < 0 then begin - // zamiana miejscami - TempSong := Song[S-1]; - Song[S-1] := Song[S]; - Song[S] := TempSong; - end; - end; - sTitle: // by title - begin - for S2 := 0 to Length(Song)-1 do - for S := 1 to Length(Song)-1 do - if CompareText(Song[S].Title, Song[S-1].Title) < 0 then begin - // zamiana miejscami - TempSong := Song[S-1]; - Song[S-1] := Song[S]; - Song[S] := TempSong; - end; - - end; - sArtist: // by artist - begin - for S2 := 0 to Length(Song)-1 do - for S := 1 to Length(Song)-1 do - if CompareText(Song[S].Artist, Song[S-1].Artist) < 0 then begin - // zamiana miejscami - TempSong := Song[S-1]; - Song[S-1] := Song[S]; - Song[S] := TempSong; - end; - end; - sFolder: // by folder - begin - for S2 := 0 to Length(Song)-1 do - for S := 1 to Length(Song)-1 do - if CompareText(Song[S].Folder, Song[S-1].Folder) < 0 then begin - // zamiana miejscami - TempSong := Song[S-1]; - Song[S-1] := Song[S]; - Song[S] := TempSong; - end; - end; - sTitle2: // by title2 - begin - for S2 := 0 to Length(Song)-1 do - for S := 1 to Length(Song)-1 do - if CompareText(Song[S].Title, Song[S-1].Title) < 0 then begin - // zamiana miejscami - TempSong := Song[S-1]; - Song[S-1] := Song[S]; - Song[S] := TempSong; - end; - - end; - sArtist2: // by artist2 - begin - for S2 := 0 to Length(Song)-1 do - for S := 1 to Length(Song)-1 do - if CompareText(Song[S].Artist, Song[S-1].Artist) < 0 then begin - // zamiana miejscami - TempSong := Song[S-1]; - Song[S-1] := Song[S]; - Song[S] := TempSong; - end; - end; - sLanguage: // by Language - begin - for S2 := 0 to Length(Song)-1 do - for S := 1 to Length(Song)-1 do - if CompareText(Song[S].Language, Song[S-1].Language) < 0 then begin - TempSong := Song[S-1]; - Song[S-1] := Song[S]; - Song[S] := TempSong; - end; - end; - - end; // case -end; - -function TSongs.FindSongFile(Dir, Mask: widestring): widestring; -var - SR: TSearchRec; // for parsing song directory -begin - Result := ''; - if FindFirst(Dir + Mask, faDirectory, SR) = 0 then begin - Result := SR.Name; - end; // if - FindClose(SR); -end; - -procedure TCatSongs.Refresh; -var - S: integer; // temporary song index - CatLen: integer; // length of CatSongs.Song - Letter: char; // current letter for sorting using letter - SS: string; // current edition for sorting using edition, genre etc. - Order: integer; // number used for ordernum - Letter2: char; // - CatNumber:integer; // Number of Song in Category -begin - CatNumShow := -1; -// Songs.Sort(0); // by title - -case Ini.Sorting of - sEdition: begin - Songs.Sort(sArtist); - Songs.Sort(sEdition); - end; - sGenre: begin - Songs.Sort(sArtist); - Songs.Sort(sGenre); - end; - sLanguage: begin - Songs.Sort(sArtist); - Songs.Sort(sLanguage); - end; - sFolder: begin - Songs.Sort(sArtist); - Songs.Sort(sFolder); - end; - sTitle: Songs.Sort(sTitle); - sArtist: Songs.Sort(sArtist); - sTitle2: Songs.Sort(sTitle2); // by title2 - sArtist2: Songs.Sort(sArtist2); // by artist2 - - end; // case - - - Letter := ' '; - SS := ''; - Order := 0; - CatNumber := 0; - - //Songs leeren - SetLength (Song, 0); - - for S := Low(Songs.Song) to High(Songs.Song) do begin - if (Ini.Tabs = 1) then - if (Ini.Sorting = sEdition) and (CompareText(SS, Songs.Song[S].Edition) <> 0) then begin - // add Category Button - Inc(Order); - SS := Songs.Song[S].Edition; - CatLen := Length(CatSongs.Song); - SetLength(CatSongs.Song, CatLen+1); - CatSongs.Song[CatLen].Artist := '[' + SS + ']'; - CatSongs.Song[CatLen].Main := true; - CatSongs.Song[CatLen].OrderTyp := 0; - CatSongs.Song[CatLen].OrderNum := Order; - - - - // 0.4.3 - // if SS = 'Singstar' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar.jpg'; - // if SS = 'Singstar Part 2' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar.jpg'; - // if SS = 'Singstar German' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar.jpg'; - // if SS = 'Singstar Spanish' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar.jpg'; - // if SS = 'Singstar Italian' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar.jpg'; - // if SS = 'Singstar French' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar.jpg'; - // if SS = 'Singstar Party' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar Party.jpg'; - // if SS = 'Singstar Popworld' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar Popworld.jpg'; - // if SS = 'Singstar 80s' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar 80s.jpg'; - // if SS = 'Singstar 80s Polish' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar 80s.jpg'; - // if SS = 'Singstar Rocks' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar Rocks.jpg'; - // if SS = 'Singstar Anthems' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar Anthems.jpg'; - - {// cover-patch - if FileExists(CoversPath + SS + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + SS + '.jpg' - else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';//} - - CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, SS); - - //CatNumber Patch - if (SS <> '') then - begin - Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy - CatNumber := 0; - end; - - CatSongs.Song[CatLen].Visible := true; - end - - else if (Ini.Sorting = sGenre) and (CompareText(SS, Songs.Song[S].Genre) <> 0) then begin - // add Genre Button - Inc(Order); - SS := Songs.Song[S].Genre; - CatLen := Length(CatSongs.Song); - SetLength(CatSongs.Song, CatLen+1); - CatSongs.Song[CatLen].Artist := SS; - CatSongs.Song[CatLen].Main := true; - CatSongs.Song[CatLen].OrderTyp := 0; - CatSongs.Song[CatLen].OrderNum := Order; - - {// cover-patch - if FileExists(CoversPath + SS + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + SS + '.jpg' - else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';} - CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, SS); - - //CatNumber Patch - if (SS <> '') then - begin - Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy - CatNumber := 0; - end; - - CatSongs.Song[CatLen].Visible := true; - end - - else if (Ini.Sorting = sLanguage) and (CompareText(SS, Songs.Song[S].Language) <> 0) then begin - // add Language Button - Inc(Order); - SS := Songs.Song[S].Language; - CatLen := Length(CatSongs.Song); - SetLength(CatSongs.Song, CatLen+1); - CatSongs.Song[CatLen].Artist := SS; - CatSongs.Song[CatLen].Main := true; - CatSongs.Song[CatLen].OrderTyp := 0; - CatSongs.Song[CatLen].OrderNum := Order; - - {// cover-patch - if FileExists(CoversPath + SS + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + SS + '.jpg' - else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';} - CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, SS); - - //CatNumber Patch - if (SS <> '') then - begin - Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy - CatNumber := 0; - end; - - CatSongs.Song[CatLen].Visible := true; - end - - else if (Ini.Sorting = sTitle) and - (Length(Songs.Song[S].Title)>=1) and - (Letter <> UpperCase(Songs.Song[S].Title)[1]) then begin - // add a letter Category Button - Inc(Order); - Letter := Uppercase(Songs.Song[S].Title)[1]; - CatLen := Length(CatSongs.Song); - SetLength(CatSongs.Song, CatLen+1); - CatSongs.Song[CatLen].Artist := '[' + Letter + ']'; - CatSongs.Song[CatLen].Main := true; - CatSongs.Song[CatLen].OrderTyp := 0; -// Order := ord(Letter); - CatSongs.Song[CatLen].OrderNum := Order; - - - {// cover-patch - if FileExists(CoversPath + 'Title' + Letter + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'Title' + Letter + '.jpg' - else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';} - CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, Letter); - - //CatNumber Patch - if (Letter <> ' ') then - begin - Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy - CatNumber := 0; - end; - - CatSongs.Song[CatLen].Visible := true; - end - - else if (Ini.Sorting = sArtist) and (Length(Songs.Song[S].Artist)>=1) and (Letter <> UpperCase(Songs.Song[S].Artist)[1]) then begin - // add a letter Category Button - Inc(Order); - Letter := UpperCase(Songs.Song[S].Artist)[1]; - CatLen := Length(CatSongs.Song); - SetLength(CatSongs.Song, CatLen+1); - CatSongs.Song[CatLen].Artist := '[' + Letter + ']'; - CatSongs.Song[CatLen].Main := true; - CatSongs.Song[CatLen].OrderTyp := 0; -// Order := ord(Letter); - CatSongs.Song[CatLen].OrderNum := Order; - - {// cover-patch - if FileExists(CoversPath + 'Artist' + Letter + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'Artist' + Letter + '.jpg' - else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';} - CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, Letter); - - //CatNumber Patch - if (Letter <> ' ') then - begin - Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy - CatNumber := 0; - end; - - CatSongs.Song[CatLen].Visible := true; - end - - else if (Ini.Sorting = sFolder) and (CompareText(SS, Songs.Song[S].Folder) <> 0) then begin - // 0.5.0: add folder tab - Inc(Order); - SS := Songs.Song[S].Folder; - CatLen := Length(CatSongs.Song); - SetLength(CatSongs.Song, CatLen+1); - CatSongs.Song[CatLen].Artist := SS; - CatSongs.Song[CatLen].Main := true; - CatSongs.Song[CatLen].OrderTyp := 0; - CatSongs.Song[CatLen].OrderNum := Order; - - {// cover-patch - if FileExists(CoversPath + SS + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + SS + '.jpg' - else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';} - CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, SS); - - //CatNumber Patch - if (SS <> '') then - begin - Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy - CatNumber := 0; - end; - - CatSongs.Song[CatLen].Visible := true; - end - - else if (Ini.Sorting = sTitle2) AND (Length(Songs.Song[S].Title)>=1) then begin - if (ord(Songs.Song[S].Title[1]) > 47) and (ord(Songs.Song[S].Title[1]) < 58) then Letter2 := '#' else Letter2 := UpperCase(Songs.Song[S].Title)[1]; - if (Letter <> Letter2) then begin - // add a letter Category Button - Inc(Order); - Letter := Letter2; - CatLen := Length(CatSongs.Song); - SetLength(CatSongs.Song, CatLen+1); - CatSongs.Song[CatLen].Artist := '[' + Letter + ']'; - CatSongs.Song[CatLen].Main := true; - CatSongs.Song[CatLen].OrderTyp := 0; -// Order := ord(Letter); - CatSongs.Song[CatLen].OrderNum := Order; - - {// cover-patch - if FileExists(CoversPath + 'Title' + Letter + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'Title' + Letter + '.jpg' - else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';} - CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, Letter); - - //CatNumber Patch - if (Letter <> ' ') then - begin - Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy - CatNumber := 0; - end; - - CatSongs.Song[CatLen].Visible := true; - end; - end - - else if (Ini.Sorting = sArtist2) AND (Length(Songs.Song[S].Artist)>=1) then begin - if (ord(Songs.Song[S].Artist[1]) > 47) and (ord(Songs.Song[S].Artist[1]) < 58) then Letter2 := '#' else Letter2 := UpperCase(Songs.Song[S].Artist)[1]; - if (Letter <> Letter2) then begin - // add a letter Category Button - Inc(Order); - Letter := Letter2; - CatLen := Length(CatSongs.Song); - SetLength(CatSongs.Song, CatLen+1); - CatSongs.Song[CatLen].Artist := '[' + Letter + ']'; - CatSongs.Song[CatLen].Main := true; - CatSongs.Song[CatLen].OrderTyp := 0; -// Order := ord(Letter); - CatSongs.Song[CatLen].OrderNum := Order; - - {// cover-patch - if FileExists(CoversPath + 'Artist' + Letter + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'Artist' + Letter + '.jpg' - else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';} - CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, Letter); - - //CatNumber Patch - if (Letter <> ' ') then - begin - Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy - CatNumber := 0; - end; - - CatSongs.Song[CatLen].Visible := true; - end; - end; - - - CatLen := Length(CatSongs.Song); - SetLength(CatSongs.Song, CatLen+1); - - Inc (CatNumber); //Increase Number in Cat - - CatSongs.Song[CatLen] := Songs.Song[S]; - CatSongs.Song[CatLen].OrderNum := Order; // assigns category - CatSongs.Song[CatLen].CatNumber := CatNumber; - - if (Ini.Tabs = 0) then CatSongs.Song[CatLen].Visible := true - else if (Ini.Tabs = 1) then CatSongs.Song[CatLen].Visible := false; -// if (Ini.Tabs = 1) and (Order = 1) then CatSongs.Song[CatLen].Visible := true; // open first tab -//CatSongs.Song[CatLen].Visible := true; - - end; -//CatNumber Patch - Set CatNumber of Last Category -if (ini.Tabs_at_startup = 1) And (high(Song) >=1) then - Song[CatLen - CatNumber].CatNumber := CatNumber;//Set CatNumber of Categroy -//CatCount Patch -CatCount := Order; -end; - -procedure TCatSongs.ShowCategory(Index: integer); -var - S: integer; // song -begin - CatNumShow := Index; - for S := 0 to high(CatSongs.Song) do - begin - if (CatSongs.Song[S].OrderNum = Index) AND (Not CatSongs.Song[S].Main) then - CatSongs.Song[S].Visible := true - else - CatSongs.Song[S].Visible := false; - end; -end; - -procedure TCatSongs.HideCategory(Index: integer); // hides all songs in category -var - S: integer; // song -begin - for S := 0 to high(CatSongs.Song) do begin - if not CatSongs.Song[S].Main then - CatSongs.Song[S].Visible := false // hides all at now - end; -end; - -procedure TCatSongs.ClickCategoryButton(Index: integer); -var - Num, S: integer; -begin - Num := CatSongs.Song[Index].OrderNum; - if Num <> CatNumShow then - begin - ShowCategory(Num); - end - else begin - ShowCategoryList; - end; -end; - -//Hide Categorys when in Category Hack -procedure TCatSongs.ShowCategoryList; -var - Num, S: integer; -begin - //Hide All Songs Show All Cats - for S := 0 to high(CatSongs.Song) do begin - if CatSongs.Song[S].Main then - CatSongs.Song[S].Visible := true - else - CatSongs.Song[S].Visible := false - end; - CatSongs.Selected := CatNumShow; //Show last shown Category - CatNumShow := -1; -end; -//Hide Categorys when in Category Hack End - -//Wrong song selected when tabs on bug -function TCatSongs.FindNextVisible(SearchFrom:integer): integer;//Find next Visible Song -var - I: Integer; - begin - Result := -1; - I := SearchFrom + 1; - while not CatSongs.Song[I].Visible do - begin - Inc (I); - if (I>high(CatSongs.Song)) then - I := low(CatSongs.Song); - if (I = SearchFrom) then //Make One Round and no song found->quit - break; - end; - end; -//Wrong song selected when tabs on bug End - -function TCatSongs.VisibleSongs: integer; -var - S: integer; // song -begin - Result := 0; - for S := 0 to high(CatSongs.Song) do - if CatSongs.Song[S].Visible = true then Inc(Result); -end; - -function TCatSongs.VisibleIndex(Index: integer): integer; -var - S: integer; // song -begin - Result := 0; - for S := 0 to Index-1 do - if CatSongs.Song[S].Visible = true then Inc(Result); -end; - -function TCatSongs.SetFilter(FilterStr: String; const fType: Byte): Cardinal; -var - I, J: Integer; - cString: String; - SearchStr: Array of String; -begin - {fType: 0: All - 1: Title - 2: Artist} - FilterStr := Trim(FilterStr); - if FilterStr<>'' then begin - Result := 0; - //Create Search Array - SetLength(SearchStr, 1); - I := Pos (' ', FilterStr); - While (I <> 0) do - begin - SetLength (SearchStr, Length(SearchStr) + 1); - cString := Copy(FilterStr, 1, I-1); - if (cString <> ' ') AND (cString <> '') then - SearchStr[High(SearchStr)-1] := cString; - Delete (FilterStr, 1, I); - - I := Pos (' ', FilterStr); - end; - //Copy last Word - if (FilterStr <> ' ') AND (FilterStr <> '') then - SearchStr[High(SearchStr)] := FilterStr; - - for I:=0 to High(Song) do begin - if not Song[i].Main then - begin - case fType of - 0: cString := Song[I].Artist + ' ' + Song[i].Title + ' ' + Song[i].Folder; - 1: cString := Song[I].Title; - 2: cString := Song[I].Artist; - end; - Song[i].Visible:=True; - //Look for every Searched Word - For J := 0 to High(SearchStr) do - begin - Song[i].Visible := Song[i].Visible AND AnsiContainsText(cString, SearchStr[J]) - end; - if Song[i].Visible then - Inc(Result); - end - else - Song[i].Visible:=False; - end; - CatNumShow := -2; - end - else begin - for i:=0 to High(Song) do begin - Song[i].Visible:=(Ini.Tabs=1)=Song[i].Main; - CatNumShow := -1; - end; - Result := 0; - end; -end; - -end. +unit USongs; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + {$IFDEF MSWINDOWS} + Windows, + {$ifdef Delphi} + DirWatch, + {$endif} + {$ELSE} + {$IFNDEF DARWIN} + oldlinux, + syscall, + {$ENDIF} + baseunix, + UnixType, + {$ENDIF} + SysUtils, + Classes, + ULog, + UTexture, + UCommon, + UCatCovers; + +type + + TBPM = record + BPM: real; + StartBeat: real; + end; + + TScore = record + Name: widestring; + Score: integer; + Length: string; + end; + + TSong = record + Path: widestring; + Folder: widestring; // for sorting by folder + FileName: widestring; + + // sorting methods + Category: array of widestring; // I think I won't need this + Genre: widestring; + Edition: widestring; + Language: widestring; // 0.5.0: new + + Title: widestring; + Artist: widestring; + + Text: widestring; + Creator: widestring; + + Cover: widestring; + CoverTex: TTexture; + Mp3: widestring; + Background: widestring; + Video: widestring; + VideoGAP: real; + VideoLoaded: boolean; // 0.5.0: true if the video has been loaded + NotesGAP: integer; + Start: real; // in seconds + Finish: integer; // in miliseconds + Relative: boolean; + Resolution: integer; + BPM: array of TBPM; + GAP: real; // in miliseconds + + Score: array[0..2] of array of TScore; + + // these are used when sorting is enabled + Visible: boolean; // false if hidden, true if visible + Main: boolean; // false for songs, true for category buttons + OrderNum: integer; // has a number of category for category buttons and songs + OrderTyp: integer; // type of sorting for this button (0=name) + CatNumber: integer; // Count of Songs in Category for Cats and Number of Song in Category for Songs + end; + + TSongs = class( TThread ) + private + BrowsePos : Cardinal; //Actual Pos in Song Array + fNotify , + fWatch : longint; + fParseSongDirectory : boolean; + fProcessing : boolean; + {$ifdef Delphi} + fDirWatch : TDirectoryWatch; + {$endif} + procedure int_LoadSongList; + procedure DoDirChanged(Sender: TObject); + protected + procedure Execute; override; + public + Song : array of TSong; // array of songs + Selected : integer; // selected song index + constructor create(); + procedure LoadSongList; // load all songs + procedure BrowseDir(Dir: widestring); // should return number of songs in the future + procedure Sort(Order: integer); + function FindSongFile(Dir, Mask: widestring): widestring; + property Processing : boolean read fProcessing; + end; + + TCatSongs = class + Song: array of TSong; // array of categories with songs + Selected: integer; // selected song index + Order: integer; // order type (0=title) + CatNumShow: integer; // Category Number being seen + CatCount: integer; //Number of Categorys + + procedure Refresh; // refreshes arrays by recreating them from Songs array +// procedure Sort(Order: integer); + procedure ShowCategory(Index: integer); // expands all songs in category + procedure HideCategory(Index: integer); // hides all songs in category + procedure ClickCategoryButton(Index: integer); // uses ShowCategory and HideCategory when needed + procedure ShowCategoryList; //Hides all Songs And Show the List of all Categorys + function FindNextVisible(SearchFrom:integer): integer; //Find Next visible Song + function VisibleSongs: integer; // returns number of visible songs (for tabs) + function VisibleIndex(Index: integer): integer; // returns visible song index (skips invisible) + + function SetFilter(FilterStr: String; const fType: Byte): Cardinal; + end; + +var + Songs: TSongs; // all songs + CatSongs: TCatSongs; // categorized songs + AktSong: TSong; // one song *unknown use) + +const + IN_ACCESS = $00000001; //* File was accessed */ + IN_MODIFY = $00000002; //* File was modified */ + IN_ATTRIB = $00000004; //* Metadata changed */ + IN_CLOSE_WRITE = $00000008; //* Writtable file was closed */ + IN_CLOSE_NOWRITE = $00000010; //* Unwrittable file closed */ + IN_OPEN = $00000020; //* File was opened */ + IN_MOVED_FROM = $00000040; //* File was moved from X */ + IN_MOVED_TO = $00000080; //* File was moved to Y */ + IN_CREATE = $00000100; //* Subfile was created */ + IN_DELETE = $00000200; //* Subfile was deleted */ + IN_DELETE_SELF = $00000400; //* Self was deleted */ + + +implementation + +uses StrUtils, + UGraphic, + UCovers, + UFiles, + UMain, + UIni; + +{$IFDEF DARWIN} +function AnsiContainsText(const AText, ASubText: string): Boolean; +begin + Result := AnsiPos(AnsiUppercase(ASubText), AnsiUppercase(AText)) > 0; +end; +{$ENDIF} + +constructor TSongs.create(); +begin + inherited create( false ); + self.freeonterminate := true; + + {$ifdef Delphi} + fDirWatch := TDirectoryWatch.create(nil); + fDirWatch.OnChange := DoDirChanged; + fDirWatch.Directory := SongPath; + fDirWatch.WatchSubDirs := true; + fDirWatch.active := true; + {$ENDIF} + + {$IFDEF linux} + (* + Thankyou to : http://www.linuxjournal.com/article/8478 + http://www.tin.org/bin/man.cgi?section=2&topic=inotify_add_watch + *) +(* + fNotify := -1; + fWatch := -1; + + writeln( 'Calling inotify_init' ); + fNotify := Do_SysCall( syscall_nr_inotify_init ); + if ( fNotify < 0 ) then + writeln( 'Filesystem change notification - disabled' ); + writeln( 'Calling inotify_init : '+ inttostr(fNotify) ); + + writeln( 'Calling syscall_nr_inotify_init ('+SongPath+')' ); + fWatch := Do_SysCall( syscall_nr_inotify_init , TSysParam( fNotify ), longint( pchar( SongPath ) ) , IN_MODIFY AND IN_CREATE AND IN_DELETE ); + + if (fWatch < 0) then + writeln ('inotify_add_watch'); + writeln( 'Calling syscall_nr_inotify_init : '+ inttostr(fWatch) ); +*) + {$endif} + + Setlength(Song, 0); +end; + +procedure TSongs.DoDirChanged(Sender: TObject); +begin + LoadSongList(); +end; + +procedure TSongs.Execute(); +var + fChangeNotify : THandle; +begin + fParseSongDirectory := true; + + while not self.terminated do + begin + + if fParseSongDirectory then + begin + writeln( 'int_LoadSongList' ); + int_LoadSongList(); + end; + + self.suspend; + end; + +end; + +procedure TSongs.int_LoadSongList; +begin + try + fProcessing := true; + Setlength(Song, 0); + + Log.LogError('SongList', 'Searching For Songs'); + + Setlength(Song, 50); + + BrowsePos := 0; + // browse directories + BrowseDir(SongPath); + + //Set Correct SongArray Length + SetLength(Song, BrowsePos); + + if assigned( CatSongs ) then + CatSongs.Refresh; + + if assigned( CatCovers ) then + CatCovers.Load; + + if assigned( Covers ) then + Covers.Load; + + if assigned(ScreenSong) then + begin + ScreenSong.GenerateThumbnails(); + ScreenSong.OnShow; // refresh ScreenSong + end; + + + finally + Log.LogError('SongList', 'Search Complete'); + + fParseSongDirectory := false; + fProcessing := false; + end; +end; + + +procedure TSongs.LoadSongList; +begin + fParseSongDirectory := true; + self.resume; +end; + +// TODO : JB - THis whole function SUX ! and needs refactoring ! :P +procedure TSongs.BrowseDir(Dir: widestring); +var + SLen: integer; + + {$ifdef Delphi} + SR: TSearchRecW; // for parsing Songs Directory + {$ENDIF} + + // eddie: can we merge that? is baseunix working on linux? oldlinux is + // not available on mac os x. + {$IFDEF LINUX} + TheDir : oldlinux.pdir; + ADirent : oldlinux.pDirent; + Entry : Longint; + info : oldlinux.stat; + {$ENDIF} + {$IFDEF DARWIN} + TheDir : pdir; + ADirent : pDirent; + Entry : Longint; + info : stat; + {$ENDIF} +begin + {$ifdef Delphi} + if FindFirstW(Dir + '*', faDirectory, SR) = 0 then // JB_Unicode - windows + begin + repeat + if (SR.Name <> '.') and (SR.Name <> '..') then + begin + BrowseDir(Dir + Sr.Name + PathDelim); + end + until FindNextw(SR) <> 0; + end; // if + FindClosew(SR); + + if FindFirstW(Dir + '*.txt', 0, SR) = 0 then + begin + repeat + SLen := BrowsePos; + + Song[SLen].Path := Dir; + Song[SLen].Folder := Copy(Dir, Length(SongPath)+1, 10000); + Song[SLen].Folder := Copy(Song[SLen].Folder, 1, Pos( PathDelim , Song[SLen].Folder)-1); + Song[SLen].FileName := SR.Name; + + if (AnalyseFile(Song[SLen]) = false) then + Dec(BrowsePos) + else + begin + if Song[SLen].Cover = '' then + Song[SLen].Cover := FindSongFile(Dir, '*[CO].jpg'); + end; + + //Change Length Only every 50 Entrys + Inc(BrowsePos); + + if (BrowsePos mod 50 = 0) AND (BrowsePos <> 0) then + begin + SetLength(Song, Length(Song) + 50); + end; + + until FindNextW(SR) <> 0; + end; // if FindFirst + FindCloseW(SR); + {$ENDIF} + + {$IFDEF LINUX} + // Itterate the Songs Directory... ( With unicode capable functions for linux ) + TheDir := oldlinux.opendir( Dir ); // JB_Unicode - linux + if TheDir <> nil then + begin + repeat + ADirent := oldlinux.ReadDir(TheDir); + + If ADirent<>Nil then + begin + With ADirent^ do + begin + + if ( name[0] <> '.') then + BrowseDir( Dir + name + pathdelim ); + + end; + end; + Until ADirent=Nil; + end; + + + + TheDir := oldlinux.opendir( Dir ); // JB_Unicode - linux + if TheDir <> nil then + begin + repeat + ADirent := oldlinux.ReadDir(TheDir); + + if ( ADirent <> Nil ) AND + ( pos( '.txt', ADirent^.name ) > 0 ) then + begin + writeln ('***** FOUND TXT' + ADirent^.name ); + + SLen := BrowsePos; + + Song[SLen].Path := Dir; + Song[SLen].Folder := Copy(Dir, Length(SongPath)+1, 10000); + Song[SLen].Folder := Copy(Song[SLen].Folder, 1, Pos( PathDelim , Song[SLen].Folder)-1); + Song[SLen].FileName := ADirent^.name; + + if (AnalyseFile(Song[SLen]) = false) then + Dec(BrowsePos) + else + begin + if Song[SLen].Cover = '' then + Song[SLen].Cover := FindSongFile(Dir, '*[CO].jpg'); + end; + + //Change Length Only every 50 Entrys + Inc(BrowsePos); + if (BrowsePos mod 50 = 0) AND (BrowsePos <> 0) then + begin + SetLength(Song, Length(Song) + 50); + end; + end; + + Until ADirent=Nil; + end; // if FindFirst + {$endif} + + {$IFDEF DARWIN} + // Itterate the Songs Directory... ( With unicode capable functions for linux ) + TheDir := FPOpenDir( Dir ); // JB_Unicode - linux + if TheDir <> nil then + begin + repeat + ADirent := FPReadDir(TheDir); + + If ADirent<>Nil then + begin + With ADirent^ do + begin + + if ( d_name[0] <> '.') then + BrowseDir( Dir + d_name + pathdelim ); + + end; + end; + Until ADirent=Nil; + end; + + + + TheDir := FPOpenDir( Dir ); // JB_Unicode - linux + if TheDir <> nil then + begin + repeat + ADirent := FPReadDir(TheDir); + + if ( ADirent <> Nil ) AND + ( pos( '.txt', ADirent^.d_name ) > -1 ) then + begin + SLen := BrowsePos; + + Song[SLen].Path := Dir; + Song[SLen].Folder := Copy(Dir, Length(SongPath)+1, 10000); + Song[SLen].Folder := Copy(Song[SLen].Folder, 1, Pos( PathDelim , Song[SLen].Folder)-1); + Song[SLen].FileName := ADirent^.d_name; + + if (AnalyseFile(Song[SLen]) = false) then + Dec(BrowsePos) + else + begin + if Song[SLen].Cover = '' then + Song[SLen].Cover := FindSongFile(Dir, '*[CO].jpg'); + end; + + //Change Length Only every 50 Entrys + Inc(BrowsePos); + + if (BrowsePos mod 50 = 0) AND (BrowsePos <> 0) then + begin + SetLength(Song, Length(Song) + 50); + end; + end; + + Until ADirent=Nil; + end; // if FindFirst + + {$endif} + +// Log.LogStatus('Parsing directory: ' + Dir + SR.Name, 'LoadSongList'); + + +end; + +procedure TSongs.Sort(Order: integer); +var + S: integer; + S2: integer; + TempSong: TSong; +begin + case Order of + sEdition: // by edition + begin + for S2 := 0 to Length(Song)-1 do + for S := 1 to Length(Song)-1 do + if CompareText(Song[S].Edition, Song[S-1].Edition) < 0 then begin + // zamiana miejscami + TempSong := Song[S-1]; + Song[S-1] := Song[S]; + Song[S] := TempSong; + end; + end; + sGenre: // by genre + begin + for S2 := 0 to Length(Song)-1 do + for S := 1 to Length(Song)-1 do + if CompareText(Song[S].Genre, Song[S-1].Genre) < 0 then begin + // zamiana miejscami + TempSong := Song[S-1]; + Song[S-1] := Song[S]; + Song[S] := TempSong; + end; + end; + sTitle: // by title + begin + for S2 := 0 to Length(Song)-1 do + for S := 1 to Length(Song)-1 do + if CompareText(Song[S].Title, Song[S-1].Title) < 0 then begin + // zamiana miejscami + TempSong := Song[S-1]; + Song[S-1] := Song[S]; + Song[S] := TempSong; + end; + + end; + sArtist: // by artist + begin + for S2 := 0 to Length(Song)-1 do + for S := 1 to Length(Song)-1 do + if CompareText(Song[S].Artist, Song[S-1].Artist) < 0 then begin + // zamiana miejscami + TempSong := Song[S-1]; + Song[S-1] := Song[S]; + Song[S] := TempSong; + end; + end; + sFolder: // by folder + begin + for S2 := 0 to Length(Song)-1 do + for S := 1 to Length(Song)-1 do + if CompareText(Song[S].Folder, Song[S-1].Folder) < 0 then begin + // zamiana miejscami + TempSong := Song[S-1]; + Song[S-1] := Song[S]; + Song[S] := TempSong; + end; + end; + sTitle2: // by title2 + begin + for S2 := 0 to Length(Song)-1 do + for S := 1 to Length(Song)-1 do + if CompareText(Song[S].Title, Song[S-1].Title) < 0 then begin + // zamiana miejscami + TempSong := Song[S-1]; + Song[S-1] := Song[S]; + Song[S] := TempSong; + end; + + end; + sArtist2: // by artist2 + begin + for S2 := 0 to Length(Song)-1 do + for S := 1 to Length(Song)-1 do + if CompareText(Song[S].Artist, Song[S-1].Artist) < 0 then begin + // zamiana miejscami + TempSong := Song[S-1]; + Song[S-1] := Song[S]; + Song[S] := TempSong; + end; + end; + sLanguage: // by Language + begin + for S2 := 0 to Length(Song)-1 do + for S := 1 to Length(Song)-1 do + if CompareText(Song[S].Language, Song[S-1].Language) < 0 then begin + TempSong := Song[S-1]; + Song[S-1] := Song[S]; + Song[S] := TempSong; + end; + end; + + end; // case +end; + +function TSongs.FindSongFile(Dir, Mask: widestring): widestring; +var + SR: TSearchRec; // for parsing song directory +begin + Result := ''; + if FindFirst(Dir + Mask, faDirectory, SR) = 0 then begin + Result := SR.Name; + end; // if + FindClose(SR); +end; + +procedure TCatSongs.Refresh; +var + S: integer; // temporary song index + CatLen: integer; // length of CatSongs.Song + Letter: char; // current letter for sorting using letter + SS: string; // current edition for sorting using edition, genre etc. + Order: integer; // number used for ordernum + Letter2: char; // + CatNumber:integer; // Number of Song in Category +begin + CatNumShow := -1; +// Songs.Sort(0); // by title + +case Ini.Sorting of + sEdition: begin + Songs.Sort(sArtist); + Songs.Sort(sEdition); + end; + sGenre: begin + Songs.Sort(sArtist); + Songs.Sort(sGenre); + end; + sLanguage: begin + Songs.Sort(sArtist); + Songs.Sort(sLanguage); + end; + sFolder: begin + Songs.Sort(sArtist); + Songs.Sort(sFolder); + end; + sTitle: Songs.Sort(sTitle); + sArtist: Songs.Sort(sArtist); + sTitle2: Songs.Sort(sTitle2); // by title2 + sArtist2: Songs.Sort(sArtist2); // by artist2 + + end; // case + + + Letter := ' '; + SS := ''; + Order := 0; + CatNumber := 0; + + //Songs leeren + SetLength (Song, 0); + + for S := Low(Songs.Song) to High(Songs.Song) do begin + if (Ini.Tabs = 1) then + if (Ini.Sorting = sEdition) and (CompareText(SS, Songs.Song[S].Edition) <> 0) then begin + // add Category Button + Inc(Order); + SS := Songs.Song[S].Edition; + CatLen := Length(CatSongs.Song); + SetLength(CatSongs.Song, CatLen+1); + CatSongs.Song[CatLen].Artist := '[' + SS + ']'; + CatSongs.Song[CatLen].Main := true; + CatSongs.Song[CatLen].OrderTyp := 0; + CatSongs.Song[CatLen].OrderNum := Order; + + + + // 0.4.3 + // if SS = 'Singstar' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar.jpg'; + // if SS = 'Singstar Part 2' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar.jpg'; + // if SS = 'Singstar German' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar.jpg'; + // if SS = 'Singstar Spanish' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar.jpg'; + // if SS = 'Singstar Italian' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar.jpg'; + // if SS = 'Singstar French' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar.jpg'; + // if SS = 'Singstar Party' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar Party.jpg'; + // if SS = 'Singstar Popworld' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar Popworld.jpg'; + // if SS = 'Singstar 80s' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar 80s.jpg'; + // if SS = 'Singstar 80s Polish' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar 80s.jpg'; + // if SS = 'Singstar Rocks' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar Rocks.jpg'; + // if SS = 'Singstar Anthems' then CatSongs.Song[CatLen].Cover := CoversPath + 'Singstar Anthems.jpg'; + + {// cover-patch + if FileExists(CoversPath + SS + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + SS + '.jpg' + else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';//} + + CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, SS); + + //CatNumber Patch + if (SS <> '') then + begin + Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy + CatNumber := 0; + end; + + CatSongs.Song[CatLen].Visible := true; + end + + else if (Ini.Sorting = sGenre) and (CompareText(SS, Songs.Song[S].Genre) <> 0) then begin + // add Genre Button + Inc(Order); + SS := Songs.Song[S].Genre; + CatLen := Length(CatSongs.Song); + SetLength(CatSongs.Song, CatLen+1); + CatSongs.Song[CatLen].Artist := SS; + CatSongs.Song[CatLen].Main := true; + CatSongs.Song[CatLen].OrderTyp := 0; + CatSongs.Song[CatLen].OrderNum := Order; + + {// cover-patch + if FileExists(CoversPath + SS + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + SS + '.jpg' + else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';} + CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, SS); + + //CatNumber Patch + if (SS <> '') then + begin + Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy + CatNumber := 0; + end; + + CatSongs.Song[CatLen].Visible := true; + end + + else if (Ini.Sorting = sLanguage) and (CompareText(SS, Songs.Song[S].Language) <> 0) then begin + // add Language Button + Inc(Order); + SS := Songs.Song[S].Language; + CatLen := Length(CatSongs.Song); + SetLength(CatSongs.Song, CatLen+1); + CatSongs.Song[CatLen].Artist := SS; + CatSongs.Song[CatLen].Main := true; + CatSongs.Song[CatLen].OrderTyp := 0; + CatSongs.Song[CatLen].OrderNum := Order; + + {// cover-patch + if FileExists(CoversPath + SS + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + SS + '.jpg' + else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';} + CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, SS); + + //CatNumber Patch + if (SS <> '') then + begin + Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy + CatNumber := 0; + end; + + CatSongs.Song[CatLen].Visible := true; + end + + else if (Ini.Sorting = sTitle) and + (Length(Songs.Song[S].Title)>=1) and + (Letter <> UpperCase(Songs.Song[S].Title)[1]) then begin + // add a letter Category Button + Inc(Order); + Letter := Uppercase(Songs.Song[S].Title)[1]; + CatLen := Length(CatSongs.Song); + SetLength(CatSongs.Song, CatLen+1); + CatSongs.Song[CatLen].Artist := '[' + Letter + ']'; + CatSongs.Song[CatLen].Main := true; + CatSongs.Song[CatLen].OrderTyp := 0; +// Order := ord(Letter); + CatSongs.Song[CatLen].OrderNum := Order; + + + {// cover-patch + if FileExists(CoversPath + 'Title' + Letter + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'Title' + Letter + '.jpg' + else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';} + CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, Letter); + + //CatNumber Patch + if (Letter <> ' ') then + begin + Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy + CatNumber := 0; + end; + + CatSongs.Song[CatLen].Visible := true; + end + + else if (Ini.Sorting = sArtist) and (Length(Songs.Song[S].Artist)>=1) and (Letter <> UpperCase(Songs.Song[S].Artist)[1]) then begin + // add a letter Category Button + Inc(Order); + Letter := UpperCase(Songs.Song[S].Artist)[1]; + CatLen := Length(CatSongs.Song); + SetLength(CatSongs.Song, CatLen+1); + CatSongs.Song[CatLen].Artist := '[' + Letter + ']'; + CatSongs.Song[CatLen].Main := true; + CatSongs.Song[CatLen].OrderTyp := 0; +// Order := ord(Letter); + CatSongs.Song[CatLen].OrderNum := Order; + + {// cover-patch + if FileExists(CoversPath + 'Artist' + Letter + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'Artist' + Letter + '.jpg' + else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';} + CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, Letter); + + //CatNumber Patch + if (Letter <> ' ') then + begin + Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy + CatNumber := 0; + end; + + CatSongs.Song[CatLen].Visible := true; + end + + else if (Ini.Sorting = sFolder) and (CompareText(SS, Songs.Song[S].Folder) <> 0) then begin + // 0.5.0: add folder tab + Inc(Order); + SS := Songs.Song[S].Folder; + CatLen := Length(CatSongs.Song); + SetLength(CatSongs.Song, CatLen+1); + CatSongs.Song[CatLen].Artist := SS; + CatSongs.Song[CatLen].Main := true; + CatSongs.Song[CatLen].OrderTyp := 0; + CatSongs.Song[CatLen].OrderNum := Order; + + {// cover-patch + if FileExists(CoversPath + SS + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + SS + '.jpg' + else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';} + CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, SS); + + //CatNumber Patch + if (SS <> '') then + begin + Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy + CatNumber := 0; + end; + + CatSongs.Song[CatLen].Visible := true; + end + + else if (Ini.Sorting = sTitle2) AND (Length(Songs.Song[S].Title)>=1) then begin + if (ord(Songs.Song[S].Title[1]) > 47) and (ord(Songs.Song[S].Title[1]) < 58) then Letter2 := '#' else Letter2 := UpperCase(Songs.Song[S].Title)[1]; + if (Letter <> Letter2) then begin + // add a letter Category Button + Inc(Order); + Letter := Letter2; + CatLen := Length(CatSongs.Song); + SetLength(CatSongs.Song, CatLen+1); + CatSongs.Song[CatLen].Artist := '[' + Letter + ']'; + CatSongs.Song[CatLen].Main := true; + CatSongs.Song[CatLen].OrderTyp := 0; +// Order := ord(Letter); + CatSongs.Song[CatLen].OrderNum := Order; + + {// cover-patch + if FileExists(CoversPath + 'Title' + Letter + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'Title' + Letter + '.jpg' + else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';} + CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, Letter); + + //CatNumber Patch + if (Letter <> ' ') then + begin + Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy + CatNumber := 0; + end; + + CatSongs.Song[CatLen].Visible := true; + end; + end + + else if (Ini.Sorting = sArtist2) AND (Length(Songs.Song[S].Artist)>=1) then begin + if (ord(Songs.Song[S].Artist[1]) > 47) and (ord(Songs.Song[S].Artist[1]) < 58) then Letter2 := '#' else Letter2 := UpperCase(Songs.Song[S].Artist)[1]; + if (Letter <> Letter2) then begin + // add a letter Category Button + Inc(Order); + Letter := Letter2; + CatLen := Length(CatSongs.Song); + SetLength(CatSongs.Song, CatLen+1); + CatSongs.Song[CatLen].Artist := '[' + Letter + ']'; + CatSongs.Song[CatLen].Main := true; + CatSongs.Song[CatLen].OrderTyp := 0; +// Order := ord(Letter); + CatSongs.Song[CatLen].OrderNum := Order; + + {// cover-patch + if FileExists(CoversPath + 'Artist' + Letter + '.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'Artist' + Letter + '.jpg' + else if FileExists(CoversPath + 'NoCover.jpg') then CatSongs.Song[CatLen].Cover := CoversPath + 'NoCover.jpg';} + CatSongs.Song[CatLen].Cover := CatCovers.GetCover(Ini.Sorting, Letter); + + //CatNumber Patch + if (Letter <> ' ') then + begin + Song[CatLen - CatNumber - 1].CatNumber := CatNumber;//Set CatNumber of Categroy + CatNumber := 0; + end; + + CatSongs.Song[CatLen].Visible := true; + end; + end; + + + CatLen := Length(CatSongs.Song); + SetLength(CatSongs.Song, CatLen+1); + + Inc (CatNumber); //Increase Number in Cat + + CatSongs.Song[CatLen] := Songs.Song[S]; + CatSongs.Song[CatLen].OrderNum := Order; // assigns category + CatSongs.Song[CatLen].CatNumber := CatNumber; + + if (Ini.Tabs = 0) then CatSongs.Song[CatLen].Visible := true + else if (Ini.Tabs = 1) then CatSongs.Song[CatLen].Visible := false; +// if (Ini.Tabs = 1) and (Order = 1) then CatSongs.Song[CatLen].Visible := true; // open first tab +//CatSongs.Song[CatLen].Visible := true; + + end; +//CatNumber Patch - Set CatNumber of Last Category +if (ini.Tabs_at_startup = 1) And (high(Song) >=1) then + Song[CatLen - CatNumber].CatNumber := CatNumber;//Set CatNumber of Categroy +//CatCount Patch +CatCount := Order; +end; + +procedure TCatSongs.ShowCategory(Index: integer); +var + S: integer; // song +begin + CatNumShow := Index; + for S := 0 to high(CatSongs.Song) do + begin + if (CatSongs.Song[S].OrderNum = Index) AND (Not CatSongs.Song[S].Main) then + CatSongs.Song[S].Visible := true + else + CatSongs.Song[S].Visible := false; + end; +end; + +procedure TCatSongs.HideCategory(Index: integer); // hides all songs in category +var + S: integer; // song +begin + for S := 0 to high(CatSongs.Song) do begin + if not CatSongs.Song[S].Main then + CatSongs.Song[S].Visible := false // hides all at now + end; +end; + +procedure TCatSongs.ClickCategoryButton(Index: integer); +var + Num, S: integer; +begin + Num := CatSongs.Song[Index].OrderNum; + if Num <> CatNumShow then + begin + ShowCategory(Num); + end + else begin + ShowCategoryList; + end; +end; + +//Hide Categorys when in Category Hack +procedure TCatSongs.ShowCategoryList; +var + Num, S: integer; +begin + //Hide All Songs Show All Cats + for S := 0 to high(CatSongs.Song) do begin + if CatSongs.Song[S].Main then + CatSongs.Song[S].Visible := true + else + CatSongs.Song[S].Visible := false + end; + CatSongs.Selected := CatNumShow; //Show last shown Category + CatNumShow := -1; +end; +//Hide Categorys when in Category Hack End + +//Wrong song selected when tabs on bug +function TCatSongs.FindNextVisible(SearchFrom:integer): integer;//Find next Visible Song +var + I: Integer; + begin + Result := -1; + I := SearchFrom + 1; + while not CatSongs.Song[I].Visible do + begin + Inc (I); + if (I>high(CatSongs.Song)) then + I := low(CatSongs.Song); + if (I = SearchFrom) then //Make One Round and no song found->quit + break; + end; + end; +//Wrong song selected when tabs on bug End + +function TCatSongs.VisibleSongs: integer; +var + S: integer; // song +begin + Result := 0; + for S := 0 to high(CatSongs.Song) do + if CatSongs.Song[S].Visible = true then Inc(Result); +end; + +function TCatSongs.VisibleIndex(Index: integer): integer; +var + S: integer; // song +begin + Result := 0; + for S := 0 to Index-1 do + if CatSongs.Song[S].Visible = true then Inc(Result); +end; + +function TCatSongs.SetFilter(FilterStr: String; const fType: Byte): Cardinal; +var + I, J: Integer; + cString: String; + SearchStr: Array of String; +begin + {fType: 0: All + 1: Title + 2: Artist} + FilterStr := Trim(FilterStr); + if FilterStr<>'' then begin + Result := 0; + //Create Search Array + SetLength(SearchStr, 1); + I := Pos (' ', FilterStr); + While (I <> 0) do + begin + SetLength (SearchStr, Length(SearchStr) + 1); + cString := Copy(FilterStr, 1, I-1); + if (cString <> ' ') AND (cString <> '') then + SearchStr[High(SearchStr)-1] := cString; + Delete (FilterStr, 1, I); + + I := Pos (' ', FilterStr); + end; + //Copy last Word + if (FilterStr <> ' ') AND (FilterStr <> '') then + SearchStr[High(SearchStr)] := FilterStr; + + for I:=0 to High(Song) do begin + if not Song[i].Main then + begin + case fType of + 0: cString := Song[I].Artist + ' ' + Song[i].Title + ' ' + Song[i].Folder; + 1: cString := Song[I].Title; + 2: cString := Song[I].Artist; + end; + Song[i].Visible:=True; + //Look for every Searched Word + For J := 0 to High(SearchStr) do + begin + Song[i].Visible := Song[i].Visible AND AnsiContainsText(cString, SearchStr[J]) + end; + if Song[i].Visible then + Inc(Result); + end + else + Song[i].Visible:=False; + end; + CatNumShow := -2; + end + else begin + for i:=0 to High(Song) do begin + Song[i].Visible:=(Ini.Tabs=1)=Song[i].Main; + CatNumShow := -1; + end; + Result := 0; + end; +end; + +end. diff --git a/Game/Code/Classes/UTexture.pas b/Game/Code/Classes/UTexture.pas index f1f7fe47..ac3aa7d6 100644 --- a/Game/Code/Classes/UTexture.pas +++ b/Game/Code/Classes/UTexture.pas @@ -1,1143 +1,1143 @@ -unit UTexture; -// added for easier debug disabling -{$define blindydebug} - -// Plain (alpha = 1) -// Transparent -// Colorized - -// obsolete? -// Transparent Range -// Font (white is drawn, black is transparent) -// Font Outline (Font with darker outline) -// Font Outline 2 (Font with darker outline) -// Font Black (black is drawn, white is transparent) -// Font Gray (gray is drawn, white is transparent) -// Arrow (for arrows, white is white, gray has color, black is transparent); - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses OpenGL12, - {$IFDEF win32} - windows, - {$ENDIF} - Math, - Classes, - SysUtils, - Graphics, - UCommon, - UThemes, - SDL, - sdlutils, - SDL_Image; - -type - TTexture = record - TexNum: integer; - X: real; - Y: real; - Z: real; // new - W: real; - H: real; - ScaleW: real; // for dynamic scalling while leaving width constant - ScaleH: real; // for dynamic scalling while leaving height constant - Rot: real; // 0 - 2*pi - Int: real; // intensity - ColR: real; - ColG: real; - ColB: real; - TexW: real; // used? - TexH: real; // used? - TexX1: real; - TexY1: real; - TexX2: real; - TexY2: real; - Alpha: real; - Name: string; // 0.5.0: experimental for handling cache images. maybe it's useful for dynamic skins - end; - - TTextureEntry = record - Name: string; - Typ: string; - - // we use normal TTexture, it's easier to implement and if needed - we copy ready data - Texture: TTexture; - TextureCache: TTexture; // 0.5.0 - end; - - TTextureDatabase = record - Texture: array of TTextureEntry; - end; - - TTextureUnit = class - - private - function LoadImage(Identifier: PChar): PSDL_Surface; - function pixfmt_eq(fmt1,fmt2: PSDL_Pixelformat): boolean; - procedure AdjustPixelFormat(var TexSurface: PSDL_Surface; Typ: PChar); - function GetScaledTexture(TexSurface: PSDL_Surface; W,H: Cardinal): PSDL_Surface; - procedure ScaleTexture(var TexSurface: PSDL_Surface; W,H: Cardinal); - procedure FitTexture(var TexSurface: PSDL_Surface; W,H: Cardinal); - procedure ColorizeTexture(TexSurface: PSDL_Surface; Col: Cardinal); - - public - Limit: integer; - CreateCacheMipmap: boolean; - -// function GetNumberFor - function GetTexture(Name, Typ: string): TTexture; overload; - function GetTexture(Name, Typ: string; FromCache: boolean): TTexture; overload; - function FindTexture(Name: string): integer; - function LoadTexture(FromRegistry: boolean; Identifier, Format, Typ: PChar; Col: LongWord): TTexture; overload; - function LoadTexture(Identifier, Format, Typ: PChar; Col: LongWord): TTexture; overload; - function LoadTexture(Identifier: string): TTexture; overload; - function CreateTexture(var Data: array of byte; Name: string; W, H: word; Bits: byte): TTexture; - procedure UnloadTexture(Name: string; FromCache: boolean); - Constructor Create; - Destructor Destroy; - end; - -var - Texture: TTextureUnit; - TextureDatabase: TTextureDatabase; - - // this should be in UDisplay?! - PrintScreenData: array[0..1024*768-1] of longword; - - ActTex: GLuint;//integer; - -// TextureD8: array[1..1024*1024] of byte; // 1MB - TextureD16: array[1..1024*1024, 1..2] of byte; // luminance/alpha tex (2MB) -// TextureD24: array[1..1024*1024, 1..3] of byte; // normal 24-bit tex (3MB) -// TextureD242: array[1..512*512, 1..3] of byte; // normal 24-bit tex (0,75MB) -// TextureD32: array[1..1024*1024, 1..4] of byte; // transparent 32-bit tex (4MB) - // total 40MB at 2048*2048 - // total 10MB at 1024*1024 - - Mipmapping: Boolean; - - CacheMipmap: array[0..256*256*3-1] of byte; // 3KB - CacheMipmapSurface: PSDL_Surface; - - -implementation - -uses ULog, - DateUtils, - UCovers, - {$IFDEF LAZARUS} - LResources, - {$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); - - -Constructor TTextureUnit.Create; -begin - inherited Create; -end; - -Destructor TTextureUnit.Destroy; -begin - inherited Destroy; -end; - -function TTextureUnit.pixfmt_eq(fmt1,fmt2: PSDL_Pixelformat): boolean; -begin - if (fmt1^.BitsPerPixel = fmt2^.BitsPerPixel) and - (fmt1^.BytesPerPixel = fmt2^.BytesPerPixel) and - (fmt1^.Rloss = fmt2^.Rloss) and (fmt1^.Gloss = fmt2^.Gloss) and - (fmt1^.Bloss = fmt2^.Bloss) and (fmt1^.Rmask = fmt2^.Rmask) and - (fmt1^.Gmask = fmt2^.Gmask) and (fmt1^.Bmask = fmt2^.Bmask) and - (fmt1^.Rshift = fmt2^.Rshift) and (fmt1^.Gshift = fmt2^.Gshift) and - (fmt1^.Bshift = fmt2^.Bshift) - then - Result:=True - else - Result:=False; -end; - -// +++++++++++++++++++++ helpers for loadimage +++++++++++++++ - 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; -// ----------------------------------------------- - -function TTextureUnit.LoadImage(Identifier: PChar): PSDL_Surface; -var - - TexRWops: PSDL_RWops; - dHandle: THandle; - - {$IFDEF LAZARUS} - lLazRes : TLResource; - lResData : TStringStream; - {$ELSE} - TexStream: TStream; - {$ENDIF} - -begin - Result := nil; - TexRWops := nil; - -// Log.LogStatus( Identifier, 'LoadImage' ); - - if ( FileExists(Identifier) ) then - begin - // load from file - Log.LogStatus( 'Is File', ' LoadImage' ); - try - Result:=IMG_Load(Identifier); - except - Log.LogStatus( 'ERROR Could not load from file' , Identifier); - beep; - Exit; - end; - end - else - begin - Log.LogStatus( 'IS Resource, because file does not exist.('+Identifier+')', ' LoadImage' ); - - // load from resource stream - {$IFDEF WIN32} - dHandle := FindResource(hInstance, Identifier, 'TEX'); - if dHandle=0 then - begin - Log.LogStatus( 'ERROR Could not find resource' , ' '+ Identifier); - beep; - Exit; - end; - - - TexStream := nil; - try - TexStream := TResourceStream.Create(HInstance, Identifier, 'TEX'); - except - Log.LogStatus( 'ERROR Could not load from resource' , Identifier); - beep; - Exit; - end; - - try - TexStream.position := 0; - try - TexRWops := SDL_AllocRW; - TexRWops.unknown := TUnknown(TexStream); - TexRWops.seek := SDLStreamSeek; - TexRWops.read := SDLStreamRead; - TexRWops.write := nil; - TexRWops.close := SDLStreamClose; - TexRWops.type_ := 2; - except - Log.LogStatus( 'ERROR Could not assign resource' , Identifier); - beep; - Exit; - end; - - Log.LogStatus( 'resource Assigned....' , Identifier); - Result:=IMG_Load_RW(TexRWops,0); - SDL_FreeRW(TexRWops); - - finally - if assigned( TexStream ) then - freeandnil( TexStream ); - end; - - - {$ELSE} - lLazRes := LazFindResource( Identifier, 'TEX' ); - if lLazRes <> nil then - begin - lResData := TStringStream.create( lLazRes.value ); - try - lResData.position := 0; - try - TexRWops := SDL_AllocRW; - TexRWops.unknown := TUnknown( lResData ); - TexRWops.seek := SDLStreamSeek; - TexRWops.read := SDLStreamRead; - TexRWops.write := nil; - TexRWops.close := SDLStreamClose; - TexRWops.type_ := 2; - except - Log.LogStatus( 'ERROR Could not assign resource ('+Identifier+')' , Identifier); - beep; - Exit; - end; - - Result := IMG_Load_RW(TexRWops,0); - SDL_FreeRW(TexRWops); - finally - freeandnil( lResData ); - end; - end - else - begin - Log.LogStatus( 'NOT found in Resource ('+Identifier+')', ' LoadImage' ); - end; - {$ENDIF} - - - end; -end; - -procedure TTextureUnit.AdjustPixelFormat(var TexSurface: PSDL_Surface; Typ: PChar); -var - TempSurface: PSDL_Surface; - NeededPixFmt: PSDL_Pixelformat; -begin - NeededPixFmt:=@fmt_rgba; - if Typ= 'Plain' then NeededPixFmt:=@fmt_rgb - else - if (Typ='Transparent') or - (Typ='Colorized') - then NeededPixFmt:=@fmt_rgba - else - NeededPixFmt:=@fmt_rgb; - - - if not pixfmt_eq(TexSurface^.format, NeededPixFmt) then - begin - TempSurface:=TexSurface; - TexSurface:=SDL_ConvertSurface(TempSurface,NeededPixFmt,SDL_SWSURFACE); - SDL_FreeSurface(TempSurface); - end; -end; - -function TTextureUnit.GetScaledTexture(TexSurface: PSDL_Surface; W,H: Cardinal): PSDL_Surface; -var - TempSurface: PSDL_Surface; -begin - TempSurface:=TexSurface; - Result:=SDL_ScaleSurfaceRect(TempSurface, - 0,0,TempSurface^.W,TempSurface^.H, - W,H); -end; - -procedure TTextureUnit.ScaleTexture(var TexSurface: PSDL_Surface; W,H: Cardinal); -var - TempSurface: PSDL_Surface; -begin - TempSurface:=TexSurface; - TexSurface:=SDL_ScaleSurfaceRect(TempSurface, - 0,0,TempSurface^.W,TempSurface^.H, - W,H); - SDL_FreeSurface(TempSurface); -end; - -procedure TTextureUnit.FitTexture(var TexSurface: PSDL_Surface; W,H: Cardinal); -var - TempSurface: PSDL_Surface; -begin - TempSurface:=TexSurface; - with TempSurface^.format^ do - TexSurface:=SDL_CreateRGBSurface(SDL_SWSURFACE,W,H,BitsPerPixel,RMask, GMask, BMask, AMask); - SDL_SetAlpha(TexSurface, 0, 255); - SDL_SetAlpha(TempSurface, 0, 255); - SDL_BlitSurface(TempSurface,nil,TexSurface,nil); - SDL_FreeSurface(TempSurface); -end; - -procedure TTextureUnit.ColorizeTexture(TexSurface: PSDL_Surface; Col: Cardinal); - //returns hue within range [0.0-6.0) - function col2h(Color:Cardinal):double; - var - clr,hls: array[0..2] of double; - delta: double; - begin - clr[0]:=((Color and $ff0000) shr 16)/255; - clr[1]:=((Color and $ff00) shr 8)/255; - clr[2]:=(Color and $ff)/255; - hls[1]:=maxvalue(clr); - delta:=hls[1]-minvalue(clr); - if clr[0]=hls[1] then hls[0]:=(clr[1]-clr[2])/delta - else if clr[1]=hls[1] then hls[0]:=2.0+(clr[2]-clr[0])/delta - else if clr[2]=hls[1] then hls[0]:=4.0+(clr[0]-clr[1])/delta; - if hls[0]<0.0 then hls[0]:=hls[0]+6.0; - if hls[0]=6.0 then hls[0]:=0.0; - col2h:=hls[0]; - end; - procedure ColorizePixel(Pix: PByteArray; hue: Double); - var - i,j,k: Cardinal; - clr, hls: array[0..2] of Double; - delta, f, p, q, t: Double; - begin - hls[0]:=hue; - - clr[0] := Pix[0]/255; - clr[1] := Pix[1]/255; - clr[2] := Pix[2]/255; - - //calculate luminance and saturation from rgb - hls[1] := maxvalue(clr); //l:=... - delta := hls[1] - minvalue(clr); - - if hls[1] = 0.0 then - hls[2] := 0.0 - else - hls[2] := delta/hls[1]; //v:=... - - // calc new rgb from our hls (h from color, l ans s from pixel) - // if (hls[1]<>0.0) and (hls[2]<>0.0) then // only if colorizing makes sense - begin - k:=trunc(hls[0]); - f:=hls[0]-k; - p:=hls[1]*(1.0-hls[2]); - q:=hls[1]*(1.0-(hls[2]*f)); - t:=hls[1]*(1.0-(hls[2]*(1.0-f))); - case k of - 0: begin clr[0]:=hls[1]; clr[1]:=t; clr[2]:=p; end; - 1: begin clr[0]:=q; clr[1]:=hls[1]; clr[2]:=p; end; - 2: begin clr[0]:=p; clr[1]:=hls[1]; clr[2]:=t; end; - 3: begin clr[0]:=p; clr[1]:=q; clr[2]:=hls[1]; end; - 4: begin clr[0]:=t; clr[1]:=p; clr[2]:=hls[1]; end; - 5: begin clr[0]:=hls[1]; clr[1]:=p; clr[2]:=q; end; - end; - // and store new rgb back into the image - Pix[0]:=floor(255*clr[0]); - Pix[1]:=floor(255*clr[1]); - Pix[2]:=floor(255*clr[2]); - end; - end; - -var - DestinationHue: Double; - PixelIndex: Cardinal; -begin - DestinationHue:=col2h(Col); - for PixelIndex:=0 to (TexSurface^.W*TexSurface^.H -1) do - ColorizePixel(@(PByteArray(TexSurface^.Pixels)[PixelIndex*TexSurface^.format.BytesPerPixel]),DestinationHue); -end; - -function TTextureUnit.LoadTexture(FromRegistry: boolean; Identifier, Format, Typ: PChar; Col: LongWord): TTexture; -var - TexSurface: PSDL_Surface; - MipmapSurface: PSDL_Surface; - newWidth, newHeight: Cardinal; - oldWidth, oldHeight: Cardinal; - kopierindex: Cardinal; -begin - Log.BenchmarkStart(4); - Mipmapping := true; -(* - Log.LogStatus( '', '' ); - - if Identifier = nil then - Log.LogStatus(' ERROR unknown Identifier', 'Id:'''+Identifier+''' Fmt:'''+Format+''' Typ:'''+Typ+'''') - else - Log.LogStatus(' should be ok - trying to load', 'Id:'''+Identifier+''' Fmt:'''+Format+''' Typ:'''+Typ+''''); -*) - - // load texture data into memory - {$ifdef blindydebug} - Log.LogStatus('',' ----------------------------------------------------'); - Log.LogStatus('',' LoadImage('''+Identifier+''') (called by '+Format+')'); - {$endif} - TexSurface := LoadImage(Identifier); - {$ifdef blindydebug} - Log.LogStatus('',' ok'); - {$endif} - if not assigned(TexSurface) then - begin - Log.LogStatus( 'ERROR Could not load texture' , Identifier +' '+ Format +' '+ Typ ); - beep; - Exit; - end; - - // convert pixel format as needed - {$ifdef blindydebug} - Log.LogStatus('',' AdjustPixelFormat'); - {$endif} - AdjustPixelFormat(TexSurface, Typ); - {$ifdef blindydebug} - Log.LogStatus('',' ok'); - {$endif} - // adjust texture size (scale down, if necessary) - newWidth := TexSurface.W; - newHeight := TexSurface.H; - - if (newWidth > Limit) then - newWidth := Limit; - - if (newHeight > Limit) then - newHeight := Limit; - - if (TexSurface.W > newWidth) or (TexSurface.H > newHeight) then - begin - {$ifdef blindydebug} - Log.LogStatus('',' ScaleTexture'); - {$endif} - ScaleTexture(TexSurface,newWidth,newHeight); - {$ifdef blindydebug} - Log.LogStatus('',' ok'); - {$endif} - end; - - {$ifdef blindydebug} - Log.LogStatus('',' JB-1 : typ='+Typ); - {$endif} - - - - // don't actually understand, if this is needed... - // this should definately be changed... together with all this - // cover cache stuff - if (CreateCacheMipmap) and (Typ='Plain') then - begin - {$ifdef blindydebug} - Log.LogStatus('',' JB-1 : Minimap'); - {$endif} - - if (Covers.W <= 256) and (Covers.H <= 256) then - begin - {$ifdef blindydebug} - Log.LogStatus('',' GetScaledTexture('''+inttostr(Covers.W)+''','''+inttostr(Covers.H)+''') (for CacheMipmap)'); - {$endif} - MipmapSurface:=GetScaledTexture(TexSurface,Covers.W, Covers.H); - if assigned(MipmapSurface) then - begin - {$ifdef blindydebug} - Log.LogStatus('',' ok'); - Log.LogStatus('',' BlitSurface Stuff'); - {$endif} - // creating and freeing the surface could be done once, if Cover.W and Cover.H don't change - CacheMipmapSurface:=SDL_CreateRGBSurfaceFrom(@CacheMipmap[0], Covers.W, Covers.H, 24, Covers.W*3, $000000ff, $0000ff00, $00ff0000, 0); - SDL_BlitSurface(MipMapSurface,nil,CacheMipmapSurface,nil); - SDL_FreeSurface(CacheMipmapSurface); - {$ifdef blindydebug} - Log.LogStatus('',' ok'); - Log.LogStatus('',' SDL_FreeSurface (CacheMipmap)'); - {$endif} - SDL_FreeSurface(MipmapSurface); - {$ifdef blindydebug} - Log.LogStatus('',' ok'); - {$endif} - end - else - begin - Log.LogStatus(' Error creating CacheMipmap',' LoadTexture('''+Identifier+''')'); - end; - end; - // should i create a cache texture, if Covers.W/H are larger? - end; - - {$ifdef blindydebug} - Log.LogStatus('',' JB-2'); - {$endif} - - - // now we might colorize the whole thing - if Typ='Colorized' then - ColorizeTexture(TexSurface,Col); - - // save actual dimensions of our texture - oldWidth:=newWidth; - oldHeight:=newHeight; - // make texture dimensions be powers of 2 - newWidth:=Round(Power(2, Ceil(Log2(newWidth)))); - newHeight:=Round(Power(2, Ceil(Log2(newHeight)))); - if (newHeight <> oldHeight) or (newWidth <> oldWidth) then - FitTexture(TexSurface,newWidth,newHeight); - - // at this point we have the image in memory... - // scaled to be at most 1024x1024 pixels large - // scaled so that dimensions are powers of 2 - // and converted to either RGB or RGBA - - {$ifdef blindydebug} - Log.LogStatus('',' JB-3'); - {$endif} - - - // if we got a Texture of Type Plain, Transparent or Colorized, - // then we're done manipulating it - // and could now create our openGL texture from it - - // prepare OpenGL texture - - // JB_linux : this is causing AV's on linux... ActText seems to be nil ! -// {$IFnDEF win32} -// if pointer(ActTex) = nil then -// exit; -// {$endif} - - glGenTextures(1, @ActTex); - - glBindTexture(GL_TEXTURE_2D, ActTex); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); - - // load data into gl texture - if (Typ = 'Transparent') or - (Typ='Colorized') then - begin - glTexImage2D(GL_TEXTURE_2D, 0, 4, newWidth, newHeight, 0, GL_RGBA, GL_UNSIGNED_BYTE, TexSurface.pixels); - end - {if Typ = 'Plain' then} else - begin - glTexImage2D(GL_TEXTURE_2D, 0, 3, newWidth, newHeight, 0, GL_RGB, GL_UNSIGNED_BYTE, TexSurface.pixels); - end; - - {$ifdef blindydebug} - Log.LogStatus('',' JB-4'); - {$endif} - -{ - if Typ = 'Transparent Range' then - // set alpha to 256-green-component (not sure) - Pix := TextureB.Canvas.Pixels[Position2, Position]; - TextureD32[Position*TexNewW + Position2+1, 1] := Pix; - TextureD32[Position*TexNewW + Position2+1, 2] := Pix div 256; - TextureD32[Position*TexNewW + Position2+1, 3] := Pix div (256*256); - TextureD32[Position*TexNewW + Position2+1, 4] := 256 - Pix div 256; -} -{ - if Typ = 'Font' then - // either create luminance-alpha texture - // or use transparency from differently saved file - // or do something totally different (text engine with ttf) - Pix := PPix[Position2 * 3]; - TextureD16[Position*TextureB.Width + Position2 + 1, 1] := 255; - TextureD16[Position*TextureB.Width + Position2 + 1, 2] := Pix; - glTexImage2D(GL_TEXTURE_2D, 0, 2, TextureB.Width, TextureB.Height, 0, GL_LUMINANCE_ALPHA, GL_UNSIGNED_BYTE, @TextureD16); -} -{ - if Typ = 'Font Outline' then - // no idea... - begin - TextureB.PixelFormat := pf24bit; - for Position := 0 to TextureB.Height-1 do begin - PPix := TextureB.ScanLine[Position]; - for Position2 := 0 to TextureB.Width-1 do begin - Pix := PPix[Position2 * 3]; - - Col := Pix; - if Col < 127 then Col := 127; - - TempA := Pix; - if TempA >= 95 then TempA := 255; - if TempA >= 31 then TempA := 255; - if Pix < 95 then TempA := (Pix * 256) div 96; - - - TextureD16[Position*TextureB.Width + Position2 + 1, 1] := Col; - TextureD16[Position*TextureB.Width + Position2 + 1, 2] := TempA; - end; - end; - glTexImage2D(GL_TEXTURE_2D, 0, 2, TextureB.Width, TextureB.Height, 0, GL_LUMINANCE_ALPHA, GL_UNSIGNED_BYTE, @TextureD16); - end; -} -{ - if Typ = 'Font Outline 2' then - // same as above - begin - TextureB.PixelFormat := pf24bit; - for Position := 0 to TextureB.Height-1 do begin - PPix := TextureB.ScanLine[Position]; - for Position2 := 0 to TextureB.Width-1 do begin - Pix := PPix[Position2 * 3]; - - Col := Pix; - if Col < 31 then Col := 31; - - TempA := Pix; - if TempA >= 31 then TempA := 255; - if Pix < 31 then TempA := Pix * (256 div 32); - - TextureD16[Position*TextureB.Width + Position2 + 1, 1] := Col; - TextureD16[Position*TextureB.Width + Position2 + 1, 2] := TempA; - end; - end; - glTexImage2D(GL_TEXTURE_2D, 0, 2, TextureB.Width, TextureB.Height, 0, GL_LUMINANCE_ALPHA, GL_UNSIGNED_BYTE, @TextureD16); - if Mipmapping then glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR); - if Mipmapping then begin - Error := gluBuild2DMipmaps(GL_TEXTURE_2D, 2, TextureB.Width, TextureB.Height, GL_LUMINANCE_ALPHA, GL_UNSIGNED_BYTE, @TextureD16); - if Error > 0 then beep; - end; - end; - - if Typ = 'Font Black' then - // and so on - begin - // normalnie 0,125s bez niczego 0,015s - 0,030s z pix 0,125s <-- ??? - // dimensions - TextureB.PixelFormat := pf24bit; - TexOrigW := TextureB.Width; - TexOrigH := TextureB.Height; - TexNewW := Round(Power(2, Ceil(Log2(TexOrigW)))); - TexNewH := Round(Power(2, Ceil(Log2(TexOrigH)))); - TextureB.Width := TexNewW; - TextureB.Height := TexNewH; - // copy and process pixeldata - for Position := 0 to TextureB.Height-1 do begin - PPix := TextureB.ScanLine[Position]; - for Position2 := 0 to TextureB.Width-1 do begin - Pix := PPix[Position2*3]; - TextureD32[Position*TextureB.Width + Position2 + 1, 1] := 255; - TextureD32[Position*TextureB.Width + Position2 + 1, 2] := 255; - TextureD32[Position*TextureB.Width + Position2 + 1, 3] := 255; - TextureD32[Position*TextureB.Width + Position2 + 1, 4] := 255 - (Pix mod 256); - end; - end; - glTexImage2D(GL_TEXTURE_2D, 0, 4, TextureB.Width, TextureB.Height, 0, GL_RGBA, GL_UNSIGNED_BYTE, @TextureD32); - end; - - if Typ = 'Alpha Black Colored' then - // ... hope, noone needs this - begin - TextureB.PixelFormat := pf24bit; - TexOrigW := TextureB.Width; - TexOrigH := TextureB.Height; - TexNewW := Round(Power(2, Ceil(Log2(TexOrigW)))); - TexNewH := Round(Power(2, Ceil(Log2(TexOrigH)))); - TextureB.Width := TexNewW; - TextureB.Height := TexNewH; - // copy and process pixeldata - for Position := 0 to TextureB.Height-1 do begin - PPix := TextureB.ScanLine[Position]; - for Position2 := 0 to TextureB.Width-1 do begin - Pix := PPix[Position2*3]; - TextureD32[Position*TextureB.Width + Position2 + 1, 1] := (Col div $10000) and $FF; - TextureD32[Position*TextureB.Width + Position2 + 1, 2] := (Col div $100) and $FF; - TextureD32[Position*TextureB.Width + Position2 + 1, 3] := Col and $FF; - TextureD32[Position*TextureB.Width + Position2 + 1, 4] := 255 - (Pix mod 256); - end; - end; - glTexImage2D(GL_TEXTURE_2D, 0, 4, TextureB.Width, TextureB.Height, 0, GL_RGBA, GL_UNSIGNED_BYTE, @TextureD32); - end; - - if Typ = 'Font Gray' then - begin - // dimensions - TexOrigW := TextureB.Width; - TexOrigH := TextureB.Height; - TexNewW := Round(Power(2, Ceil(Log2(TexOrigW)))); - TexNewH := Round(Power(2, Ceil(Log2(TexOrigH)))); - TextureB.Width := TexNewW; - TextureB.Height := TexNewH; - // copy and process pixeldata - for Position := 0 to TextureB.Height-1 do begin - for Position2 := 0 to TextureB.Width-1 do begin - Pix := TextureB.Canvas.Pixels[Position2, Position]; - TextureD32[Position*TextureB.Width + Position2 + 1, 1] := 127; - TextureD32[Position*TextureB.Width + Position2 + 1, 2] := 127; - TextureD32[Position*TextureB.Width + Position2 + 1, 3] := 127; - TextureD32[Position*TextureB.Width + Position2 + 1, 4] := 255 - (Pix mod 256); - end; - end; - glTexImage2D(GL_TEXTURE_2D, 0, 4, TextureB.Width, TextureB.Height, 0, GL_RGBA, GL_UNSIGNED_BYTE, @TextureD32); - end; - - if Typ = 'Arrow' then - begin - TextureB.PixelFormat := pf24bit; - for Position := 0 to TextureB.Height-1 do begin - PPix := TextureB.ScanLine[Position]; - for Position2 := 0 to TextureB.Width-1 do begin - Pix := PPix[Position2 * 3]; - - // transparency - if Pix >= 127 then TempA := 255; - if Pix < 127 then TempA := Pix * 2; - - // ColInt = color intensity - if Pix < 127 then ColInt := 1; - if Pix >= 127 then ColInt := 2 - Pix / 128; - //0.75, 0.6, 0.25 - - TextureD32[Position*TextureB.Width + Position2 + 1, 1] := Round(ColInt * 0.75 * 255 + (1 - ColInt) * 255); - TextureD32[Position*TextureB.Width + Position2 + 1, 2] := Round(ColInt * 0.6 * 255 + (1 - ColInt) * 255); - TextureD32[Position*TextureB.Width + Position2 + 1, 3] := Round(ColInt * 0.25 * 255 + (1 - ColInt) * 255); - TextureD32[Position*TextureB.Width + Position2 + 1, 4] := TempA; - end; - end; - glTexImage2D(GL_TEXTURE_2D, 0, 4, TextureB.Width, TextureB.Height, 0, GL_RGBA, GL_UNSIGNED_BYTE, @TextureD32); - - if Mipmapping then glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR); - if Mipmapping then begin - Error := gluBuild2DMipmaps(GL_TEXTURE_2D, 4, TextureB.Width, TextureB.Height, GL_RGBA, GL_UNSIGNED_BYTE, @TextureD32); - if Error > 0 then beep; - end; - end; - - if Typ = 'Note Plain' then - begin - for Position := 0 to TextureB.Height-1 do - begin - PPix := TextureB.ScanLine[Position]; - for Position2 := 0 to TextureB.Width-1 do - begin - - - - // Skin Patch - // 0-191= Fade Black to Col, 192= Col, 193-254 Fade Col to White, 255= White - case PPix[Position2*3] of - 0..191: Pix := $10000 * ((((Col div $10000) and $FF) * PPix[Position2*3]) div $Bf) + $100 * ((((Col div $100) and $FF) * PPix[Position2*3]) div $Bf) + (((Col and $FF) * PPix[Position2*3]) div $Bf); - 192: Pix := Col; - 193..254: Pix := Col + ($10000 * ((($FF - ((Col div $10000) and $FF)) * ((PPix[Position2*3] - $C0) * 4) ) div $FF) + $100 * ((($FF - ((Col div $100) and $FF)) * ((PPix[Position2*3] - $C0) * 4)) div $FF) + ((($FF - (Col and $FF)) * ((PPix[Position2*3] - $C0) * 4)) div $FF)); - 255: Pix := $FFFFFF; - end; -// 0.5.0. Original -// case PPix[Position2*3] of -// 128: Pix := $10000 * ((Col div $10000) div 2) + $100 * (((Col div $100) and $FF) div 2) + (Col and $FF) div 2; -// 192: Pix := Col; -// 255: Pix := $FFFFFF; -// end; - - - - - - TextureD24[Position*TextureB.Width + Position2 + 1, 1] := Pix div $10000; - TextureD24[Position*TextureB.Width + Position2 + 1, 2] := (Pix div $100) and $FF; - TextureD24[Position*TextureB.Width + Position2 + 1, 3] := Pix and $FF; - end; - end; - glTexImage2D(GL_TEXTURE_2D, 0, 3, TextureB.Width, TextureB.Height, 0, GL_RGB, GL_UNSIGNED_BYTE, @TextureD24); - end; - - if Typ = 'Note Transparent' then - begin - for Position := 0 to TextureB.Height-1 do begin - PPix := TextureB.ScanLine[Position]; - for Position2 := 0 to TextureB.Width-1 do begin - TempA := 255; - - - - //Skin Patch - // 0= Transparent, 1-191= Fade Black to Col, 192= Col, 193-254 Fade Col to White, 255= White - case PPix[Position2*3] of - 0: TempA := 0; - 1..191: Pix := $10000 * ((((Col div $10000) and $FF) * PPix[Position2*3]) div $Bf) + $100 * ((((Col div $100) and $FF) * PPix[Position2*3]) div $Bf) + (((Col and $FF) * PPix[Position2*3]) div $Bf); - 192: Pix := Col; - 193..254: Pix := Col + ($10000 * ((($FF - ((Col div $10000) and $FF)) * ((PPix[Position2*3] - $C0) * 4) ) div $FF) + $100 * ((($FF - ((Col div $100) and $FF)) * ((PPix[Position2*3] - $C0) * 4)) div $FF) + ((($FF - (Col and $FF)) * ((PPix[Position2*3] - $C0) * 4)) div $FF)); - 255: Pix := $FFFFFF; - end; -// 0.5.0 Original -// case PPix[Position2*3] of -// 0: TempA := 0; -// 128: Pix := $10000 * ((Col div $10000) div 2) + $100 * (((Col div $100) and $FF) div 2) + (Col and $FF) div 2; -// 192: Pix := Col; -// 255: Pix := $FFFFFF; -// end; - - - - - TextureD32[Position*TextureB.Width + Position2 + 1, 1] := Pix div $10000; - TextureD32[Position*TextureB.Width + Position2 + 1, 2] := (Pix div $100) and $FF; - TextureD32[Position*TextureB.Width + Position2 + 1, 3] := Pix and $FF; - TextureD32[Position*TextureB.Width + Position2 + 1, 4] := TempA; - end; - end; - glTexImage2D(GL_TEXTURE_2D, 0, 4, TextureB.Width, TextureB.Height, 0, GL_RGBA, GL_UNSIGNED_BYTE, @TextureD32); - end; -} - - {$ifdef blindydebug} - Log.LogStatus('',' JB-5'); - {$endif} - - - Result.X := 0; - Result.Y := 0; - Result.W := 0; - Result.H := 0; - Result.ScaleW := 1; - Result.ScaleH := 1; - Result.Rot := 0; - Result.TexNum := ActTex; - Result.TexW := oldWidth / newWidth; - Result.TexH := oldHeight / newHeight; - - Result.Int := 1; - Result.ColR := 1; - Result.ColG := 1; - Result.ColB := 1; - Result.Alpha := 1; - - // 0.4.2 new test - default use whole texure, taking TexW and TexH as const and changing these - Result.TexX1 := 0; - Result.TexY1 := 0; - Result.TexX2 := 1; - Result.TexY2 := 1; - - {$ifdef blindydebug} - Log.LogStatus('',' JB-6'); - {$endif} - - - // 0.5.0 - Result.Name := Identifier; - - SDL_FreeSurface(TexSurface); - - {$ifdef blindydebug} - Log.LogStatus('',' JB-7'); - {$endif} - - - Log.BenchmarkEnd(4); - if Log.BenchmarkTimeLength[4] >= 1 then - Log.LogBenchmark('**********> Texture Load Time Warning - ' + Format + '/' + Identifier + '/' + Typ, 4); - - {$ifdef blindydebug} - Log.LogStatus('',' JB-8'); - {$endif} - -end; - - -function TTextureUnit.GetTexture(Name, Typ: string): TTexture; -begin - Result := GetTexture(Name, Typ, true); -end; - -function TTextureUnit.GetTexture(Name, Typ: string; FromCache: boolean): TTexture; -var - T: integer; // texture - C: integer; // cover - Data: array of byte; -begin - - if Name = '' then - exit; - - // find texture entry - T := FindTexture(Name); - - if T = -1 then - begin - // create texture entry - T := Length(TextureDatabase.Texture); - SetLength(TextureDatabase.Texture, T+1); - - TextureDatabase.Texture[T].Name := Name; - TextureDatabase.Texture[T].Typ := Typ; - - // inform database that no textures have been loaded into memory - TextureDatabase.Texture[T].Texture.TexNum := -1; - TextureDatabase.Texture[T].TextureCache.TexNum := -1; - end; - - // use preloaded texture - if (not FromCache) or (FromCache and not Covers.CoverExists(Name)) then - begin - // use full texture - if TextureDatabase.Texture[T].Texture.TexNum = -1 then - begin - // load texture - {$ifdef blindydebug} - Log.LogStatus('...', 'GetTexture('''+Name+''','''+Typ+''')'); - {$endif} - TextureDatabase.Texture[T].Texture := LoadTexture(false, pchar(Name), 'JPG', pchar(Typ), $0); - {$ifdef blindydebug} - Log.LogStatus('done',' '); - {$endif} - end; - - // use texture - Result := TextureDatabase.Texture[T].Texture; - end; - - if FromCache and Covers.CoverExists(Name) then - begin - // use cache texture - C := Covers.CoverNumber(Name); - - if TextureDatabase.Texture[T].TextureCache.TexNum = -1 then - begin - // load texture - Covers.PrepareData(Name); - TextureDatabase.Texture[T].TextureCache := CreateTexture(Covers.Data, Name, Covers.Cover[C].W, Covers.Cover[C].H, 24); - end; - - // use texture - Result := TextureDatabase.Texture[T].TextureCache; - end; -end; - -function TTextureUnit.FindTexture(Name: string): integer; -var - T: integer; // texture -begin - Result := -1; - for T := 0 to high(TextureDatabase.Texture) do - if TextureDatabase.Texture[T].Name = Name then - Result := T; -end; - -function TTextureUnit.LoadTexture(Identifier, Format, Typ: PChar; Col: LongWord): TTexture; -begin - Result := LoadTexture(false, Identifier, Format, Typ, Col); -end; - -function TTextureUnit.LoadTexture(Identifier: string): TTexture; -begin - Result := LoadTexture(false, pchar(Identifier), 'JPG', 'Plain', 0); -end; - -function TTextureUnit.CreateTexture(var Data: array of byte; Name: string; W, H: word; Bits: byte): TTexture; -var - Position: integer; - Position2: integer; - Pix: integer; - ColInt: real; - PPix: PByteArray; - TempA: integer; - Error: integer; -begin - Mipmapping := false; - - glGenTextures(1, @ActTex); // ActText = new texture number - glBindTexture(GL_TEXTURE_2D, ActTex); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); - - glTexImage2D(GL_TEXTURE_2D, 0, 3, W, H, 0, GL_RGB, GL_UNSIGNED_BYTE, @Data[0]); - if Mipmapping then begin - Error := gluBuild2DMipmaps(GL_TEXTURE_2D, 3, W, H, GL_RGB, GL_UNSIGNED_BYTE, @Data[0]); - if Error > 0 then beep; - end; - - Result.X := 0; - Result.Y := 0; - Result.W := 0; - Result.H := 0; - Result.ScaleW := 1; - Result.ScaleH := 1; - Result.Rot := 0; - Result.TexNum := ActTex; - Result.TexW := 1; - Result.TexH := 1; - - Result.Int := 1; - Result.ColR := 1; - Result.ColG := 1; - Result.ColB := 1; - Result.Alpha := 1; - - // 0.4.2 new test - default use whole texure, taking TexW and TexH as const and changing these - Result.TexX1 := 0; - Result.TexY1 := 0; - Result.TexX2 := 1; - Result.TexY2 := 1; - - // 0.5.0 - Result.Name := Name; -end; - -procedure TTextureUnit.UnloadTexture(Name: string; FromCache: boolean); -var - T: integer; - TexNum: GLuint; -begin - T := FindTexture(Name); - - if not FromCache then begin - TexNum := TextureDatabase.Texture[T].Texture.TexNum; - if TexNum >= 0 then begin - glDeleteTextures(1, @TexNum); - TextureDatabase.Texture[T].Texture.TexNum := -1; -// Log.LogError('Unload texture no '+IntToStr(TexNum)); - end; - end else begin - TexNum := TextureDatabase.Texture[T].TextureCache.TexNum; - if TexNum >= 0 then begin - glDeleteTextures(1, @TexNum); - TextureDatabase.Texture[T].TextureCache.TexNum := -1; -// Log.LogError('Unload texture cache no '+IntToStr(TexNum)); - end; - end; -end; - -{$IFDEF LAZARUS} -initialization - {$I UltraStar.lrs} -{$ENDIF} - - -end. +unit UTexture; +// added for easier debug disabling +{$define blindydebug} + +// Plain (alpha = 1) +// Transparent +// Colorized + +// obsolete? +// Transparent Range +// Font (white is drawn, black is transparent) +// Font Outline (Font with darker outline) +// Font Outline 2 (Font with darker outline) +// Font Black (black is drawn, white is transparent) +// Font Gray (gray is drawn, white is transparent) +// Arrow (for arrows, white is white, gray has color, black is transparent); + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses OpenGL12, + {$IFDEF win32} + windows, + {$ENDIF} + Math, + Classes, + SysUtils, + Graphics, + UCommon, + UThemes, + SDL, + sdlutils, + SDL_Image; + +type + TTexture = record + TexNum: integer; + X: real; + Y: real; + Z: real; // new + W: real; + H: real; + ScaleW: real; // for dynamic scalling while leaving width constant + ScaleH: real; // for dynamic scalling while leaving height constant + Rot: real; // 0 - 2*pi + Int: real; // intensity + ColR: real; + ColG: real; + ColB: real; + TexW: real; // used? + TexH: real; // used? + TexX1: real; + TexY1: real; + TexX2: real; + TexY2: real; + Alpha: real; + Name: string; // 0.5.0: experimental for handling cache images. maybe it's useful for dynamic skins + end; + + TTextureEntry = record + Name: string; + Typ: string; + + // we use normal TTexture, it's easier to implement and if needed - we copy ready data + Texture: TTexture; + TextureCache: TTexture; // 0.5.0 + end; + + TTextureDatabase = record + Texture: array of TTextureEntry; + end; + + TTextureUnit = class + + private + function LoadImage(Identifier: PChar): PSDL_Surface; + function pixfmt_eq(fmt1,fmt2: PSDL_Pixelformat): boolean; + procedure AdjustPixelFormat(var TexSurface: PSDL_Surface; Typ: PChar); + function GetScaledTexture(TexSurface: PSDL_Surface; W,H: Cardinal): PSDL_Surface; + procedure ScaleTexture(var TexSurface: PSDL_Surface; W,H: Cardinal); + procedure FitTexture(var TexSurface: PSDL_Surface; W,H: Cardinal); + procedure ColorizeTexture(TexSurface: PSDL_Surface; Col: Cardinal); + + public + Limit: integer; + CreateCacheMipmap: boolean; + +// function GetNumberFor + function GetTexture(Name, Typ: string): TTexture; overload; + function GetTexture(Name, Typ: string; FromCache: boolean): TTexture; overload; + function FindTexture(Name: string): integer; + function LoadTexture(FromRegistry: boolean; Identifier, Format, Typ: PChar; Col: LongWord): TTexture; overload; + function LoadTexture(Identifier, Format, Typ: PChar; Col: LongWord): TTexture; overload; + function LoadTexture(Identifier: string): TTexture; overload; + function CreateTexture(var Data: array of byte; Name: string; W, H: word; Bits: byte): TTexture; + procedure UnloadTexture(Name: string; FromCache: boolean); + Constructor Create; + Destructor Destroy; + end; + +var + Texture: TTextureUnit; + TextureDatabase: TTextureDatabase; + + // this should be in UDisplay?! + PrintScreenData: array[0..1024*768-1] of longword; + + ActTex: GLuint;//integer; + +// TextureD8: array[1..1024*1024] of byte; // 1MB + TextureD16: array[1..1024*1024, 1..2] of byte; // luminance/alpha tex (2MB) +// TextureD24: array[1..1024*1024, 1..3] of byte; // normal 24-bit tex (3MB) +// TextureD242: array[1..512*512, 1..3] of byte; // normal 24-bit tex (0,75MB) +// TextureD32: array[1..1024*1024, 1..4] of byte; // transparent 32-bit tex (4MB) + // total 40MB at 2048*2048 + // total 10MB at 1024*1024 + + Mipmapping: Boolean; + + CacheMipmap: array[0..256*256*3-1] of byte; // 3KB + CacheMipmapSurface: PSDL_Surface; + + +implementation + +uses ULog, + DateUtils, + UCovers, + {$IFDEF LAZARUS} + LResources, + {$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); + + +Constructor TTextureUnit.Create; +begin + inherited Create; +end; + +Destructor TTextureUnit.Destroy; +begin + inherited Destroy; +end; + +function TTextureUnit.pixfmt_eq(fmt1,fmt2: PSDL_Pixelformat): boolean; +begin + if (fmt1^.BitsPerPixel = fmt2^.BitsPerPixel) and + (fmt1^.BytesPerPixel = fmt2^.BytesPerPixel) and + (fmt1^.Rloss = fmt2^.Rloss) and (fmt1^.Gloss = fmt2^.Gloss) and + (fmt1^.Bloss = fmt2^.Bloss) and (fmt1^.Rmask = fmt2^.Rmask) and + (fmt1^.Gmask = fmt2^.Gmask) and (fmt1^.Bmask = fmt2^.Bmask) and + (fmt1^.Rshift = fmt2^.Rshift) and (fmt1^.Gshift = fmt2^.Gshift) and + (fmt1^.Bshift = fmt2^.Bshift) + then + Result:=True + else + Result:=False; +end; + +// +++++++++++++++++++++ helpers for loadimage +++++++++++++++ + 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; +// ----------------------------------------------- + +function TTextureUnit.LoadImage(Identifier: PChar): PSDL_Surface; +var + + TexRWops: PSDL_RWops; + dHandle: THandle; + + {$IFDEF LAZARUS} + lLazRes : TLResource; + lResData : TStringStream; + {$ELSE} + TexStream: TStream; + {$ENDIF} + +begin + Result := nil; + TexRWops := nil; + +// Log.LogStatus( Identifier, 'LoadImage' ); + + if ( FileExists(Identifier) ) then + begin + // load from file + Log.LogStatus( 'Is File', ' LoadImage' ); + try + Result:=IMG_Load(Identifier); + except + Log.LogStatus( 'ERROR Could not load from file' , Identifier); + beep; + Exit; + end; + end + else + begin + Log.LogStatus( 'IS Resource, because file does not exist.('+Identifier+')', ' LoadImage' ); + + // load from resource stream + {$IFDEF DELPHI} + dHandle := FindResource(hInstance, Identifier, 'TEX'); + if dHandle=0 then + begin + Log.LogStatus( 'ERROR Could not find resource' , ' '+ Identifier); + beep; + Exit; + end; + + + TexStream := nil; + try + TexStream := TResourceStream.Create(HInstance, Identifier, 'TEX'); + except + Log.LogStatus( 'ERROR Could not load from resource' , Identifier); + beep; + Exit; + end; + + try + TexStream.position := 0; + try + TexRWops := SDL_AllocRW; + TexRWops.unknown := TUnknown(TexStream); + TexRWops.seek := SDLStreamSeek; + TexRWops.read := SDLStreamRead; + TexRWops.write := nil; + TexRWops.close := SDLStreamClose; + TexRWops.type_ := 2; + except + Log.LogStatus( 'ERROR Could not assign resource' , Identifier); + beep; + Exit; + end; + + Log.LogStatus( 'resource Assigned....' , Identifier); + Result:=IMG_Load_RW(TexRWops,0); + SDL_FreeRW(TexRWops); + + finally + if assigned( TexStream ) then + freeandnil( TexStream ); + end; + + + {$ELSE} + lLazRes := LazFindResource( Identifier, 'TEX' ); + if lLazRes <> nil then + begin + lResData := TStringStream.create( lLazRes.value ); + try + lResData.position := 0; + try + TexRWops := SDL_AllocRW; + TexRWops.unknown := TUnknown( lResData ); + TexRWops.seek := SDLStreamSeek; + TexRWops.read := SDLStreamRead; + TexRWops.write := nil; + TexRWops.close := SDLStreamClose; + TexRWops.type_ := 2; + except + Log.LogStatus( 'ERROR Could not assign resource ('+Identifier+')' , Identifier); + beep; + Exit; + end; + + Result := IMG_Load_RW(TexRWops,0); + SDL_FreeRW(TexRWops); + finally + freeandnil( lResData ); + end; + end + else + begin + Log.LogStatus( 'NOT found in Resource ('+Identifier+')', ' LoadImage' ); + end; + {$ENDIF} + + + end; +end; + +procedure TTextureUnit.AdjustPixelFormat(var TexSurface: PSDL_Surface; Typ: PChar); +var + TempSurface: PSDL_Surface; + NeededPixFmt: PSDL_Pixelformat; +begin + NeededPixFmt:=@fmt_rgba; + if Typ= 'Plain' then NeededPixFmt:=@fmt_rgb + else + if (Typ='Transparent') or + (Typ='Colorized') + then NeededPixFmt:=@fmt_rgba + else + NeededPixFmt:=@fmt_rgb; + + + if not pixfmt_eq(TexSurface^.format, NeededPixFmt) then + begin + TempSurface:=TexSurface; + TexSurface:=SDL_ConvertSurface(TempSurface,NeededPixFmt,SDL_SWSURFACE); + SDL_FreeSurface(TempSurface); + end; +end; + +function TTextureUnit.GetScaledTexture(TexSurface: PSDL_Surface; W,H: Cardinal): PSDL_Surface; +var + TempSurface: PSDL_Surface; +begin + TempSurface:=TexSurface; + Result:=SDL_ScaleSurfaceRect(TempSurface, + 0,0,TempSurface^.W,TempSurface^.H, + W,H); +end; + +procedure TTextureUnit.ScaleTexture(var TexSurface: PSDL_Surface; W,H: Cardinal); +var + TempSurface: PSDL_Surface; +begin + TempSurface:=TexSurface; + TexSurface:=SDL_ScaleSurfaceRect(TempSurface, + 0,0,TempSurface^.W,TempSurface^.H, + W,H); + SDL_FreeSurface(TempSurface); +end; + +procedure TTextureUnit.FitTexture(var TexSurface: PSDL_Surface; W,H: Cardinal); +var + TempSurface: PSDL_Surface; +begin + TempSurface:=TexSurface; + with TempSurface^.format^ do + TexSurface:=SDL_CreateRGBSurface(SDL_SWSURFACE,W,H,BitsPerPixel,RMask, GMask, BMask, AMask); + SDL_SetAlpha(TexSurface, 0, 255); + SDL_SetAlpha(TempSurface, 0, 255); + SDL_BlitSurface(TempSurface,nil,TexSurface,nil); + SDL_FreeSurface(TempSurface); +end; + +procedure TTextureUnit.ColorizeTexture(TexSurface: PSDL_Surface; Col: Cardinal); + //returns hue within range [0.0-6.0) + function col2h(Color:Cardinal):double; + var + clr,hls: array[0..2] of double; + delta: double; + begin + clr[0]:=((Color and $ff0000) shr 16)/255; + clr[1]:=((Color and $ff00) shr 8)/255; + clr[2]:=(Color and $ff)/255; + hls[1]:=maxvalue(clr); + delta:=hls[1]-minvalue(clr); + if clr[0]=hls[1] then hls[0]:=(clr[1]-clr[2])/delta + else if clr[1]=hls[1] then hls[0]:=2.0+(clr[2]-clr[0])/delta + else if clr[2]=hls[1] then hls[0]:=4.0+(clr[0]-clr[1])/delta; + if hls[0]<0.0 then hls[0]:=hls[0]+6.0; + if hls[0]=6.0 then hls[0]:=0.0; + col2h:=hls[0]; + end; + procedure ColorizePixel(Pix: PByteArray; hue: Double); + var + i,j,k: Cardinal; + clr, hls: array[0..2] of Double; + delta, f, p, q, t: Double; + begin + hls[0]:=hue; + + clr[0] := Pix[0]/255; + clr[1] := Pix[1]/255; + clr[2] := Pix[2]/255; + + //calculate luminance and saturation from rgb + hls[1] := maxvalue(clr); //l:=... + delta := hls[1] - minvalue(clr); + + if hls[1] = 0.0 then + hls[2] := 0.0 + else + hls[2] := delta/hls[1]; //v:=... + + // calc new rgb from our hls (h from color, l ans s from pixel) + // if (hls[1]<>0.0) and (hls[2]<>0.0) then // only if colorizing makes sense + begin + k:=trunc(hls[0]); + f:=hls[0]-k; + p:=hls[1]*(1.0-hls[2]); + q:=hls[1]*(1.0-(hls[2]*f)); + t:=hls[1]*(1.0-(hls[2]*(1.0-f))); + case k of + 0: begin clr[0]:=hls[1]; clr[1]:=t; clr[2]:=p; end; + 1: begin clr[0]:=q; clr[1]:=hls[1]; clr[2]:=p; end; + 2: begin clr[0]:=p; clr[1]:=hls[1]; clr[2]:=t; end; + 3: begin clr[0]:=p; clr[1]:=q; clr[2]:=hls[1]; end; + 4: begin clr[0]:=t; clr[1]:=p; clr[2]:=hls[1]; end; + 5: begin clr[0]:=hls[1]; clr[1]:=p; clr[2]:=q; end; + end; + // and store new rgb back into the image + Pix[0]:=floor(255*clr[0]); + Pix[1]:=floor(255*clr[1]); + Pix[2]:=floor(255*clr[2]); + end; + end; + +var + DestinationHue: Double; + PixelIndex: Cardinal; +begin + DestinationHue:=col2h(Col); + for PixelIndex:=0 to (TexSurface^.W*TexSurface^.H -1) do + ColorizePixel(@(PByteArray(TexSurface^.Pixels)[PixelIndex*TexSurface^.format.BytesPerPixel]),DestinationHue); +end; + +function TTextureUnit.LoadTexture(FromRegistry: boolean; Identifier, Format, Typ: PChar; Col: LongWord): TTexture; +var + TexSurface: PSDL_Surface; + MipmapSurface: PSDL_Surface; + newWidth, newHeight: Cardinal; + oldWidth, oldHeight: Cardinal; + kopierindex: Cardinal; +begin + Log.BenchmarkStart(4); + Mipmapping := true; +(* + Log.LogStatus( '', '' ); + + if Identifier = nil then + Log.LogStatus(' ERROR unknown Identifier', 'Id:'''+Identifier+''' Fmt:'''+Format+''' Typ:'''+Typ+'''') + else + Log.LogStatus(' should be ok - trying to load', 'Id:'''+Identifier+''' Fmt:'''+Format+''' Typ:'''+Typ+''''); +*) + + // load texture data into memory + {$ifdef blindydebug} + Log.LogStatus('',' ----------------------------------------------------'); + Log.LogStatus('',' LoadImage('''+Identifier+''') (called by '+Format+')'); + {$endif} + TexSurface := LoadImage(Identifier); + {$ifdef blindydebug} + Log.LogStatus('',' ok'); + {$endif} + if not assigned(TexSurface) then + begin + Log.LogStatus( 'ERROR Could not load texture' , Identifier +' '+ Format +' '+ Typ ); + beep; + Exit; + end; + + // convert pixel format as needed + {$ifdef blindydebug} + Log.LogStatus('',' AdjustPixelFormat'); + {$endif} + AdjustPixelFormat(TexSurface, Typ); + {$ifdef blindydebug} + Log.LogStatus('',' ok'); + {$endif} + // adjust texture size (scale down, if necessary) + newWidth := TexSurface.W; + newHeight := TexSurface.H; + + if (newWidth > Limit) then + newWidth := Limit; + + if (newHeight > Limit) then + newHeight := Limit; + + if (TexSurface.W > newWidth) or (TexSurface.H > newHeight) then + begin + {$ifdef blindydebug} + Log.LogStatus('',' ScaleTexture'); + {$endif} + ScaleTexture(TexSurface,newWidth,newHeight); + {$ifdef blindydebug} + Log.LogStatus('',' ok'); + {$endif} + end; + + {$ifdef blindydebug} + Log.LogStatus('',' JB-1 : typ='+Typ); + {$endif} + + + + // don't actually understand, if this is needed... + // this should definately be changed... together with all this + // cover cache stuff + if (CreateCacheMipmap) and (Typ='Plain') then + begin + {$ifdef blindydebug} + Log.LogStatus('',' JB-1 : Minimap'); + {$endif} + + if (Covers.W <= 256) and (Covers.H <= 256) then + begin + {$ifdef blindydebug} + Log.LogStatus('',' GetScaledTexture('''+inttostr(Covers.W)+''','''+inttostr(Covers.H)+''') (for CacheMipmap)'); + {$endif} + MipmapSurface:=GetScaledTexture(TexSurface,Covers.W, Covers.H); + if assigned(MipmapSurface) then + begin + {$ifdef blindydebug} + Log.LogStatus('',' ok'); + Log.LogStatus('',' BlitSurface Stuff'); + {$endif} + // creating and freeing the surface could be done once, if Cover.W and Cover.H don't change + CacheMipmapSurface:=SDL_CreateRGBSurfaceFrom(@CacheMipmap[0], Covers.W, Covers.H, 24, Covers.W*3, $000000ff, $0000ff00, $00ff0000, 0); + SDL_BlitSurface(MipMapSurface,nil,CacheMipmapSurface,nil); + SDL_FreeSurface(CacheMipmapSurface); + {$ifdef blindydebug} + Log.LogStatus('',' ok'); + Log.LogStatus('',' SDL_FreeSurface (CacheMipmap)'); + {$endif} + SDL_FreeSurface(MipmapSurface); + {$ifdef blindydebug} + Log.LogStatus('',' ok'); + {$endif} + end + else + begin + Log.LogStatus(' Error creating CacheMipmap',' LoadTexture('''+Identifier+''')'); + end; + end; + // should i create a cache texture, if Covers.W/H are larger? + end; + + {$ifdef blindydebug} + Log.LogStatus('',' JB-2'); + {$endif} + + + // now we might colorize the whole thing + if Typ='Colorized' then + ColorizeTexture(TexSurface,Col); + + // save actual dimensions of our texture + oldWidth:=newWidth; + oldHeight:=newHeight; + // make texture dimensions be powers of 2 + newWidth:=Round(Power(2, Ceil(Log2(newWidth)))); + newHeight:=Round(Power(2, Ceil(Log2(newHeight)))); + if (newHeight <> oldHeight) or (newWidth <> oldWidth) then + FitTexture(TexSurface,newWidth,newHeight); + + // at this point we have the image in memory... + // scaled to be at most 1024x1024 pixels large + // scaled so that dimensions are powers of 2 + // and converted to either RGB or RGBA + + {$ifdef blindydebug} + Log.LogStatus('',' JB-3'); + {$endif} + + + // if we got a Texture of Type Plain, Transparent or Colorized, + // then we're done manipulating it + // and could now create our openGL texture from it + + // prepare OpenGL texture + + // JB_linux : this is causing AV's on linux... ActText seems to be nil ! +// {$IFnDEF win32} +// if pointer(ActTex) = nil then +// exit; +// {$endif} + + glGenTextures(1, @ActTex); + + glBindTexture(GL_TEXTURE_2D, ActTex); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); + + // load data into gl texture + if (Typ = 'Transparent') or + (Typ='Colorized') then + begin + glTexImage2D(GL_TEXTURE_2D, 0, 4, newWidth, newHeight, 0, GL_RGBA, GL_UNSIGNED_BYTE, TexSurface.pixels); + end + {if Typ = 'Plain' then} else + begin + glTexImage2D(GL_TEXTURE_2D, 0, 3, newWidth, newHeight, 0, GL_RGB, GL_UNSIGNED_BYTE, TexSurface.pixels); + end; + + {$ifdef blindydebug} + Log.LogStatus('',' JB-4'); + {$endif} + +{ + if Typ = 'Transparent Range' then + // set alpha to 256-green-component (not sure) + Pix := TextureB.Canvas.Pixels[Position2, Position]; + TextureD32[Position*TexNewW + Position2+1, 1] := Pix; + TextureD32[Position*TexNewW + Position2+1, 2] := Pix div 256; + TextureD32[Position*TexNewW + Position2+1, 3] := Pix div (256*256); + TextureD32[Position*TexNewW + Position2+1, 4] := 256 - Pix div 256; +} +{ + if Typ = 'Font' then + // either create luminance-alpha texture + // or use transparency from differently saved file + // or do something totally different (text engine with ttf) + Pix := PPix[Position2 * 3]; + TextureD16[Position*TextureB.Width + Position2 + 1, 1] := 255; + TextureD16[Position*TextureB.Width + Position2 + 1, 2] := Pix; + glTexImage2D(GL_TEXTURE_2D, 0, 2, TextureB.Width, TextureB.Height, 0, GL_LUMINANCE_ALPHA, GL_UNSIGNED_BYTE, @TextureD16); +} +{ + if Typ = 'Font Outline' then + // no idea... + begin + TextureB.PixelFormat := pf24bit; + for Position := 0 to TextureB.Height-1 do begin + PPix := TextureB.ScanLine[Position]; + for Position2 := 0 to TextureB.Width-1 do begin + Pix := PPix[Position2 * 3]; + + Col := Pix; + if Col < 127 then Col := 127; + + TempA := Pix; + if TempA >= 95 then TempA := 255; + if TempA >= 31 then TempA := 255; + if Pix < 95 then TempA := (Pix * 256) div 96; + + + TextureD16[Position*TextureB.Width + Position2 + 1, 1] := Col; + TextureD16[Position*TextureB.Width + Position2 + 1, 2] := TempA; + end; + end; + glTexImage2D(GL_TEXTURE_2D, 0, 2, TextureB.Width, TextureB.Height, 0, GL_LUMINANCE_ALPHA, GL_UNSIGNED_BYTE, @TextureD16); + end; +} +{ + if Typ = 'Font Outline 2' then + // same as above + begin + TextureB.PixelFormat := pf24bit; + for Position := 0 to TextureB.Height-1 do begin + PPix := TextureB.ScanLine[Position]; + for Position2 := 0 to TextureB.Width-1 do begin + Pix := PPix[Position2 * 3]; + + Col := Pix; + if Col < 31 then Col := 31; + + TempA := Pix; + if TempA >= 31 then TempA := 255; + if Pix < 31 then TempA := Pix * (256 div 32); + + TextureD16[Position*TextureB.Width + Position2 + 1, 1] := Col; + TextureD16[Position*TextureB.Width + Position2 + 1, 2] := TempA; + end; + end; + glTexImage2D(GL_TEXTURE_2D, 0, 2, TextureB.Width, TextureB.Height, 0, GL_LUMINANCE_ALPHA, GL_UNSIGNED_BYTE, @TextureD16); + if Mipmapping then glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR); + if Mipmapping then begin + Error := gluBuild2DMipmaps(GL_TEXTURE_2D, 2, TextureB.Width, TextureB.Height, GL_LUMINANCE_ALPHA, GL_UNSIGNED_BYTE, @TextureD16); + if Error > 0 then beep; + end; + end; + + if Typ = 'Font Black' then + // and so on + begin + // normalnie 0,125s bez niczego 0,015s - 0,030s z pix 0,125s <-- ??? + // dimensions + TextureB.PixelFormat := pf24bit; + TexOrigW := TextureB.Width; + TexOrigH := TextureB.Height; + TexNewW := Round(Power(2, Ceil(Log2(TexOrigW)))); + TexNewH := Round(Power(2, Ceil(Log2(TexOrigH)))); + TextureB.Width := TexNewW; + TextureB.Height := TexNewH; + // copy and process pixeldata + for Position := 0 to TextureB.Height-1 do begin + PPix := TextureB.ScanLine[Position]; + for Position2 := 0 to TextureB.Width-1 do begin + Pix := PPix[Position2*3]; + TextureD32[Position*TextureB.Width + Position2 + 1, 1] := 255; + TextureD32[Position*TextureB.Width + Position2 + 1, 2] := 255; + TextureD32[Position*TextureB.Width + Position2 + 1, 3] := 255; + TextureD32[Position*TextureB.Width + Position2 + 1, 4] := 255 - (Pix mod 256); + end; + end; + glTexImage2D(GL_TEXTURE_2D, 0, 4, TextureB.Width, TextureB.Height, 0, GL_RGBA, GL_UNSIGNED_BYTE, @TextureD32); + end; + + if Typ = 'Alpha Black Colored' then + // ... hope, noone needs this + begin + TextureB.PixelFormat := pf24bit; + TexOrigW := TextureB.Width; + TexOrigH := TextureB.Height; + TexNewW := Round(Power(2, Ceil(Log2(TexOrigW)))); + TexNewH := Round(Power(2, Ceil(Log2(TexOrigH)))); + TextureB.Width := TexNewW; + TextureB.Height := TexNewH; + // copy and process pixeldata + for Position := 0 to TextureB.Height-1 do begin + PPix := TextureB.ScanLine[Position]; + for Position2 := 0 to TextureB.Width-1 do begin + Pix := PPix[Position2*3]; + TextureD32[Position*TextureB.Width + Position2 + 1, 1] := (Col div $10000) and $FF; + TextureD32[Position*TextureB.Width + Position2 + 1, 2] := (Col div $100) and $FF; + TextureD32[Position*TextureB.Width + Position2 + 1, 3] := Col and $FF; + TextureD32[Position*TextureB.Width + Position2 + 1, 4] := 255 - (Pix mod 256); + end; + end; + glTexImage2D(GL_TEXTURE_2D, 0, 4, TextureB.Width, TextureB.Height, 0, GL_RGBA, GL_UNSIGNED_BYTE, @TextureD32); + end; + + if Typ = 'Font Gray' then + begin + // dimensions + TexOrigW := TextureB.Width; + TexOrigH := TextureB.Height; + TexNewW := Round(Power(2, Ceil(Log2(TexOrigW)))); + TexNewH := Round(Power(2, Ceil(Log2(TexOrigH)))); + TextureB.Width := TexNewW; + TextureB.Height := TexNewH; + // copy and process pixeldata + for Position := 0 to TextureB.Height-1 do begin + for Position2 := 0 to TextureB.Width-1 do begin + Pix := TextureB.Canvas.Pixels[Position2, Position]; + TextureD32[Position*TextureB.Width + Position2 + 1, 1] := 127; + TextureD32[Position*TextureB.Width + Position2 + 1, 2] := 127; + TextureD32[Position*TextureB.Width + Position2 + 1, 3] := 127; + TextureD32[Position*TextureB.Width + Position2 + 1, 4] := 255 - (Pix mod 256); + end; + end; + glTexImage2D(GL_TEXTURE_2D, 0, 4, TextureB.Width, TextureB.Height, 0, GL_RGBA, GL_UNSIGNED_BYTE, @TextureD32); + end; + + if Typ = 'Arrow' then + begin + TextureB.PixelFormat := pf24bit; + for Position := 0 to TextureB.Height-1 do begin + PPix := TextureB.ScanLine[Position]; + for Position2 := 0 to TextureB.Width-1 do begin + Pix := PPix[Position2 * 3]; + + // transparency + if Pix >= 127 then TempA := 255; + if Pix < 127 then TempA := Pix * 2; + + // ColInt = color intensity + if Pix < 127 then ColInt := 1; + if Pix >= 127 then ColInt := 2 - Pix / 128; + //0.75, 0.6, 0.25 + + TextureD32[Position*TextureB.Width + Position2 + 1, 1] := Round(ColInt * 0.75 * 255 + (1 - ColInt) * 255); + TextureD32[Position*TextureB.Width + Position2 + 1, 2] := Round(ColInt * 0.6 * 255 + (1 - ColInt) * 255); + TextureD32[Position*TextureB.Width + Position2 + 1, 3] := Round(ColInt * 0.25 * 255 + (1 - ColInt) * 255); + TextureD32[Position*TextureB.Width + Position2 + 1, 4] := TempA; + end; + end; + glTexImage2D(GL_TEXTURE_2D, 0, 4, TextureB.Width, TextureB.Height, 0, GL_RGBA, GL_UNSIGNED_BYTE, @TextureD32); + + if Mipmapping then glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR); + if Mipmapping then begin + Error := gluBuild2DMipmaps(GL_TEXTURE_2D, 4, TextureB.Width, TextureB.Height, GL_RGBA, GL_UNSIGNED_BYTE, @TextureD32); + if Error > 0 then beep; + end; + end; + + if Typ = 'Note Plain' then + begin + for Position := 0 to TextureB.Height-1 do + begin + PPix := TextureB.ScanLine[Position]; + for Position2 := 0 to TextureB.Width-1 do + begin + + + + // Skin Patch + // 0-191= Fade Black to Col, 192= Col, 193-254 Fade Col to White, 255= White + case PPix[Position2*3] of + 0..191: Pix := $10000 * ((((Col div $10000) and $FF) * PPix[Position2*3]) div $Bf) + $100 * ((((Col div $100) and $FF) * PPix[Position2*3]) div $Bf) + (((Col and $FF) * PPix[Position2*3]) div $Bf); + 192: Pix := Col; + 193..254: Pix := Col + ($10000 * ((($FF - ((Col div $10000) and $FF)) * ((PPix[Position2*3] - $C0) * 4) ) div $FF) + $100 * ((($FF - ((Col div $100) and $FF)) * ((PPix[Position2*3] - $C0) * 4)) div $FF) + ((($FF - (Col and $FF)) * ((PPix[Position2*3] - $C0) * 4)) div $FF)); + 255: Pix := $FFFFFF; + end; +// 0.5.0. Original +// case PPix[Position2*3] of +// 128: Pix := $10000 * ((Col div $10000) div 2) + $100 * (((Col div $100) and $FF) div 2) + (Col and $FF) div 2; +// 192: Pix := Col; +// 255: Pix := $FFFFFF; +// end; + + + + + + TextureD24[Position*TextureB.Width + Position2 + 1, 1] := Pix div $10000; + TextureD24[Position*TextureB.Width + Position2 + 1, 2] := (Pix div $100) and $FF; + TextureD24[Position*TextureB.Width + Position2 + 1, 3] := Pix and $FF; + end; + end; + glTexImage2D(GL_TEXTURE_2D, 0, 3, TextureB.Width, TextureB.Height, 0, GL_RGB, GL_UNSIGNED_BYTE, @TextureD24); + end; + + if Typ = 'Note Transparent' then + begin + for Position := 0 to TextureB.Height-1 do begin + PPix := TextureB.ScanLine[Position]; + for Position2 := 0 to TextureB.Width-1 do begin + TempA := 255; + + + + //Skin Patch + // 0= Transparent, 1-191= Fade Black to Col, 192= Col, 193-254 Fade Col to White, 255= White + case PPix[Position2*3] of + 0: TempA := 0; + 1..191: Pix := $10000 * ((((Col div $10000) and $FF) * PPix[Position2*3]) div $Bf) + $100 * ((((Col div $100) and $FF) * PPix[Position2*3]) div $Bf) + (((Col and $FF) * PPix[Position2*3]) div $Bf); + 192: Pix := Col; + 193..254: Pix := Col + ($10000 * ((($FF - ((Col div $10000) and $FF)) * ((PPix[Position2*3] - $C0) * 4) ) div $FF) + $100 * ((($FF - ((Col div $100) and $FF)) * ((PPix[Position2*3] - $C0) * 4)) div $FF) + ((($FF - (Col and $FF)) * ((PPix[Position2*3] - $C0) * 4)) div $FF)); + 255: Pix := $FFFFFF; + end; +// 0.5.0 Original +// case PPix[Position2*3] of +// 0: TempA := 0; +// 128: Pix := $10000 * ((Col div $10000) div 2) + $100 * (((Col div $100) and $FF) div 2) + (Col and $FF) div 2; +// 192: Pix := Col; +// 255: Pix := $FFFFFF; +// end; + + + + + TextureD32[Position*TextureB.Width + Position2 + 1, 1] := Pix div $10000; + TextureD32[Position*TextureB.Width + Position2 + 1, 2] := (Pix div $100) and $FF; + TextureD32[Position*TextureB.Width + Position2 + 1, 3] := Pix and $FF; + TextureD32[Position*TextureB.Width + Position2 + 1, 4] := TempA; + end; + end; + glTexImage2D(GL_TEXTURE_2D, 0, 4, TextureB.Width, TextureB.Height, 0, GL_RGBA, GL_UNSIGNED_BYTE, @TextureD32); + end; +} + + {$ifdef blindydebug} + Log.LogStatus('',' JB-5'); + {$endif} + + + Result.X := 0; + Result.Y := 0; + Result.W := 0; + Result.H := 0; + Result.ScaleW := 1; + Result.ScaleH := 1; + Result.Rot := 0; + Result.TexNum := ActTex; + Result.TexW := oldWidth / newWidth; + Result.TexH := oldHeight / newHeight; + + Result.Int := 1; + Result.ColR := 1; + Result.ColG := 1; + Result.ColB := 1; + Result.Alpha := 1; + + // 0.4.2 new test - default use whole texure, taking TexW and TexH as const and changing these + Result.TexX1 := 0; + Result.TexY1 := 0; + Result.TexX2 := 1; + Result.TexY2 := 1; + + {$ifdef blindydebug} + Log.LogStatus('',' JB-6'); + {$endif} + + + // 0.5.0 + Result.Name := Identifier; + + SDL_FreeSurface(TexSurface); + + {$ifdef blindydebug} + Log.LogStatus('',' JB-7'); + {$endif} + + + Log.BenchmarkEnd(4); + if Log.BenchmarkTimeLength[4] >= 1 then + Log.LogBenchmark('**********> Texture Load Time Warning - ' + Format + '/' + Identifier + '/' + Typ, 4); + + {$ifdef blindydebug} + Log.LogStatus('',' JB-8'); + {$endif} + +end; + + +function TTextureUnit.GetTexture(Name, Typ: string): TTexture; +begin + Result := GetTexture(Name, Typ, true); +end; + +function TTextureUnit.GetTexture(Name, Typ: string; FromCache: boolean): TTexture; +var + T: integer; // texture + C: integer; // cover + Data: array of byte; +begin + + if Name = '' then + exit; + + // find texture entry + T := FindTexture(Name); + + if T = -1 then + begin + // create texture entry + T := Length(TextureDatabase.Texture); + SetLength(TextureDatabase.Texture, T+1); + + TextureDatabase.Texture[T].Name := Name; + TextureDatabase.Texture[T].Typ := Typ; + + // inform database that no textures have been loaded into memory + TextureDatabase.Texture[T].Texture.TexNum := -1; + TextureDatabase.Texture[T].TextureCache.TexNum := -1; + end; + + // use preloaded texture + if (not FromCache) or (FromCache and not Covers.CoverExists(Name)) then + begin + // use full texture + if TextureDatabase.Texture[T].Texture.TexNum = -1 then + begin + // load texture + {$ifdef blindydebug} + Log.LogStatus('...', 'GetTexture('''+Name+''','''+Typ+''')'); + {$endif} + TextureDatabase.Texture[T].Texture := LoadTexture(false, pchar(Name), 'JPG', pchar(Typ), $0); + {$ifdef blindydebug} + Log.LogStatus('done',' '); + {$endif} + end; + + // use texture + Result := TextureDatabase.Texture[T].Texture; + end; + + if FromCache and Covers.CoverExists(Name) then + begin + // use cache texture + C := Covers.CoverNumber(Name); + + if TextureDatabase.Texture[T].TextureCache.TexNum = -1 then + begin + // load texture + Covers.PrepareData(Name); + TextureDatabase.Texture[T].TextureCache := CreateTexture(Covers.Data, Name, Covers.Cover[C].W, Covers.Cover[C].H, 24); + end; + + // use texture + Result := TextureDatabase.Texture[T].TextureCache; + end; +end; + +function TTextureUnit.FindTexture(Name: string): integer; +var + T: integer; // texture +begin + Result := -1; + for T := 0 to high(TextureDatabase.Texture) do + if TextureDatabase.Texture[T].Name = Name then + Result := T; +end; + +function TTextureUnit.LoadTexture(Identifier, Format, Typ: PChar; Col: LongWord): TTexture; +begin + Result := LoadTexture(false, Identifier, Format, Typ, Col); +end; + +function TTextureUnit.LoadTexture(Identifier: string): TTexture; +begin + Result := LoadTexture(false, pchar(Identifier), 'JPG', 'Plain', 0); +end; + +function TTextureUnit.CreateTexture(var Data: array of byte; Name: string; W, H: word; Bits: byte): TTexture; +var + Position: integer; + Position2: integer; + Pix: integer; + ColInt: real; + PPix: PByteArray; + TempA: integer; + Error: integer; +begin + Mipmapping := false; + + glGenTextures(1, @ActTex); // ActText = new texture number + glBindTexture(GL_TEXTURE_2D, ActTex); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); + + glTexImage2D(GL_TEXTURE_2D, 0, 3, W, H, 0, GL_RGB, GL_UNSIGNED_BYTE, @Data[0]); + if Mipmapping then begin + Error := gluBuild2DMipmaps(GL_TEXTURE_2D, 3, W, H, GL_RGB, GL_UNSIGNED_BYTE, @Data[0]); + if Error > 0 then beep; + end; + + Result.X := 0; + Result.Y := 0; + Result.W := 0; + Result.H := 0; + Result.ScaleW := 1; + Result.ScaleH := 1; + Result.Rot := 0; + Result.TexNum := ActTex; + Result.TexW := 1; + Result.TexH := 1; + + Result.Int := 1; + Result.ColR := 1; + Result.ColG := 1; + Result.ColB := 1; + Result.Alpha := 1; + + // 0.4.2 new test - default use whole texure, taking TexW and TexH as const and changing these + Result.TexX1 := 0; + Result.TexY1 := 0; + Result.TexX2 := 1; + Result.TexY2 := 1; + + // 0.5.0 + Result.Name := Name; +end; + +procedure TTextureUnit.UnloadTexture(Name: string; FromCache: boolean); +var + T: integer; + TexNum: GLuint; +begin + T := FindTexture(Name); + + if not FromCache then begin + TexNum := TextureDatabase.Texture[T].Texture.TexNum; + if TexNum >= 0 then begin + glDeleteTextures(1, @TexNum); + TextureDatabase.Texture[T].Texture.TexNum := -1; +// Log.LogError('Unload texture no '+IntToStr(TexNum)); + end; + end else begin + TexNum := TextureDatabase.Texture[T].TextureCache.TexNum; + if TexNum >= 0 then begin + glDeleteTextures(1, @TexNum); + TextureDatabase.Texture[T].TextureCache.TexNum := -1; +// Log.LogError('Unload texture cache no '+IntToStr(TexNum)); + end; + end; +end; + +{$IFDEF LAZARUS} +initialization + {$I UltraStar.lrs} +{$ENDIF} + + +end. diff --git a/Game/Code/Classes/uPluginLoader.pas b/Game/Code/Classes/uPluginLoader.pas index 0fe5d51a..87951fed 100644 --- a/Game/Code/Classes/uPluginLoader.pas +++ b/Game/Code/Classes/uPluginLoader.pas @@ -1,801 +1,801 @@ -unit UPluginLoader; -{********************* - UPluginLoader - Unit contains to Classes - TPluginLoader: Class Searching for and Loading the Plugins - TtehPlugins: Class that represents the Plugins in Modules chain -*********************} - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses UPluginDefs, UCoreModule; - -type - TPluginListItem = record - Info: TUS_PluginInfo; - State: Byte; //State of this Plugin: 0 - undefined; 1 - Loaded; 2 - Inited / Running; 4 - Unloaded; 254 - Loading aborted by Plugin; 255 - Unloaded because of Error - Path: String; //Path to this Plugin - NeedsDeInit: Boolean; //If this is Inited correctly this should be true - hLib: THandle; //Handle of Loaded Libary - Procs: record //Procs offered by Plugin. Don't call this directly use wrappers of TPluginLoader - Load: Func_Load; - Init: Func_Init; - DeInit: Proc_DeInit; - end; - end; - {********************* - TPluginLoader - Class Searches for Plugins and Manages loading and unloading - *********************} - PPluginLoader = ^TPluginLoader; - TPluginLoader = class (TCoreModule) - private - LoadingProcessFinished: Boolean; - sUnloadPlugin: THandle; - sLoadPlugin: THandle; - sGetPluginInfo: THandle; - sGetPluginState: THandle; - - Procedure FreePlugin(Index: Cardinal); - public - PluginInterface: TUS_PluginInterface; - Plugins: Array of TPluginListItem; - - //TCoreModule methods to inherit - Constructor Create; override; - Procedure Info(const pInfo: PModuleInfo); override; - Function Load: Boolean; override; - Function Init: Boolean; override; - Procedure DeInit; override; - Procedure Free; override; - - //New Methods - Procedure BrowseDir(Path: String); //Browses the Path at _Path_ for Plugins - Function PluginExists(Name: String): Integer; //If Plugin Exists: Index of Plugin, else -1 - Procedure AddPlugin(Filename: String);//Adds Plugin to the Array - - Function CallLoad(Index: Cardinal): Integer; - Function CallInit(Index: Cardinal): Integer; - Procedure CallDeInit(Index: Cardinal); - - //Services offered - Function LoadPlugin(wParam, lParam: DWord): integer; //wParam PChar(PluginName/PluginPath) | lParam (if wParam = nil) ID of the Plugin - Function UnloadPlugin(wParam, lParam: DWord): integer; //wParam PChar(PluginName/PluginPath) | lParam (if wParam = nil) ID of the Plugin - Function GetPluginInfo(wParam, lParam: DWord): integer; //If wParam = -1 then (If lParam = nil then get length of Moduleinfo Array. If lparam <> nil then write array of TUS_PluginInfo to address at lparam) Else (Get PluginInfo of Plugin with Index(wParam) to Address at lParam) - Function GetPluginState(wParam, lParam: DWord): integer; //If wParam = -1 then (If lParam = nil then get length of Moduleinfo Array. If lparam <> nil then write array of TUS_PluginInfo to address at lparam) Else (Return PluginInfo of Plugin with Index(wParam)) - - end; - - {********************* - TtehPlugins - Class Represents the Plugins in Module Chain. - It Calls the Plugins Procs and Funcs - *********************} - TtehPlugins = class (TCoreModule) - private - PluginLoader: PPluginLoader; - public - //TCoreModule methods to inherit - Constructor Create; override; - - Procedure Info(const pInfo: PModuleInfo); override; - Function Load: Boolean; override; - Function Init: Boolean; override; - Procedure DeInit; override; - end; - -const - {$IFDEF MSWINDOWS} - PluginFileExtension = '.dll'; - {$ENDIF} - {$IFDEF LINUX} - PluginFileExtension = '.so'; - {$ENDIF} - {$IFDEF DARWIN} - PluginFileExtension = '.dylib'; - {$ENDIF} - -implementation -uses UCore, UPluginInterface, -{$IFDEF MSWINDOWS} - windows, -{$ELSE} - dynlibs, -{$ENDIF} -UMain, SysUtils; - -{********************* - TPluginLoader - Implentation -*********************} - -//------------- -// Function that gives some Infos about the Module to the Core -//------------- -Procedure TPluginLoader.Info(const pInfo: PModuleInfo); -begin - pInfo^.Name := 'TPluginLoader'; - pInfo^.Version := MakeVersion(1,0,0,chr(0)); - pInfo^.Description := 'Searches for Plugins, loads and unloads them'; -end; - -//------------- -// Just the Constructor -//------------- -Constructor TPluginLoader.Create; -begin - //Init PluginInterface - //Using Methods from UPluginInterface - PluginInterface.CreateHookableEvent := CreateHookableEvent; - PluginInterface.DestroyHookableEvent := DestroyHookableEvent; - PluginInterface.NotivyEventHooks := NotivyEventHooks; - PluginInterface.HookEvent := HookEvent; - PluginInterface.UnHookEvent := UnHookEvent; - PluginInterface.EventExists := EventExists; - - PluginInterface.CreateService := CreateService; - PluginInterface.DestroyService := DestroyService; - PluginInterface.CallService := CallService; - PluginInterface.ServiceExists := ServiceExists; - - //UnSet Private Var - LoadingProcessFinished := False; -end; - -//------------- -//Is Called on Loading. -//In this Method only Events and Services should be created -//to offer them to other Modules or Plugins during the Init process -//If False is Returned this will cause a Forced Exit -//------------- -Function TPluginLoader.Load: Boolean; -begin - Result := True; - - Try - //Start Searching for Plugins - BrowseDir(PluginPath); - Except - Result := False; - Core.ReportError(Integer(PChar('Error Browsing and Loading.')), Integer(PChar('TPluginLoader'))); - end; -end; - -//------------- -//Is Called on Init Process -//In this Method you can Hook some Events and Create + Init -//your Classes, Variables etc. -//If False is Returned this will cause a Forced Exit -//------------- -Function TPluginLoader.Init: Boolean; -begin - //Just set Prvate Var to true. - LoadingProcessFinished := True; - Result := True; -end; - -//------------- -//Is Called if this Module has been Inited and there is a Exit. -//Deinit is in backwards Initing Order -//------------- -Procedure TPluginLoader.DeInit; -var - I: Integer; -begin - //Force DeInit - //If some Plugins aren't DeInited for some Reason o0 - For I := 0 to High(Plugins) do - begin - If (Plugins[I].State < 4) then - FreePlugin(I); - end; - - //Nothing to do here. Core will remove the Hooks -end; - -//------------- -//Is Called if this Module will be unloaded and has been created -//Should be used to Free Memory -//------------- -Procedure TPluginLoader.Free; -begin - //Just save some Memory if it wasn't done now.. - SetLength(Plugins, 0); -end; - -//-------------- -// Browses the Path at _Path_ for Plugins -//-------------- -Procedure TPluginLoader.BrowseDir(Path: String); -var - SR: TSearchRec; -begin - //Search for other Dirs to Browse - if FindFirst(Path + '*', faDirectory, SR) = 0 then begin - repeat - if (SR.Name <> '.') and (SR.Name <> '..') then - BrowseDir(Path + Sr.Name + PathDelim); - until FindNext(SR) <> 0; - end; - FindClose(SR); - - //Search for Plugins at Path - if FindFirst(Path + '*' + PluginFileExtension, 0, SR) = 0 then - begin - repeat - AddPlugin(Path + SR.Name); - until FindNext(SR) <> 0; - end; - FindClose(SR); -end; - -//-------------- -// If Plugin Exists: Index of Plugin, else -1 -//-------------- -Function TPluginLoader.PluginExists(Name: String): Integer; -var - I: Integer; -begin - Result := -1; - - If (Length(Name) <= 32 { =>Length(TUS_PluginInfo.Name)}) then - begin - For I := 0 to High(Plugins) do - if (Plugins[I].Info.Name = Name) then - begin //Found the Plugin - Result := I; - Break; - end; - end; -end; - -//-------------- -// Adds Plugin to the Array -//-------------- -Procedure TPluginLoader.AddPlugin(Filename: String); -var - hLib: THandle; - PInfo: Proc_PluginInfo; - Info: TUS_PluginInfo; - PluginID: Integer; -begin - If (FileExists(Filename)) then - begin //Load Libary - hLib := LoadLibrary(PChar(Filename)); - If (hLib <> 0) then - begin //Try to get Address of the Info Proc - PInfo := GetProcAddress (hLib, PChar('USPlugin_Info')); - If (@PInfo <> nil) then - begin - Info.cbSize := SizeOf(TUS_PluginInfo); - - Try //Call Info Proc - PInfo(@Info); - Except - Info.Name := ''; - Core.ReportError(Integer(PChar('Error getting Plugin Info: ' + Filename)), Integer(PChar('TPluginLoader'))); - end; - - //Is Name set ? - If (Trim(Info.Name) <> '') then - begin - PluginID := PluginExists(Info.Name); - - If (PluginID > 0) AND (Plugins[PluginID].State >=4) then - PluginID := -1; - - If (PluginID = -1) then - begin - //Add new item to array - PluginID := Length(Plugins); - SetLength(Plugins, PluginID + 1); - - //Fill with Info: - Plugins[PluginID].Info := Info; - Plugins[PluginID].State := 0; - Plugins[PluginID].Path := Filename; - Plugins[PluginID].NeedsDeInit := False; - Plugins[PluginID].hLib := hLib; - - //Try to get Procs - Plugins[PluginID].Procs.Load := GetProcAddress (hLib, PChar('USPlugin_Load')); - Plugins[PluginID].Procs.Init := GetProcAddress (hLib, PChar('USPlugin_Init')); - Plugins[PluginID].Procs.DeInit := GetProcAddress (hLib, PChar('USPlugin_DeInit')); - - If (@Plugins[PluginID].Procs.Load = nil) OR (@Plugins[PluginID].Procs.Init = nil) OR (@Plugins[PluginID].Procs.DeInit = nil) then - begin - Plugins[PluginID].State := 255; - FreeLibrary(hLib); - Core.ReportError(Integer(PChar('Can''t get Plugin Procs from Libary: "' + Info.Name + '" ' + Filename)), Integer(PChar('TPluginLoader'))); - end; - - //Emulate loading process if this Plugin is loaded to late - If (LoadingProcessFinished) then - begin - CallLoad(PluginID); - CallInit(PluginID); - end; - end - Else If (LoadingProcessFinished = False) then - begin - If (Plugins[PluginID].Info.Version < Info.Version) then - begin //Found newer Version of this Plugin - Core.ReportDebug(Integer(PChar('Found a newer Version of Plugin: ' + String(Info.Name))), Integer(PChar('TPluginLoader'))); - - //Unload Old Plugin - UnloadPlugin(Integer(nil), PluginID); - - //Fill with new Info - Plugins[PluginID].Info := Info; - Plugins[PluginID].State := 0; - Plugins[PluginID].Path := Filename; - Plugins[PluginID].NeedsDeInit := False; - Plugins[PluginID].hLib := hLib; - - //Try to get Procs - Plugins[PluginID].Procs.Load := GetProcAddress (hLib, PChar('USPlugin_Load')); - Plugins[PluginID].Procs.Init := GetProcAddress (hLib, PChar('USPlugin_Init')); - Plugins[PluginID].Procs.DeInit := GetProcAddress (hLib, PChar('USPlugin_DeInit')); - - If (@Plugins[PluginID].Procs.Load = nil) OR (@Plugins[PluginID].Procs.Init = nil) OR (@Plugins[PluginID].Procs.DeInit = nil) then - begin - FreeLibrary(hLib); - Plugins[PluginID].State := 255; - Core.ReportError(Integer(PChar('Can''t get Plugin Procs from Libary: "' + Info.Name + '" ' + Filename)), Integer(PChar('TPluginLoader'))); - end; - end - else - begin //Newer Version already loaded - FreeLibrary(hLib); - end; - end - else - begin - FreeLibrary(hLib); - Core.ReportError(Integer(PChar('Plugin with this Name already exists: ' + String(Info.Name))), Integer(PChar('TPluginLoader'))); - end; - end - else - begin - FreeLibrary(hLib); - Core.ReportError(Integer(PChar('No name reported: ' + Filename)), Integer(PChar('TPluginLoader'))); - end; - end - else - begin - FreeLibrary(hLib); - Core.ReportError(Integer(PChar('Can''t find Info Procedure: ' + Filename)), Integer(PChar('TPluginLoader'))); - end; - end - else - Core.ReportError(Integer(PChar('Can''t load Plugin Libary: ' + Filename)), Integer(PChar('TPluginLoader'))); - end; -end; - -//-------------- -// Calls Load Func of Plugin with the given Index -//-------------- -Function TPluginLoader.CallLoad(Index: Cardinal): Integer; -begin - Result := -2; - If(Index < Length(Plugins)) then - begin - If (@Plugins[Index].Procs.Load <> nil) AND (Plugins[Index].State = 0) then - begin - Try - Result := Plugins[Index].Procs.Load(@PluginInterface); - Except - Result := -3; - End; - - If (Result = 0) then - Plugins[Index].State := 1 - Else - begin - FreePlugin(Index); - Plugins[Index].State := 255; - Core.ReportError(Integer(PChar('Error calling Load Function from Plugin: ' + String(Plugins[Index].Info.Name))), Integer(PChar('TPluginLoader'))); - end; - end; - end; -end; - -//-------------- -// Calls Init Func of Plugin with the given Index -//-------------- -Function TPluginLoader.CallInit(Index: Cardinal): Integer; -begin - Result := -2; - If(Index < Length(Plugins)) then - begin - If (@Plugins[Index].Procs.Init <> nil) AND (Plugins[Index].State = 1) then - begin - Try - Result := Plugins[Index].Procs.Init(@PluginInterface); - Except - Result := -3; - End; - - If (Result = 0) then - begin - Plugins[Index].State := 2; - Plugins[Index].NeedsDeInit := True; - end - Else - begin - FreePlugin(Index); - Plugins[Index].State := 255; - Core.ReportError(Integer(PChar('Error calling Init Function from Plugin: ' + String(Plugins[Index].Info.Name))), Integer(PChar('TPluginLoader'))); - end; - end; - end; -end; - -//-------------- -// Calls DeInit Proc of Plugin with the given Index -//-------------- -Procedure TPluginLoader.CallDeInit(Index: Cardinal); -begin - If(Index < Length(Plugins)) then - begin - If (Plugins[Index].State < 4) then - begin - If (@Plugins[Index].Procs.DeInit <> nil) and (Plugins[Index].NeedsDeInit) then - Try - Plugins[Index].Procs.DeInit(@PluginInterface); - Except - - End; - - //Don't forget to remove Services and Subscriptions by this Plugin - Core.Hooks.DelbyOwner(-1 - Index); - - FreePlugin(Index); - end; - end; -end; - -//-------------- -// Frees all Plugin Sources (Procs and Handles) - Helper for Deiniting Functions -//-------------- -Procedure TPluginLoader.FreePlugin(Index: Cardinal); -begin - Plugins[Index].State := 4; - Plugins[Index].Procs.Load := nil; - Plugins[Index].Procs.Init := nil; - Plugins[Index].Procs.DeInit := nil; - - If (Plugins[Index].hLib <> 0) then - FreeLibrary(Plugins[Index].hLib); -end; - - - -//-------------- -// wParam PChar(PluginName/PluginPath) | lParam (if wParam = nil) ID of the Plugin -//-------------- -Function TPluginLoader.LoadPlugin(wParam, lParam: DWord): integer; -var - Index: Integer; - sFile: String; -begin - Result := -1; - sFile := ''; - //lParam is ID - If (Pointer(wParam) = nil) then - begin - Index := lParam; - end - else - begin //wParam is PChar - try - sFile := String(PChar(Pointer(wParam))); - Index := PluginExists(sFile); - If (Index < 0) And FileExists(sFile) then - begin //Is Filename - AddPlugin(sFile); - Result := Plugins[High(Plugins)].State; - end; - except - Index := -2; - end; - end; - - - If (Index >= 0) and (Index < Length(Plugins)) then - begin - AddPlugin(Plugins[Index].Path); - Result := Plugins[Index].State; - end; -end; - -//-------------- -// wParam PChar(PluginName/PluginPath) | lParam (if wParam = nil) ID of the Plugin -//-------------- -Function TPluginLoader.UnloadPlugin(wParam, lParam: DWord): integer; -var - Index: Integer; - sName: String; -begin - Result := -1; - //lParam is ID - If (Pointer(wParam) = nil) then - begin - Index := lParam; - end - else - begin //wParam is PChar - try - sName := String(PChar(Pointer(wParam))); - Index := PluginExists(sName); - except - Index := -2; - end; - end; - - - If (Index >= 0) and (Index < Length(Plugins)) then - CallDeInit(Index) -end; - -//-------------- -// If wParam = -1 then (If lParam = nil then get length of Moduleinfo Array. If lparam <> nil then write array of TUS_PluginInfo to address at lparam) Else (Get PluginInfo of Plugin with Index(wParam) to Address at lParam) -//-------------- -Function TPluginLoader.GetPluginInfo(wParam, lParam: DWord): integer; -var I: Integer; -begin - Result := 0; - If (wParam < 0) then - begin //Get Info of 1 Plugin - If (Pointer(lParam) <> nil) AND (wParam < Length(Plugins)) then - begin - Try - Result := 1; - PUS_PluginInfo(Pointer(lParam))^ := Plugins[wParam].Info; - Except - - End; - end; - end - Else If (Pointer(lParam) = nil) then - begin //Get Length of Plugin (Info) Array - Result := Length(Plugins); - end - Else //Write PluginInfo Array to Address in lParam - begin - Try - For I := 0 to high(Plugins) do - PAUS_PluginInfo(Pointer(lParam))^[I] := Plugins[I].Info; - Result := Length(Plugins); - Except - Core.ReportError(Integer(PChar('Could not write PluginInfo Array')), Integer(PChar('TPluginLoader'))); - End; - end; - -end; - -//-------------- -// If wParam = -1 then (If lParam = nil then get length of Plugin State Array. If lparam <> nil then write array of Byte to address at lparam) Else (Return State of Plugin with Index(wParam)) -//-------------- -Function TPluginLoader.GetPluginState(wParam, lParam: DWord): integer; -var I: Integer; -begin - Result := -1; - If (wParam < 0) then - begin //Get State of 1 Plugin - If (wParam < Length(Plugins)) then - begin - Result := Plugins[wParam].State; - end; - end - Else If (Pointer(lParam) = nil) then - begin //Get Length of Plugin (Info) Array - Result := Length(Plugins); - end - Else //Write PluginInfo Array to Address in lParam - begin - Try - For I := 0 to high(Plugins) do - Byte(Pointer(lParam + I)^) := Plugins[I].State; - Result := Length(Plugins); - Except - Core.ReportError(Integer(PChar('Could not write PluginState Array')), Integer(PChar('TPluginLoader'))); - End; - end; -end; - - - - - -{********************* - TtehPlugins - Implentation -*********************} - -//------------- -// Function that gives some Infos about the Module to the Core -//------------- -Procedure TtehPlugins.Info(const pInfo: PModuleInfo); -begin - pInfo^.Name := 'TtehPlugins'; - pInfo^.Version := MakeVersion(1,0,0,chr(0)); - pInfo^.Description := 'Module executing the Plugins!'; -end; - -//------------- -// Just the Constructor -//------------- -Constructor TtehPlugins.Create; -begin - PluginLoader := nil; -end; - -//------------- -//Is Called on Loading. -//In this Method only Events and Services should be created -//to offer them to other Modules or Plugins during the Init process -//If False is Returned this will cause a Forced Exit -//------------- -Function TtehPlugins.Load: Boolean; -var - I: Integer; //Counter - CurExecutedBackup: Integer; //backup of Core.CurExecuted Attribute -label Continue; -begin - //Get Pointer to PluginLoader - PluginLoader := PPluginLoader(Core.GetModulebyName('TPluginLoader')); - If (PluginLoader = nil) then - begin - Result := False; - Core.ReportError(Integer(PChar('Could not get Pointer to PluginLoader')), Integer(PChar('TtehPlugins'))); - end - else - begin - Result := True; - - //Backup CurExecuted - CurExecutedBackup := Core.CurExecuted; - - //Start Loading the Plugins - I := 0; - Continue: - Try - While (I <= High(PluginLoader.Plugins)) do - begin - Core.CurExecuted := -1 - I; - - //Unload Plugin if not correctly Executed - If (PluginLoader.CallLoad(I) <> 0) then - begin - PluginLoader.CallDeInit(I); - PluginLoader.Plugins[I].State := 254; //Plugin asks for unload - Core.ReportDebug(Integer(PChar('Plugin Selfabort during loading process: ' + String(PluginLoader.Plugins[I].Info.Name))), Integer(PChar('TtehPlugins'))); - end - else - Core.ReportDebug(Integer(PChar('Plugin loaded succesful: ' + String(PluginLoader.Plugins[I].Info.Name))), Integer(PChar('TtehPlugins'))); - - Inc(I); - end; - Except - //Plugin could not be loaded. - // => Show Error Message, then ShutDown Plugin - on E: Exception do - begin - PluginLoader.CallDeInit(I); - PluginLoader.Plugins[I].State := 255; //Plugin causes Error - Core.ReportError(Integer(PChar('Plugin causes Error during loading process: ' + PluginLoader.Plugins[I].Info.Name + ', ErrorMsg: "' + E.Message + '"')), Integer(PChar('TtehPlugins'))); - - - //don't forget to increase I - Inc(I); - end; - End; - - If (I <= High(PluginLoader.Plugins)) then - Goto Continue; - - //Reset CurExecuted - Core.CurExecuted := CurExecutedBackup; - end; -end; - -//------------- -//Is Called on Init Process -//In this Method you can Hook some Events and Create + Init -//your Classes, Variables etc. -//If False is Returned this will cause a Forced Exit -//------------- -Function TtehPlugins.Init: Boolean; -var - I: Integer; //Counter - CurExecutedBackup: Integer; //backup of Core.CurExecuted Attribute -label Continue; -begin - Result := True; - - //Backup CurExecuted - CurExecutedBackup := Core.CurExecuted; - - //Start Loading the Plugins - I := 0; - Continue: - Try - While (I <= High(PluginLoader.Plugins)) do - begin - Core.CurExecuted := -1 - I; - - //Unload Plugin if not correctly Executed - If (PluginLoader.CallInit(I) <> 0) then - begin - PluginLoader.CallDeInit(I); - PluginLoader.Plugins[I].State := 254; //Plugin asks for unload - Core.ReportDebug(Integer(PChar('Plugin Selfabort during init process: ' + String(PluginLoader.Plugins[I].Info.Name))), Integer(PChar('TtehPlugins'))); - end - else - Core.ReportDebug(Integer(PChar('Plugin inited succesful: ' + String(PluginLoader.Plugins[I].Info.Name))), Integer(PChar('TtehPlugins'))); - - //don't forget to increase I - Inc(I); - end; - Except - //Plugin could not be loaded. - // => Show Error Message, then ShutDown Plugin - PluginLoader.CallDeInit(I); - PluginLoader.Plugins[I].State := 255; //Plugin causes Error - Core.ReportError(Integer(PChar('Plugin causes Error during init process: ' + String(PluginLoader.Plugins[I].Info.Name))), Integer(PChar('TtehPlugins'))); - - //don't forget to increase I - Inc(I); - End; - - If (I <= High(PluginLoader.Plugins)) then - GoTo Continue; - - //Reset CurExecuted - Core.CurExecuted := CurExecutedBackup; -end; - -//------------- -//Is Called if this Module has been Inited and there is a Exit. -//Deinit is in backwards Initing Order -//------------- -Procedure TtehPlugins.DeInit; -var - I: Integer; //Counter - CurExecutedBackup: Integer; //backup of Core.CurExecuted Attribute -label Continue; -begin - //Backup CurExecuted - CurExecutedBackup := Core.CurExecuted; - - //Start Loop - I := 0; - - Continue: - Try - While (I <= High(PluginLoader.Plugins)) do - begin - //DeInit Plugin - PluginLoader.CallDeInit(I); - - Inc(I); - end; - Except - Inc(I); - End; - - If I <= High(PluginLoader.Plugins) then - Goto Continue; - - //Reset CurExecuted - Core.CurExecuted := CurExecutedBackup; -end; - -end. +unit UPluginLoader; +{********************* + UPluginLoader + Unit contains to Classes + TPluginLoader: Class Searching for and Loading the Plugins + TtehPlugins: Class that represents the Plugins in Modules chain +*********************} + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses UPluginDefs, UCoreModule; + +type + TPluginListItem = record + Info: TUS_PluginInfo; + State: Byte; //State of this Plugin: 0 - undefined; 1 - Loaded; 2 - Inited / Running; 4 - Unloaded; 254 - Loading aborted by Plugin; 255 - Unloaded because of Error + Path: String; //Path to this Plugin + NeedsDeInit: Boolean; //If this is Inited correctly this should be true + hLib: THandle; //Handle of Loaded Libary + Procs: record //Procs offered by Plugin. Don't call this directly use wrappers of TPluginLoader + Load: Func_Load; + Init: Func_Init; + DeInit: Proc_DeInit; + end; + end; + {********************* + TPluginLoader + Class Searches for Plugins and Manages loading and unloading + *********************} + PPluginLoader = ^TPluginLoader; + TPluginLoader = class (TCoreModule) + private + LoadingProcessFinished: Boolean; + sUnloadPlugin: THandle; + sLoadPlugin: THandle; + sGetPluginInfo: THandle; + sGetPluginState: THandle; + + Procedure FreePlugin(Index: Cardinal); + public + PluginInterface: TUS_PluginInterface; + Plugins: Array of TPluginListItem; + + //TCoreModule methods to inherit + Constructor Create; override; + Procedure Info(const pInfo: PModuleInfo); override; + Function Load: Boolean; override; + Function Init: Boolean; override; + Procedure DeInit; override; + Procedure Free; override; + + //New Methods + Procedure BrowseDir(Path: String); //Browses the Path at _Path_ for Plugins + Function PluginExists(Name: String): Integer; //If Plugin Exists: Index of Plugin, else -1 + Procedure AddPlugin(Filename: String);//Adds Plugin to the Array + + Function CallLoad(Index: Cardinal): Integer; + Function CallInit(Index: Cardinal): Integer; + Procedure CallDeInit(Index: Cardinal); + + //Services offered + Function LoadPlugin(wParam, lParam: DWord): integer; //wParam PChar(PluginName/PluginPath) | lParam (if wParam = nil) ID of the Plugin + Function UnloadPlugin(wParam, lParam: DWord): integer; //wParam PChar(PluginName/PluginPath) | lParam (if wParam = nil) ID of the Plugin + Function GetPluginInfo(wParam, lParam: DWord): integer; //If wParam = -1 then (If lParam = nil then get length of Moduleinfo Array. If lparam <> nil then write array of TUS_PluginInfo to address at lparam) Else (Get PluginInfo of Plugin with Index(wParam) to Address at lParam) + Function GetPluginState(wParam, lParam: DWord): integer; //If wParam = -1 then (If lParam = nil then get length of Moduleinfo Array. If lparam <> nil then write array of TUS_PluginInfo to address at lparam) Else (Return PluginInfo of Plugin with Index(wParam)) + + end; + + {********************* + TtehPlugins + Class Represents the Plugins in Module Chain. + It Calls the Plugins Procs and Funcs + *********************} + TtehPlugins = class (TCoreModule) + private + PluginLoader: PPluginLoader; + public + //TCoreModule methods to inherit + Constructor Create; override; + + Procedure Info(const pInfo: PModuleInfo); override; + Function Load: Boolean; override; + Function Init: Boolean; override; + Procedure DeInit; override; + end; + +const + {$IFDEF MSWINDOWS} + PluginFileExtension = '.dll'; + {$ENDIF} + {$IFDEF LINUX} + PluginFileExtension = '.so'; + {$ENDIF} + {$IFDEF DARWIN} + PluginFileExtension = '.dylib'; + {$ENDIF} + +implementation +uses UCore, UPluginInterface, +{$IFDEF MSWINDOWS} + windows, +{$ELSE} + dynlibs, +{$ENDIF} +UMain, SysUtils; + +{********************* + TPluginLoader + Implentation +*********************} + +//------------- +// Function that gives some Infos about the Module to the Core +//------------- +Procedure TPluginLoader.Info(const pInfo: PModuleInfo); +begin + pInfo^.Name := 'TPluginLoader'; + pInfo^.Version := MakeVersion(1,0,0,chr(0)); + pInfo^.Description := 'Searches for Plugins, loads and unloads them'; +end; + +//------------- +// Just the Constructor +//------------- +Constructor TPluginLoader.Create; +begin + //Init PluginInterface + //Using Methods from UPluginInterface + PluginInterface.CreateHookableEvent := CreateHookableEvent; + PluginInterface.DestroyHookableEvent := DestroyHookableEvent; + PluginInterface.NotivyEventHooks := NotivyEventHooks; + PluginInterface.HookEvent := HookEvent; + PluginInterface.UnHookEvent := UnHookEvent; + PluginInterface.EventExists := EventExists; + + PluginInterface.CreateService := @CreateService; + PluginInterface.DestroyService := DestroyService; + PluginInterface.CallService := CallService; + PluginInterface.ServiceExists := ServiceExists; + + //UnSet Private Var + LoadingProcessFinished := False; +end; + +//------------- +//Is Called on Loading. +//In this Method only Events and Services should be created +//to offer them to other Modules or Plugins during the Init process +//If False is Returned this will cause a Forced Exit +//------------- +Function TPluginLoader.Load: Boolean; +begin + Result := True; + + Try + //Start Searching for Plugins + BrowseDir(PluginPath); + Except + Result := False; + Core.ReportError(Integer(PChar('Error Browsing and Loading.')), Integer(PChar('TPluginLoader'))); + end; +end; + +//------------- +//Is Called on Init Process +//In this Method you can Hook some Events and Create + Init +//your Classes, Variables etc. +//If False is Returned this will cause a Forced Exit +//------------- +Function TPluginLoader.Init: Boolean; +begin + //Just set Prvate Var to true. + LoadingProcessFinished := True; + Result := True; +end; + +//------------- +//Is Called if this Module has been Inited and there is a Exit. +//Deinit is in backwards Initing Order +//------------- +Procedure TPluginLoader.DeInit; +var + I: Integer; +begin + //Force DeInit + //If some Plugins aren't DeInited for some Reason o0 + For I := 0 to High(Plugins) do + begin + If (Plugins[I].State < 4) then + FreePlugin(I); + end; + + //Nothing to do here. Core will remove the Hooks +end; + +//------------- +//Is Called if this Module will be unloaded and has been created +//Should be used to Free Memory +//------------- +Procedure TPluginLoader.Free; +begin + //Just save some Memory if it wasn't done now.. + SetLength(Plugins, 0); +end; + +//-------------- +// Browses the Path at _Path_ for Plugins +//-------------- +Procedure TPluginLoader.BrowseDir(Path: String); +var + SR: TSearchRec; +begin + //Search for other Dirs to Browse + if FindFirst(Path + '*', faDirectory, SR) = 0 then begin + repeat + if (SR.Name <> '.') and (SR.Name <> '..') then + BrowseDir(Path + Sr.Name + PathDelim); + until FindNext(SR) <> 0; + end; + FindClose(SR); + + //Search for Plugins at Path + if FindFirst(Path + '*' + PluginFileExtension, 0, SR) = 0 then + begin + repeat + AddPlugin(Path + SR.Name); + until FindNext(SR) <> 0; + end; + FindClose(SR); +end; + +//-------------- +// If Plugin Exists: Index of Plugin, else -1 +//-------------- +Function TPluginLoader.PluginExists(Name: String): Integer; +var + I: Integer; +begin + Result := -1; + + If (Length(Name) <= 32 { =>Length(TUS_PluginInfo.Name)}) then + begin + For I := 0 to High(Plugins) do + if (Plugins[I].Info.Name = Name) then + begin //Found the Plugin + Result := I; + Break; + end; + end; +end; + +//-------------- +// Adds Plugin to the Array +//-------------- +Procedure TPluginLoader.AddPlugin(Filename: String); +var + hLib: THandle; + PInfo: Proc_PluginInfo; + Info: TUS_PluginInfo; + PluginID: Integer; +begin + If (FileExists(Filename)) then + begin //Load Libary + hLib := LoadLibrary(PChar(Filename)); + If (hLib <> 0) then + begin //Try to get Address of the Info Proc + PInfo := GetProcAddress (hLib, PChar('USPlugin_Info')); + If (@PInfo <> nil) then + begin + Info.cbSize := SizeOf(TUS_PluginInfo); + + Try //Call Info Proc + PInfo(@Info); + Except + Info.Name := ''; + Core.ReportError(Integer(PChar('Error getting Plugin Info: ' + Filename)), Integer(PChar('TPluginLoader'))); + end; + + //Is Name set ? + If (Trim(Info.Name) <> '') then + begin + PluginID := PluginExists(Info.Name); + + If (PluginID > 0) AND (Plugins[PluginID].State >=4) then + PluginID := -1; + + If (PluginID = -1) then + begin + //Add new item to array + PluginID := Length(Plugins); + SetLength(Plugins, PluginID + 1); + + //Fill with Info: + Plugins[PluginID].Info := Info; + Plugins[PluginID].State := 0; + Plugins[PluginID].Path := Filename; + Plugins[PluginID].NeedsDeInit := False; + Plugins[PluginID].hLib := hLib; + + //Try to get Procs + Plugins[PluginID].Procs.Load := GetProcAddress (hLib, PChar('USPlugin_Load')); + Plugins[PluginID].Procs.Init := GetProcAddress (hLib, PChar('USPlugin_Init')); + Plugins[PluginID].Procs.DeInit := GetProcAddress (hLib, PChar('USPlugin_DeInit')); + + If (@Plugins[PluginID].Procs.Load = nil) OR (@Plugins[PluginID].Procs.Init = nil) OR (@Plugins[PluginID].Procs.DeInit = nil) then + begin + Plugins[PluginID].State := 255; + FreeLibrary(hLib); + Core.ReportError(Integer(PChar('Can''t get Plugin Procs from Libary: "' + Info.Name + '" ' + Filename)), Integer(PChar('TPluginLoader'))); + end; + + //Emulate loading process if this Plugin is loaded to late + If (LoadingProcessFinished) then + begin + CallLoad(PluginID); + CallInit(PluginID); + end; + end + Else If (LoadingProcessFinished = False) then + begin + If (Plugins[PluginID].Info.Version < Info.Version) then + begin //Found newer Version of this Plugin + Core.ReportDebug(Integer(PChar('Found a newer Version of Plugin: ' + String(Info.Name))), Integer(PChar('TPluginLoader'))); + + //Unload Old Plugin + UnloadPlugin(Integer(nil), PluginID); + + //Fill with new Info + Plugins[PluginID].Info := Info; + Plugins[PluginID].State := 0; + Plugins[PluginID].Path := Filename; + Plugins[PluginID].NeedsDeInit := False; + Plugins[PluginID].hLib := hLib; + + //Try to get Procs + Plugins[PluginID].Procs.Load := GetProcAddress (hLib, PChar('USPlugin_Load')); + Plugins[PluginID].Procs.Init := GetProcAddress (hLib, PChar('USPlugin_Init')); + Plugins[PluginID].Procs.DeInit := GetProcAddress (hLib, PChar('USPlugin_DeInit')); + + If (@Plugins[PluginID].Procs.Load = nil) OR (@Plugins[PluginID].Procs.Init = nil) OR (@Plugins[PluginID].Procs.DeInit = nil) then + begin + FreeLibrary(hLib); + Plugins[PluginID].State := 255; + Core.ReportError(Integer(PChar('Can''t get Plugin Procs from Libary: "' + Info.Name + '" ' + Filename)), Integer(PChar('TPluginLoader'))); + end; + end + else + begin //Newer Version already loaded + FreeLibrary(hLib); + end; + end + else + begin + FreeLibrary(hLib); + Core.ReportError(Integer(PChar('Plugin with this Name already exists: ' + String(Info.Name))), Integer(PChar('TPluginLoader'))); + end; + end + else + begin + FreeLibrary(hLib); + Core.ReportError(Integer(PChar('No name reported: ' + Filename)), Integer(PChar('TPluginLoader'))); + end; + end + else + begin + FreeLibrary(hLib); + Core.ReportError(Integer(PChar('Can''t find Info Procedure: ' + Filename)), Integer(PChar('TPluginLoader'))); + end; + end + else + Core.ReportError(Integer(PChar('Can''t load Plugin Libary: ' + Filename)), Integer(PChar('TPluginLoader'))); + end; +end; + +//-------------- +// Calls Load Func of Plugin with the given Index +//-------------- +Function TPluginLoader.CallLoad(Index: Cardinal): Integer; +begin + Result := -2; + If(Index < Length(Plugins)) then + begin + If (@Plugins[Index].Procs.Load <> nil) AND (Plugins[Index].State = 0) then + begin + Try + Result := Plugins[Index].Procs.Load(@PluginInterface); + Except + Result := -3; + End; + + If (Result = 0) then + Plugins[Index].State := 1 + Else + begin + FreePlugin(Index); + Plugins[Index].State := 255; + Core.ReportError(Integer(PChar('Error calling Load Function from Plugin: ' + String(Plugins[Index].Info.Name))), Integer(PChar('TPluginLoader'))); + end; + end; + end; +end; + +//-------------- +// Calls Init Func of Plugin with the given Index +//-------------- +Function TPluginLoader.CallInit(Index: Cardinal): Integer; +begin + Result := -2; + If(Index < Length(Plugins)) then + begin + If (@Plugins[Index].Procs.Init <> nil) AND (Plugins[Index].State = 1) then + begin + Try + Result := Plugins[Index].Procs.Init(@PluginInterface); + Except + Result := -3; + End; + + If (Result = 0) then + begin + Plugins[Index].State := 2; + Plugins[Index].NeedsDeInit := True; + end + Else + begin + FreePlugin(Index); + Plugins[Index].State := 255; + Core.ReportError(Integer(PChar('Error calling Init Function from Plugin: ' + String(Plugins[Index].Info.Name))), Integer(PChar('TPluginLoader'))); + end; + end; + end; +end; + +//-------------- +// Calls DeInit Proc of Plugin with the given Index +//-------------- +Procedure TPluginLoader.CallDeInit(Index: Cardinal); +begin + If(Index < Length(Plugins)) then + begin + If (Plugins[Index].State < 4) then + begin + If (@Plugins[Index].Procs.DeInit <> nil) and (Plugins[Index].NeedsDeInit) then + Try + Plugins[Index].Procs.DeInit(@PluginInterface); + Except + + End; + + //Don't forget to remove Services and Subscriptions by this Plugin + Core.Hooks.DelbyOwner(-1 - Index); + + FreePlugin(Index); + end; + end; +end; + +//-------------- +// Frees all Plugin Sources (Procs and Handles) - Helper for Deiniting Functions +//-------------- +Procedure TPluginLoader.FreePlugin(Index: Cardinal); +begin + Plugins[Index].State := 4; + Plugins[Index].Procs.Load := nil; + Plugins[Index].Procs.Init := nil; + Plugins[Index].Procs.DeInit := nil; + + If (Plugins[Index].hLib <> 0) then + FreeLibrary(Plugins[Index].hLib); +end; + + + +//-------------- +// wParam PChar(PluginName/PluginPath) | lParam (if wParam = nil) ID of the Plugin +//-------------- +Function TPluginLoader.LoadPlugin(wParam, lParam: DWord): integer; +var + Index: Integer; + sFile: String; +begin + Result := -1; + sFile := ''; + //lParam is ID + If (Pointer(wParam) = nil) then + begin + Index := lParam; + end + else + begin //wParam is PChar + try + sFile := String(PChar(Pointer(wParam))); + Index := PluginExists(sFile); + If (Index < 0) And FileExists(sFile) then + begin //Is Filename + AddPlugin(sFile); + Result := Plugins[High(Plugins)].State; + end; + except + Index := -2; + end; + end; + + + If (Index >= 0) and (Index < Length(Plugins)) then + begin + AddPlugin(Plugins[Index].Path); + Result := Plugins[Index].State; + end; +end; + +//-------------- +// wParam PChar(PluginName/PluginPath) | lParam (if wParam = nil) ID of the Plugin +//-------------- +Function TPluginLoader.UnloadPlugin(wParam, lParam: DWord): integer; +var + Index: Integer; + sName: String; +begin + Result := -1; + //lParam is ID + If (Pointer(wParam) = nil) then + begin + Index := lParam; + end + else + begin //wParam is PChar + try + sName := String(PChar(Pointer(wParam))); + Index := PluginExists(sName); + except + Index := -2; + end; + end; + + + If (Index >= 0) and (Index < Length(Plugins)) then + CallDeInit(Index) +end; + +//-------------- +// If wParam = -1 then (If lParam = nil then get length of Moduleinfo Array. If lparam <> nil then write array of TUS_PluginInfo to address at lparam) Else (Get PluginInfo of Plugin with Index(wParam) to Address at lParam) +//-------------- +Function TPluginLoader.GetPluginInfo(wParam, lParam: DWord): integer; +var I: Integer; +begin + Result := 0; + If (wParam < 0) then + begin //Get Info of 1 Plugin + If (Pointer(lParam) <> nil) AND (wParam < Length(Plugins)) then + begin + Try + Result := 1; + PUS_PluginInfo(Pointer(lParam))^ := Plugins[wParam].Info; + Except + + End; + end; + end + Else If (Pointer(lParam) = nil) then + begin //Get Length of Plugin (Info) Array + Result := Length(Plugins); + end + Else //Write PluginInfo Array to Address in lParam + begin + Try + For I := 0 to high(Plugins) do + PAUS_PluginInfo(Pointer(lParam))^[I] := Plugins[I].Info; + Result := Length(Plugins); + Except + Core.ReportError(Integer(PChar('Could not write PluginInfo Array')), Integer(PChar('TPluginLoader'))); + End; + end; + +end; + +//-------------- +// If wParam = -1 then (If lParam = nil then get length of Plugin State Array. If lparam <> nil then write array of Byte to address at lparam) Else (Return State of Plugin with Index(wParam)) +//-------------- +Function TPluginLoader.GetPluginState(wParam, lParam: DWord): integer; +var I: Integer; +begin + Result := -1; + If (wParam < 0) then + begin //Get State of 1 Plugin + If (wParam < Length(Plugins)) then + begin + Result := Plugins[wParam].State; + end; + end + Else If (Pointer(lParam) = nil) then + begin //Get Length of Plugin (Info) Array + Result := Length(Plugins); + end + Else //Write PluginInfo Array to Address in lParam + begin + Try + For I := 0 to high(Plugins) do + Byte(Pointer(lParam + I)^) := Plugins[I].State; + Result := Length(Plugins); + Except + Core.ReportError(Integer(PChar('Could not write PluginState Array')), Integer(PChar('TPluginLoader'))); + End; + end; +end; + + + + + +{********************* + TtehPlugins + Implentation +*********************} + +//------------- +// Function that gives some Infos about the Module to the Core +//------------- +Procedure TtehPlugins.Info(const pInfo: PModuleInfo); +begin + pInfo^.Name := 'TtehPlugins'; + pInfo^.Version := MakeVersion(1,0,0,chr(0)); + pInfo^.Description := 'Module executing the Plugins!'; +end; + +//------------- +// Just the Constructor +//------------- +Constructor TtehPlugins.Create; +begin + PluginLoader := nil; +end; + +//------------- +//Is Called on Loading. +//In this Method only Events and Services should be created +//to offer them to other Modules or Plugins during the Init process +//If False is Returned this will cause a Forced Exit +//------------- +Function TtehPlugins.Load: Boolean; +var + I: Integer; //Counter + CurExecutedBackup: Integer; //backup of Core.CurExecuted Attribute +label Continue; +begin + //Get Pointer to PluginLoader + PluginLoader := PPluginLoader(Core.GetModulebyName('TPluginLoader')); + If (PluginLoader = nil) then + begin + Result := False; + Core.ReportError(Integer(PChar('Could not get Pointer to PluginLoader')), Integer(PChar('TtehPlugins'))); + end + else + begin + Result := True; + + //Backup CurExecuted + CurExecutedBackup := Core.CurExecuted; + + //Start Loading the Plugins + I := 0; + Continue: + Try + While (I <= High(PluginLoader.Plugins)) do + begin + Core.CurExecuted := -1 - I; + + //Unload Plugin if not correctly Executed + If (PluginLoader.CallLoad(I) <> 0) then + begin + PluginLoader.CallDeInit(I); + PluginLoader.Plugins[I].State := 254; //Plugin asks for unload + Core.ReportDebug(Integer(PChar('Plugin Selfabort during loading process: ' + String(PluginLoader.Plugins[I].Info.Name))), Integer(PChar('TtehPlugins'))); + end + else + Core.ReportDebug(Integer(PChar('Plugin loaded succesful: ' + String(PluginLoader.Plugins[I].Info.Name))), Integer(PChar('TtehPlugins'))); + + Inc(I); + end; + Except + //Plugin could not be loaded. + // => Show Error Message, then ShutDown Plugin + on E: Exception do + begin + PluginLoader.CallDeInit(I); + PluginLoader.Plugins[I].State := 255; //Plugin causes Error + Core.ReportError(Integer(PChar('Plugin causes Error during loading process: ' + PluginLoader.Plugins[I].Info.Name + ', ErrorMsg: "' + E.Message + '"')), Integer(PChar('TtehPlugins'))); + + + //don't forget to increase I + Inc(I); + end; + End; + + If (I <= High(PluginLoader.Plugins)) then + Goto Continue; + + //Reset CurExecuted + Core.CurExecuted := CurExecutedBackup; + end; +end; + +//------------- +//Is Called on Init Process +//In this Method you can Hook some Events and Create + Init +//your Classes, Variables etc. +//If False is Returned this will cause a Forced Exit +//------------- +Function TtehPlugins.Init: Boolean; +var + I: Integer; //Counter + CurExecutedBackup: Integer; //backup of Core.CurExecuted Attribute +label Continue; +begin + Result := True; + + //Backup CurExecuted + CurExecutedBackup := Core.CurExecuted; + + //Start Loading the Plugins + I := 0; + Continue: + Try + While (I <= High(PluginLoader.Plugins)) do + begin + Core.CurExecuted := -1 - I; + + //Unload Plugin if not correctly Executed + If (PluginLoader.CallInit(I) <> 0) then + begin + PluginLoader.CallDeInit(I); + PluginLoader.Plugins[I].State := 254; //Plugin asks for unload + Core.ReportDebug(Integer(PChar('Plugin Selfabort during init process: ' + String(PluginLoader.Plugins[I].Info.Name))), Integer(PChar('TtehPlugins'))); + end + else + Core.ReportDebug(Integer(PChar('Plugin inited succesful: ' + String(PluginLoader.Plugins[I].Info.Name))), Integer(PChar('TtehPlugins'))); + + //don't forget to increase I + Inc(I); + end; + Except + //Plugin could not be loaded. + // => Show Error Message, then ShutDown Plugin + PluginLoader.CallDeInit(I); + PluginLoader.Plugins[I].State := 255; //Plugin causes Error + Core.ReportError(Integer(PChar('Plugin causes Error during init process: ' + String(PluginLoader.Plugins[I].Info.Name))), Integer(PChar('TtehPlugins'))); + + //don't forget to increase I + Inc(I); + End; + + If (I <= High(PluginLoader.Plugins)) then + GoTo Continue; + + //Reset CurExecuted + Core.CurExecuted := CurExecutedBackup; +end; + +//------------- +//Is Called if this Module has been Inited and there is a Exit. +//Deinit is in backwards Initing Order +//------------- +Procedure TtehPlugins.DeInit; +var + I: Integer; //Counter + CurExecutedBackup: Integer; //backup of Core.CurExecuted Attribute +label Continue; +begin + //Backup CurExecuted + CurExecutedBackup := Core.CurExecuted; + + //Start Loop + I := 0; + + Continue: + Try + While (I <= High(PluginLoader.Plugins)) do + begin + //DeInit Plugin + PluginLoader.CallDeInit(I); + + Inc(I); + end; + Except + Inc(I); + End; + + If I <= High(PluginLoader.Plugins) then + Goto Continue; + + //Reset CurExecuted + Core.CurExecuted := CurExecutedBackup; +end; + +end. diff --git a/Game/Code/UltraStar.dpr b/Game/Code/UltraStar.dpr index 2e04df9f..6d50fff4 100644 --- a/Game/Code/UltraStar.dpr +++ b/Game/Code/UltraStar.dpr @@ -1,169 +1,182 @@ +{$IFNDEF FPC} // This is here, so linux & MacOS X Versions can simply include the uses + // from the dpr. Saves dupicating the uses clause. program UltraStar; -{$R 'UltraStar.res' 'UltraStar.rc'} -{$I switches.inc} + {$R 'UltraStar.res' 'UltraStar.rc'} + {$I switches.inc} uses - //------------------------------ +{$ENDIF} + + //------------------------------ //Includes - 3rd Party Libraries //------------------------------ - SDL in 'lib\JEDI-SDLv1.0\SDL\Pas\SDL.pas', - moduleloader in 'lib\JEDI-SDLv1.0\SDL\Pas\moduleloader.pas', - sdlutils in 'lib\JEDI-SDLv1.0\SDL\Pas\sdlutils.pas', - sdl_image in 'lib\JEDI-SDLv1.0\SDL_Image\Pas\sdl_image.pas', - OpenGL12 in 'lib\JEDI-SDLv1.0\OpenGL\Pas\OpenGL12.pas', - sdl_ttf in 'lib\JEDI-SDLv1.0\SDL_ttf\Pas\sdl_ttf.pas', - - bass in 'lib\bass\delphi\bass.pas', - - PNGImage in 'lib\PNGImage\PNGImage.pas', - PNGzLib in 'lib\PNGImage\PNGzLib.pas', - pnglang in 'lib\PNGImage\pnglang.pas', - - midiout in 'lib\midi\midiout.pas', - midiin in 'lib\midi\midiin.pas', - CIRCBUF in 'lib\midi\CIRCBUF.PAS', - MidiType in 'lib\midi\MidiType.PAS', - MidiDefs in 'lib\midi\MidiDefs.PAS', - MidiCons in 'lib\midi\MidiCons.PAS', - MidiFile in 'lib\midi\MidiFile.PAS', - Delphmcb in 'lib\midi\Delphmcb.PAS', - - avcodec in 'lib\ffmpeg\avcodec.pas', - avformat in 'lib\ffmpeg\avformat.pas', - avutil in 'lib\ffmpeg\avutil.pas', - rational in 'lib\ffmpeg\rational.pas', - opt in 'lib\ffmpeg\opt.pas', - avio in 'lib\ffmpeg\avio.pas', - - DirWatch in 'lib\other\DirWatch.pas', - - SQLiteTable3 in 'lib\SQLite\SQLiteTable3.pas', - SQLite3 in 'lib\SQLite\SQLite3.pas', + SDL in 'lib\JEDI-SDLv1.0\SDL\Pas\SDL.pas', + moduleloader in 'lib\JEDI-SDLv1.0\SDL\Pas\moduleloader.pas', + sdlutils in 'lib\JEDI-SDLv1.0\SDL\Pas\sdlutils.pas', + sdl_image in 'lib\JEDI-SDLv1.0\SDL_Image\Pas\sdl_image.pas', + OpenGL12 in 'lib\JEDI-SDLv1.0\OpenGL\Pas\OpenGL12.pas', + sdl_ttf in 'lib\JEDI-SDLv1.0\SDL_ttf\Pas\sdl_ttf.pas', + + bass in 'lib\bass\delphi\bass.pas', + + {$ifdef delphi} + midiout in 'lib\midi\midiout.pas', + midiin in 'lib\midi\midiin.pas', + CIRCBUF in 'lib\midi\CIRCBUF.PAS', + MidiType in 'lib\midi\MidiType.PAS', + MidiDefs in 'lib\midi\MidiDefs.PAS', + MidiCons in 'lib\midi\MidiCons.PAS', + MidiFile in 'lib\midi\MidiFile.PAS', + Delphmcb in 'lib\midi\Delphmcb.PAS', + + DirWatch in 'lib\other\DirWatch.pas', + {$endif} + + avcodec in 'lib\ffmpeg\avcodec.pas', + avformat in 'lib\ffmpeg\avformat.pas', + avutil in 'lib\ffmpeg\avutil.pas', + rational in 'lib\ffmpeg\rational.pas', + opt in 'lib\ffmpeg\opt.pas', + avio in 'lib\ffmpeg\avio.pas', + + + SQLiteTable3 in 'lib\SQLite\SQLiteTable3.pas', + SQLite3 in 'lib\SQLite\SQLite3.pas', - //------------------------------ + //------------------------------ //Includes - Menu System //------------------------------ - UDisplay in 'Menu\UDisplay.pas', - UMenu in 'Menu\UMenu.pas', - UMenuStatic in 'Menu\UMenuStatic.pas', - UMenuText in 'Menu\UMenuText.pas', - UMenuButton in 'Menu\UMenuButton.pas', - UMenuInteract in 'Menu\UMenuInteract.pas', - UMenuSelect in 'Menu\UMenuSelect.pas', - UMenuSelectSlide in 'Menu\UMenuSelectSlide.pas', - UDrawTexture in 'Menu\UDrawTexture.pas', - UMenuButtonCollection in 'Menu\UMenuButtonCollection.pas', + UDisplay in 'Menu\UDisplay.pas', + UMenu in 'Menu\UMenu.pas', + UMenuStatic in 'Menu\UMenuStatic.pas', + UMenuText in 'Menu\UMenuText.pas', + UMenuButton in 'Menu\UMenuButton.pas', + UMenuInteract in 'Menu\UMenuInteract.pas', + UMenuSelect in 'Menu\UMenuSelect.pas', + UMenuSelectSlide in 'Menu\UMenuSelectSlide.pas', + UDrawTexture in 'Menu\UDrawTexture.pas', + UMenuButtonCollection in 'Menu\UMenuButtonCollection.pas', - //------------------------------ - //Includes - Classes //------------------------------ - UCommon in 'Classes\UCommon.pas', - UGraphic in 'Classes\UGraphic.pas', - UTexture in 'Classes\UTexture.pas', - ULanguage in 'Classes\ULanguage.pas', - UMain in 'Classes\UMain.pas', - UDraw in 'Classes\UDraw.pas', - URecord in 'Classes\URecord.pas', - UTime in 'Classes\UTime.pas', - TextGL in 'Classes\TextGL.pas', - USongs in 'Classes\USongs.pas', - UIni in 'Classes\UIni.pas', - ULyrics in 'Classes\ULyrics.pas', - ULyrics_bak in 'Classes\ULyrics_bak.pas', - USkins in 'Classes\USkins.pas', - UThemes in 'Classes\UThemes.pas', - ULog in 'Classes\ULog.pas', - UJoystick in 'Classes\UJoystick.pas', - ULCD in 'Classes\ULCD.pas', - ULight in 'Classes\ULight.pas', - UDataBase in 'Classes\UDataBase.pas', - UCovers in 'Classes\UCovers.pas', - UCatCovers in 'Classes\UCatCovers.pas', - UFiles in 'Classes\UFiles.pas', - UGraphicClasses in 'Classes\UGraphicClasses.pas', - UDLLManager in 'Classes\UDLLManager.pas', - UPlaylist in 'Classes\UPlaylist.pas', - UCommandLine in 'Classes\UCommandLine.pas', - UTextClasses in 'Classes\UTextClasses.pas', - USingScores in 'Classes\USingScores.pas', - USingNotes in 'Classes\USingNotes.pas', - - UModules in 'Classes\UModules.pas', //List of Modules to Load - UHooks in 'Classes\UHooks.pas', //Hook Managing - UServices in 'Classes\UServices.pas',//Service Managing - UCore in 'Classes\UCore.pas', //Core, Maybe remove this - UCoreModule in 'Classes\UCoreModule.pas', //^ - UPluginInterface in 'Classes\UPluginInterface.pas', //Interface offered by Core to Plugins - UPluginLoader in 'Classes\UPluginLoader.pas', //New Plugin Loader Module - - UParty in 'Classes\UParty.pas', // to - do : rewrite Party Manager as Module, reomplent ability to offer party Mody by Plugin + //Includes - Classes + //------------------------------ + UCommon in 'Classes\UCommon.pas', + UGraphic in 'Classes\UGraphic.pas', + UTexture in 'Classes\UTexture.pas', + ULanguage in 'Classes\ULanguage.pas', + UMain in 'Classes\UMain.pas', + UDraw in 'Classes\UDraw.pas', + URecord in 'Classes\URecord.pas', + UTime in 'Classes\UTime.pas', + TextGL in 'Classes\TextGL.pas', + USongs in 'Classes\USongs.pas', + UIni in 'Classes\UIni.pas', + ULyrics in 'Classes\ULyrics.pas', + ULyrics_bak in 'Classes\ULyrics_bak.pas', + USkins in 'Classes\USkins.pas', + UThemes in 'Classes\UThemes.pas', + ULog in 'Classes\ULog.pas', + UJoystick in 'Classes\UJoystick.pas', + ULCD in 'Classes\ULCD.pas', + ULight in 'Classes\ULight.pas', + UDataBase in 'Classes\UDataBase.pas', + UCovers in 'Classes\UCovers.pas', + UCatCovers in 'Classes\UCatCovers.pas', + UFiles in 'Classes\UFiles.pas', + UGraphicClasses in 'Classes\UGraphicClasses.pas', + UDLLManager in 'Classes\UDLLManager.pas', + UPlaylist in 'Classes\UPlaylist.pas', + UCommandLine in 'Classes\UCommandLine.pas', + UTextClasses in 'Classes\UTextClasses.pas', + USingScores in 'Classes\USingScores.pas', + USingNotes in 'Classes\USingNotes.pas', + + UModules in 'Classes\UModules.pas', //List of Modules to Load + UHooks in 'Classes\UHooks.pas', //Hook Managing + UServices in 'Classes\UServices.pas', //Service Managing + UCore in 'Classes\UCore.pas', //Core, Maybe remove this + UCoreModule in 'Classes\UCoreModule.pas', //^ + UPluginInterface in 'Classes\UPluginInterface.pas', //Interface offered by Core to Plugins + UPluginLoader in 'Classes\UPluginLoader.pas', //New Plugin Loader Module + + UParty in 'Classes\UParty.pas', // to - do : rewrite Party Manager as Module, reomplent ability to offer party Mody by Plugin + +{$IFDEF FPC} + ulazjpeg in 'Classes\Ulazjpeg.pas', +{$ENDIF} + //------------------------------ //Includes - Media support classes.... // Make sure UMedia always first, then UMedia_dummy //------------------------------ - UMusic in 'Classes\UMusic.pas', - UMedia_dummy in 'Classes\UMedia_dummy.pas', - UVideo in 'Classes\UVideo.pas', -// UAudio_FFMpeg in 'Classes\UAudio_FFMpeg.pas', // this is NEARLY to a working point :P - UAudio_Bass in 'Classes\UAudio_Bass.pas', + UMusic in 'Classes\UMusic.pas', + UMedia_dummy in 'Classes\UMedia_dummy.pas', + UVideo in 'Classes\UVideo.pas', +{$ifdef linux} + UAudio_FFMpeg in 'Classes\UAudio_FFMpeg.pas', +{$endif} +{$ifdef win32} + UAudio_bass in 'Classes\UAudio_bass.pas', +{$endif} - //------------------------------ - //Includes - Screens //------------------------------ - UScreenLoading in 'Screens\UScreenLoading.pas', - UScreenWelcome in 'Screens\UScreenWelcome.pas', - UScreenMain in 'Screens\UScreenMain.pas', - UScreenName in 'Screens\UScreenName.pas', - UScreenLevel in 'Screens\UScreenLevel.pas', - UScreenSong in 'Screens\UScreenSong.pas', - UScreenSing in 'Screens\UScreenSing.pas', - UScreenScore in 'Screens\UScreenScore.pas', - UScreenOptions in 'Screens\UScreenOptions.pas', - UScreenOptionsGame in 'Screens\UScreenOptionsGame.pas', - UScreenOptionsGraphics in 'Screens\UScreenOptionsGraphics.pas', - UScreenOptionsSound in 'Screens\UScreenOptionsSound.pas', - UScreenOptionsLyrics in 'Screens\UScreenOptionsLyrics.pas', - UScreenOptionsThemes in 'Screens\UScreenOptionsThemes.pas', - UScreenOptionsRecord in 'Screens\UScreenOptionsRecord.pas', - UScreenOptionsAdvanced in 'Screens\UScreenOptionsAdvanced.pas', - UScreenEditSub in 'Screens\UScreenEditSub.pas', - UScreenEdit in 'Screens\UScreenEdit.pas', - UScreenEditConvert in 'Screens\UScreenEditConvert.pas', - UScreenEditHeader in 'Screens\UScreenEditHeader.pas', - UScreenOpen in 'Screens\UScreenOpen.pas', - UScreenTop5 in 'Screens\UScreenTop5.pas', - UScreenSongMenu in 'Screens\UScreenSongMenu.pas', - UScreenSongJumpto in 'Screens\UScreenSongJumpto.pas', - UScreenStatMain in 'Screens\UScreenStatMain.pas', - UScreenStatDetail in 'Screens\UScreenStatDetail.pas', - UScreenCredits in 'Screens\UScreenCredits.pas', - UScreenPopup in 'Screens\UScreenPopup.pas', + //Includes - Screens + //------------------------------ + UScreenLoading in 'Screens\UScreenLoading.pas', + UScreenWelcome in 'Screens\UScreenWelcome.pas', + UScreenMain in 'Screens\UScreenMain.pas', + UScreenName in 'Screens\UScreenName.pas', + UScreenLevel in 'Screens\UScreenLevel.pas', + UScreenSong in 'Screens\UScreenSong.pas', + UScreenSing in 'Screens\UScreenSing.pas', + UScreenScore in 'Screens\UScreenScore.pas', + UScreenOptions in 'Screens\UScreenOptions.pas', + UScreenOptionsGame in 'Screens\UScreenOptionsGame.pas', + UScreenOptionsGraphics in 'Screens\UScreenOptionsGraphics.pas', + UScreenOptionsSound in 'Screens\UScreenOptionsSound.pas', + UScreenOptionsLyrics in 'Screens\UScreenOptionsLyrics.pas', + UScreenOptionsThemes in 'Screens\UScreenOptionsThemes.pas', + UScreenOptionsRecord in 'Screens\UScreenOptionsRecord.pas', + UScreenOptionsAdvanced in 'Screens\UScreenOptionsAdvanced.pas', + UScreenEditSub in 'Screens\UScreenEditSub.pas', + UScreenEdit in 'Screens\UScreenEdit.pas', + UScreenEditConvert in 'Screens\UScreenEditConvert.pas', + UScreenEditHeader in 'Screens\UScreenEditHeader.pas', + UScreenOpen in 'Screens\UScreenOpen.pas', + UScreenTop5 in 'Screens\UScreenTop5.pas', + UScreenSongMenu in 'Screens\UScreenSongMenu.pas', + UScreenSongJumpto in 'Screens\UScreenSongJumpto.pas', + UScreenStatMain in 'Screens\UScreenStatMain.pas', + UScreenStatDetail in 'Screens\UScreenStatDetail.pas', + UScreenCredits in 'Screens\UScreenCredits.pas', + UScreenPopup in 'Screens\UScreenPopup.pas', - //------------------------------ //Includes - Screens PartyMode - //------------------------------ - UScreenSingModi in 'Screens\UScreenSingModi.pas', - UScreenPartyNewRound in 'Screens\UScreenPartyNewRound.pas', - UScreenPartyScore in 'Screens\UScreenPartyScore.pas', - UScreenPartyPlayer in 'Screens\UScreenPartyPlayer.pas', - UScreenPartyOptions in 'Screens\UScreenPartyOptions.pas', - UScreenPartyWin in 'Screens\UScreenPartyWin.pas', + UScreenSingModi in 'Screens\UScreenSingModi.pas', + UScreenPartyNewRound in 'Screens\UScreenPartyNewRound.pas', + UScreenPartyScore in 'Screens\UScreenPartyScore.pas', + UScreenPartyPlayer in 'Screens\UScreenPartyPlayer.pas', + UScreenPartyOptions in 'Screens\UScreenPartyOptions.pas', + UScreenPartyWin in 'Screens\UScreenPartyWin.pas', + //------------------------------ //Includes - Modi SDK //------------------------------ - ModiSDK in '..\..\Modis\SDK\ModiSDK.pas', //Old SDK, will be deleted soon - UPluginDefs in '..\..\Modis\SDK\UPluginDefs.pas', //New SDK, not only Modis - UPartyDefs in '..\..\Modis\SDK\UPartyDefs.pas', //Headers to register Party Modes + ModiSDK in '..\..\Modis\SDK\ModiSDK.pas', //Old SDK, will be deleted soon + UPluginDefs in '..\..\Modis\SDK\UPluginDefs.pas', //New SDK, not only Modis + UPartyDefs in '..\..\Modis\SDK\UPartyDefs.pas', //Headers to register Party Modes Windows, SysUtils; - - // eddie: I had to move the main procedure to UMain.pas, because - // I can't use the dpr file with Xcode on the mac. +const + Version = 'UltraStar Deluxe V 1.10 Alpha Build'; + +{$IFNDEF FPC} begin Main; -end. \ No newline at end of file +end. +{$ENDIF} \ No newline at end of file diff --git a/Game/Code/UltraStar.lpr b/Game/Code/UltraStar.lpr index dc8fb781..01cd7f87 100644 --- a/Game/Code/UltraStar.lpr +++ b/Game/Code/UltraStar.lpr @@ -1,221 +1,36 @@ -program UltraStar; - -{$DEFINE TRANSLATE} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ELSE} - {$R 'UltraStar.res' 'UltraStar.rc'} -{$ENDIF} - -{$I switches.inc} - -uses - {$ifdef unix} // http://wiki.lazarus.freepascal.org/Multithreaded_Application_Tutorial - cthreads, // THIS MUST be the first used unit !! - {$endif} - - syscall, - - // *************************************************************************** - // - // Developers PLEASE NOTE !!!!!!! - // - // As of september 2007, I am working towards porting Ultrastar-DX to run - // on Linux. I will be modifiying the source to make it compile in lazarus - // on windows & linux and I will make sure that it compiles in delphi still - // To help me in this endevour, please can you make a point of remembering - // that linux is CASE SENSATIVE, and file / unit names must be as per - // the filename exactly. - // - // EG : opengl12.pas must not be OpenGL in the uses cluase. - // - // thanks for your help... - // - // *************************************************************************** - - // Interesting stuff... :) - // http://burningsmell.org/sdl_audioin/ - - - //------------------------------ - //Includes - 3rd Party Libraries - //------------------------------ - - // SDL / OpenGL - moduleloader in 'lib\JEDI-SDLv1.0\SDL\Pas\moduleloader.pas', - opengl12 in 'lib\JEDI-SDLv1.0\OpenGL\Pas\opengl12.pas', - sdl in 'lib\JEDI-SDLv1.0\SDL\Pas\sdl.pas', - sdl_image in 'lib\JEDI-SDLv1.0\SDL_Image\Pas\sdl_image.pas', - sdl_ttf in 'lib\JEDI-SDLv1.0\SDL_ttf\Pas\sdl_ttf.pas', - sdlutils in 'lib\JEDI-SDLv1.0\SDL\Pas\sdlutils.pas', - - - // Bass - {$IFDEF UseBASS} - bass in 'lib\bass\delphi\bass.pas', - {$ENDIF} - - // Midi Units - {$IFDEF UseMIDIPort} - Circbuf in 'lib\midi\CIRCBUF.PAS', - Delphmcb in 'lib\midi\Delphmcb.PAS', - MidiCons in 'lib\midi\MidiCons.PAS', - MidiDefs in 'lib\midi\MidiDefs.PAS', - MidiFile in 'lib\midi\MidiFile.PAS', - midiin in 'lib\midi\midiin.pas', - midiout in 'lib\midi\midiout.pas', - MidiType in 'lib\midi\MidiType.PAS', - {$ENDIF} - - // FFMpeg units - avcodec in 'lib\ffmpeg\avcodec.pas', - avformat in 'lib\ffmpeg\avformat.pas', - avio in 'lib\ffmpeg\avio.pas', - avutil in 'lib\ffmpeg\avutil.pas', - opt in 'lib\ffmpeg\opt.pas', - rational in 'lib\ffmpeg\rational.pas', - - - // Sql Lite - SQLiteTable3 in 'lib\SQLite\SQLiteTable3.pas', - SQLite3 in 'lib\SQLite\SQLite3.pas', - - - //------------------------------ - //Includes - Menu System - //------------------------------ - - UDisplay in 'Menu\UDisplay.pas', - UDrawTexture in 'Menu\UDrawTexture.pas', - UMenu in 'Menu\UMenu.pas', - UMenuButton in 'Menu\UMenuButton.pas', - UMenuButtonCollection in 'Menu\UMenuButtonCollection.pas', - UMenuInteract in 'Menu\UMenuInteract.pas', - UMenuSelect in 'Menu\UMenuSelect.pas', - UMenuSelectSlide in 'Menu\UMenuSelectSlide.pas', - UMenuStatic in 'Menu\UMenuStatic.pas', - UMenuText in 'Menu\UMenuText.pas', - - //------------------------------ - //Includes - Classes - //------------------------------ - - {$IFDEF FPC} - ulazjpeg in 'Classes\Ulazjpeg.pas', - {$ENDIF} - - TextGL in 'Classes\TextGL.pas', - UCatCovers in 'Classes\UCatCovers.pas', - UCommandLine in 'Classes\UCommandLine.pas', - UCommon in 'Classes\UCommon.pas', - UCovers in 'Classes\UCovers.pas', - UDataBase in 'Classes\UDataBase.pas', - UDLLManager in 'Classes\UDLLManager.pas', - UDraw in 'Classes\UDraw.pas', - UFiles in 'Classes\UFiles.pas', - UGraphic in 'Classes\UGraphic.pas', - UGraphicClasses in 'Classes\UGraphicClasses.pas', - UIni in 'Classes\UIni.pas', - UJoystick in 'Classes\UJoystick.pas', - ULanguage in 'Classes\ULanguage.pas', - ULCD in 'Classes\ULCD.pas', - ULight in 'Classes\ULight.pas', - ULog in 'Classes\ULog.pas', - ULyrics in 'Classes\ULyrics.pas', - ULyrics_bak in 'Classes\ULyrics_bak.pas', - UMain in 'Classes\UMain.pas', - - - UMusic in 'Classes\UMusic.pas', - - UMedia_dummy in 'Classes\UMedia_dummy.pas', - UVideo in 'Classes\UVideo.pas', - UAudio_FFMpeg in 'Classes\UAudio_FFMpeg.pas', -{$ifdef win32} - UAudio_bass in 'Classes\UAudio_bass.pas', -{$endif} - -// UAudio_fmod in 'Classes\UAudio_fmod.pas', // this has not yet been developed.. :( - - UParty in 'Classes\UParty.pas', - UPlaylist in 'Classes\UPlaylist.pas', - URecord in 'Classes\URecord.pas', - USkins in 'Classes\USkins.pas', - USingScores in 'Classes\USingScores.pas', - USongs in 'Classes\USongs.pas', - UTexture in 'Classes\UTexture.pas', - UThemes in 'Classes\UThemes.pas', - UTime in 'Classes\UTime.pas', - USingNotes in 'Classes\USingNotes.pas', - - uPluginLoader in 'Classes\uPluginLoader.pas', - UCoreModule in 'Classes\UCoreModule.pas', - UServices in 'Classes\UServices.pas', - UCore in 'Classes\UCore.pas', - UHooks in 'Classes\UHooks.pas', - - - - //------------------------------ - //Includes - Screens - //------------------------------ - UScreenCredits in 'Screens\UScreenCredits.pas', - UScreenEdit in 'Screens\UScreenEdit.pas', - UScreenEditConvert in 'Screens\UScreenEditConvert.pas', - UScreenEditHeader in 'Screens\UScreenEditHeader.pas', - UScreenEditSub in 'Screens\UScreenEditSub.pas', - UScreenLevel in 'Screens\UScreenLevel.pas', - UScreenLoading in 'Screens\UScreenLoading.pas', - UScreenMain in 'Screens\UScreenMain.pas', - UScreenName in 'Screens\UScreenName.pas', - UScreenOpen in 'Screens\UScreenOpen.pas', - UScreenOptions in 'Screens\UScreenOptions.pas', - UScreenOptionsAdvanced in 'Screens\UScreenOptionsAdvanced.pas', - UScreenOptionsGame in 'Screens\UScreenOptionsGame.pas', - UScreenOptionsGraphics in 'Screens\UScreenOptionsGraphics.pas', - UScreenOptionsLyrics in 'Screens\UScreenOptionsLyrics.pas', - UScreenOptionsRecord in 'Screens\UScreenOptionsRecord.pas', - UScreenOptionsSound in 'Screens\UScreenOptionsSound.pas', - UScreenOptionsThemes in 'Screens\UScreenOptionsThemes.pas', - UScreenPopup in 'Screens\UScreenPopup.pas', - UScreenScore in 'Screens\UScreenScore.pas', - UScreenSing in 'Screens\UScreenSing.pas', - UScreenSong in 'Screens\UScreenSong.pas', - UScreenSongJumpto in 'Screens\UScreenSongJumpto.pas', - UScreenSongMenu in 'Screens\UScreenSongMenu.pas', - UScreenStatDetail in 'Screens\UScreenStatDetail.pas', - UScreenStatMain in 'Screens\UScreenStatMain.pas', - UScreenTop5 in 'Screens\UScreenTop5.pas', - UScreenWelcome in 'Screens\UScreenWelcome.pas', - - //------------------------------ - //Includes - Screens PartyMode - //------------------------------ - UScreenPartyNewRound in 'Screens\UScreenPartyNewRound.pas', - UScreenPartyOptions in 'Screens\UScreenPartyOptions.pas', - UScreenPartyPlayer in 'Screens\UScreenPartyPlayer.pas', - UScreenPartyScore in 'Screens\UScreenPartyScore.pas', - UScreenPartyWin in 'Screens\UScreenPartyWin.pas', - UScreenSingModi in 'Screens\UScreenSingModi.pas', - - //------------------------------ - //Includes - Modi SDK - //------------------------------ - ModiSDK in '..\..\Modis\SDK\ModiSDK.pas', - UPluginDefs in '..\..\Modis\SDK\UPluginDefs.pas', - - //------------------------------ - //Includes - Delphi - //------------------------------ - {$IFDEF win32} - Windows, - {$ENDIF} - SysUtils; - -const - Version = 'UltraStar Deluxe V 1.10 Alpha Build'; - -begin - main(); -end. +program UltraStar; + +{$DEFINE TRANSLATE} +{$MODE DELPHI} +{$I switches.inc} + +uses + {$ifdef unix} // http://wiki.lazarus.freepascal.org/Multithreaded_Application_Tutorial + cthreads, // THIS MUST be the first used unit !! + {$endif} + + // *************************************************************************** + // + // Developers PLEASE NOTE !!!!!!! + // + // As of september 2007, I am working towards porting Ultrastar-DX to run + // on Linux. I will be modifiying the source to make it compile in lazarus + // on windows & linux and I will make sure that it compiles in delphi still + // To help me in this endevour, please can you make a point of remembering + // that linux is CASE SENSATIVE, and file / unit names must be as per + // the filename exactly. + // + // EG : opengl12.pas must not be OpenGL in the uses cluase. + // + // thanks for your help... + // + // *************************************************************************** + + // Interesting stuff... :) + // http://burningsmell.org/sdl_audioin/ + + {$I UltraStar.dpr} + +begin + main(); +end. diff --git a/Game/Code/switches.inc b/Game/Code/switches.inc index 1958471b..a5ec9994 100644 --- a/Game/Code/switches.inc +++ b/Game/Code/switches.inc @@ -1,44 +1,45 @@ -{$DEFINE DEBUG} // to-do : Remove b4 release - -// Comment by eddie: -// The mac port currently also uses the WIN32 define. -// Once I get the beast compiled, linked and running -// I will change this. -// There are some parts where the WIN32 define could not -// be used. I changed the WIN32 to MSWINDOWS. -// So, for Windows-only code use the MSWINDOWS define. - - -{$IFDEF FPC} - {$IFDEF DARWIN} - {$H+} - {$R-} - {$DEFINE WIN32} - {$DEFINE TRANSLATE} - {$ELSE} - {$DEFINE LAZARUS} - {$ENDIF} - -// {$MODE DELPHI} // JB - This is not allowed by the free pascal compiler for some reason ( At least on linux ) - - {$DEFINE DLL_CDECL} - {$UNDEF UseSerialPort} - {$UNDEF UseMIDIPort} -{$ELSE} - {$DEFINE DLL_STDCALL} - {$UNDEF UseSerialPort} - {$DEFINE UseMIDIPort} -{$ENDIF} - - -{$IFDEF win32} - {$DEFINE UseBASS} - {$IFDEF DEBUG} - {$IFNDEF DARWIN} - {$APPTYPE CONSOLE} - {$ENDIF} - {$ENDIF} -{$ELSE} - {$UNDEF UseBASS} -{$ENDIF} - +{$DEFINE DEBUG} // to-do : Remove b4 release + +// Comment by eddie: +// The mac port currently also uses the WIN32 define. +// Once I get the beast compiled, linked and running +// I will change this. +// There are some parts where the WIN32 define could not +// be used. I changed the WIN32 to MSWINDOWS. +// So, for Windows-only code use the MSWINDOWS define. + + +{$IFDEF FPC} + {$IFDEF DARWIN} + {$H+} + {$R-} + {$DEFINE WIN32} + {$DEFINE TRANSLATE} + {$ELSE} + {$DEFINE LAZARUS} + {$ENDIF} + +// {$MODE DELPHI} // JB - This is not allowed by the free pascal compiler for some reason ( At least on linux ) + + {$DEFINE DLL_CDECL} + {$UNDEF UseSerialPort} + {$UNDEF UseMIDIPort} +{$ELSE} + {$DEFINE Delphi} + {$DEFINE DLL_STDCALL} + {$UNDEF UseSerialPort} + {$DEFINE UseMIDIPort} +{$ENDIF} + + +{$IFDEF win32} + {$DEFINE UseBASS} + {$IFDEF DEBUG} + {$IFNDEF DARWIN} + {$APPTYPE CONSOLE} + {$ENDIF} + {$ENDIF} +{$ELSE} + {$UNDEF UseBASS} +{$ENDIF} + diff --git a/Modis/SDK/ModiSDK.pas b/Modis/SDK/ModiSDK.pas index 4423502c..7cc3ef1a 100644 --- a/Modis/SDK/ModiSDK.pas +++ b/Modis/SDK/ModiSDK.pas @@ -2,6 +2,10 @@ unit ModiSDK; interface +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + {$I switches.inc} type //PluginInfo, for Init diff --git a/Modis/SDK/UPartyDefs.pas b/Modis/SDK/UPartyDefs.pas index bbe933c6..78b04bdd 100644 --- a/Modis/SDK/UPartyDefs.pas +++ b/Modis/SDK/UPartyDefs.pas @@ -7,6 +7,10 @@ unit UPartyDefs; interface +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + {$I switches.inc} uses UPluginDefs; diff --git a/Modis/SDK/UPluginDefs.pas b/Modis/SDK/UPluginDefs.pas index 4e1ea36b..f0a68fa9 100644 --- a/Modis/SDK/UPluginDefs.pas +++ b/Modis/SDK/UPluginDefs.pas @@ -7,6 +7,10 @@ unit uPluginDefs; interface +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + {$I switches.inc} type -- cgit v1.2.3