aboutsummaryrefslogtreecommitdiffstats
path: root/Game/Code/Classes
diff options
context:
space:
mode:
Diffstat (limited to 'Game/Code/Classes')
-rw-r--r--Game/Code/Classes/UCommon.pas603
-rw-r--r--Game/Code/Classes/UCore.pas1002
-rw-r--r--Game/Code/Classes/USongs.pas2088
-rw-r--r--Game/Code/Classes/UTexture.pas2286
-rw-r--r--Game/Code/Classes/uPluginLoader.pas1602
5 files changed, 3791 insertions, 3790 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.