diff options
Diffstat (limited to '')
185 files changed, 35208 insertions, 10743 deletions
diff --git a/cmake/src/.gitignore b/cmake/src/.gitignore new file mode 100644 index 00000000..1c20f512 --- /dev/null +++ b/cmake/src/.gitignore @@ -0,0 +1,8 @@ +*.cfg
+*.local
+*.bdsproj
+*.identcache
+clean.bat
+config-linux.inc
+paths.inc
+ultrastardx-*.lp[i|s]
diff --git a/cmake/src/base/TextGL.pas b/cmake/src/base/TextGL.pas index c8de4e28..c354a500 100644 --- a/cmake/src/base/TextGL.pas +++ b/cmake/src/base/TextGL.pas @@ -33,304 +33,189 @@ interface {$I switches.inc} -// as long as the transition to freetype is not finished -// use the old implementation -{$IFDEF UseFreetype} - {$INCLUDE TextGLFreetype.pas} -{$ELSE} uses gl, + glext, SDL, + Classes, UTexture, + UFont, + UPath, ULog; -procedure BuildFont; // build our bitmap font -procedure KillFont; // delete the font -function glTextWidth(const text: string): real; // returns text width -procedure glPrint(const text: string); // custom GL "Print" routine +type + PGLFont = ^TGLFont; + TGLFont = record + Font: TScalableFont; + Outlined: boolean; + X, Y, Z: real; + end; + +const + ftNormal = 0; + ftBold = 1; + ftOutline1 = 2; + ftOutline2 = 3; + +var + Fonts: array of TGLFont; + ActFont: integer; + +procedure BuildFonts; // builds all fonts +procedure KillFonts; // deletes all font +function glTextWidth(const text: UTF8String): real; // returns text width +procedure glPrint(const text: UTF8String); // custom GL "Print" routine procedure ResetFont(); // reset font settings of active font procedure SetFontPos(X, Y: real); // sets X and Y procedure SetFontZ(Z: real); // sets Z procedure SetFontSize(Size: real); procedure SetFontStyle(Style: integer); // sets active font style (normal, bold, etc) procedure SetFontItalic(Enable: boolean); // sets italic type letter (works for all fonts) -procedure SetFontAspectW(Aspect: real); procedure SetFontReflection(Enable:boolean;Spacing: real); // enables/disables text reflection -//function NextPowerOfTwo(Value: integer): integer; -// Checks if the ttf exists, if yes then a SDL_ttf is returned -//function LoadFont(FileName: PAnsiChar; PointSize: integer):PTTF_Font; -// Does the renderstuff, color is in $ffeecc style -//function RenderText(font: PTTF_Font; Text:PAnsiChar; Color: Cardinal):PSDL_Surface; - -type - TTextGL = record - X: real; - Y: real; - Z: real; - Text: string; - Size: real; - ColR: real; - ColG: real; - ColB: real; - end; - - PFont = ^TFont; - TFont = record - Tex: TTexture; - Width: array[0..255] of byte; - AspectW: real; - Centered: boolean; - Outline: real; - Italic: boolean; - Reflection: boolean; - ReflectionSpacing: real; - end; - - -var - Fonts: array of TFont; - ActFont: integer; - - implementation uses - Classes, + UTextEncoding, SysUtils, IniFiles, UCommon, - UGraphic, UMain, - UPath; - -var - // Colours for the reflection - TempColor: array[0..3] of GLfloat; + UPathUtils; {** - * Load font info. - * FontFile is the name of the image (.png) not the data (.dat) file + * Returns either Filename if it is absolute or a path relative to FontPath. *} -procedure LoadFontInfo(FontID: integer; const FontFile: string); -var - Stream: TFileStream; - DatFile: string; +function FindFontFile(const Filename: string): IPath; begin - DatFile := ChangeFileExt(FontFile, '.dat'); - FillChar(Fonts[FontID].Width[0], Length(Fonts[FontID].Width), 0); + Result := FontPath.Append(Filename); + // if path does not exist, try as an absolute path + if (not Result.IsFile) then + Result := Path(Filename); +end; - Stream := nil; - try - Stream := TFileStream.Create(DatFile, fmOpenRead); - Stream.Read(Fonts[FontID].Width, 256); - except - Log.LogError('Error while reading font['+ inttostr(FontID) +']', 'LoadFontInfo'); +procedure AddFontFallbacks(FontIni: TMemIniFile; Font: TFont); +var + FallbackFont: IPath; + IdentName: string; + I: Integer; +begin + // evaluate the ini-file's 'Fallbacks' section + for I := 1 to 10 do + begin + IdentName := 'File' + IntToStr(I); + FallbackFont := FindFontFile(FontIni.ReadString('Fallbacks', IdentName, '')); + if (FallbackFont.Equals(PATH_NONE)) then + Continue; + try + Font.AddFallback(FallbackFont); + except + on E: EFontError do + Log.LogError('Setting font fallback ''' + FallbackFont.ToNative() + ''' failed: ' + E.Message); + end; end; - Stream.Free; end; -// Builds bitmap fonts -procedure BuildFont; +const + FONT_NAMES: array [0..3] of string = ( + 'Normal', 'Bold', 'Outline1', 'Outline2' + ); + +procedure BuildFonts; var - Count: integer; + I: integer; FontIni: TMemIniFile; - FontFile: string; // filename of the image (with .png/... ending) + FontFile: IPath; + Outline: single; + Embolden: single; + OutlineFont: TFTScalableOutlineFont; + SectionName: string; begin ActFont := 0; - SetLength(Fonts, 4); - FontIni := TMemIniFile.Create(FontPath + 'fonts.ini'); - - // Normal - - FontFile := FontPath + FontIni.ReadString('Normal', 'File', ''); - - Fonts[0].Tex := Texture.LoadTexture(true, FontFile, TEXTURE_TYPE_TRANSPARENT, 0); - Fonts[0].Tex.H := 30; - Fonts[0].AspectW := 0.9; - Fonts[0].Outline := 0; - - LoadFontInfo(0, FontFile); - - // Bold - - FontFile := FontPath + FontIni.ReadString('Bold', 'File', ''); - - Fonts[1].Tex := Texture.LoadTexture(true, FontFile, TEXTURE_TYPE_TRANSPARENT, 0); - Fonts[1].Tex.H := 30; - Fonts[1].AspectW := 1; - Fonts[1].Outline := 0; - - LoadFontInfo(1, FontFile); - for Count := 0 to 255 do - Fonts[1].Width[Count] := Fonts[1].Width[Count] div 2; - - // Outline1 - - FontFile := FontPath + FontIni.ReadString('Outline1', 'File', ''); - - Fonts[2].Tex := Texture.LoadTexture(true, FontFile, TEXTURE_TYPE_TRANSPARENT, 0); - Fonts[2].Tex.H := 30; - Fonts[2].AspectW := 0.95; - Fonts[2].Outline := 5; - - LoadFontInfo(2, FontFile); - for Count := 0 to 255 do - Fonts[2].Width[Count] := Fonts[2].Width[Count] div 2 + 2; - - // Outline2 + SetLength(Fonts, Length(FONT_NAMES)); - FontFile := FontPath + FontIni.ReadString('Outline2', 'File', ''); - - Fonts[3].Tex := Texture.LoadTexture(true, FontFile, TEXTURE_TYPE_TRANSPARENT, 0); - Fonts[3].Tex.H := 30; - Fonts[3].AspectW := 0.95; - Fonts[3].Outline := 4; - - LoadFontInfo(3, FontFile); - for Count := 0 to 255 do - Fonts[3].Width[Count] := Fonts[3].Width[Count] + 1; + FontIni := TMemIniFile.Create(FontPath.Append('fonts.ini').ToNative); + try + for I := 0 to High(FONT_NAMES) do + begin + SectionName := 'Font_'+FONT_NAMES[I]; + + FontFile := FindFontFile(FontIni.ReadString(SectionName , 'File', '')); + + // create either outlined or normal font + Outline := FontIni.ReadFloat(SectionName, 'Outline', 0.0); + if (Outline > 0.0) then + begin + // outlined font + OutlineFont := TFTScalableOutlineFont.Create(FontFile, 64, Outline); + OutlineFont.SetOutlineColor( + FontIni.ReadFloat(SectionName, 'OutlineColorR', 0.0), + FontIni.ReadFloat(SectionName, 'OutlineColorG', 0.0), + FontIni.ReadFloat(SectionName, 'OutlineColorB', 0.0), + FontIni.ReadFloat(SectionName, 'OutlineColorA', -1.0) + ); + Fonts[I].Font := OutlineFont; + Fonts[I].Outlined := true; + end + else + begin + // normal font + Embolden := FontIni.ReadFloat(SectionName, 'Embolden', 0.0); + Fonts[I].Font := TFTScalableFont.Create(FontFile, 64, Embolden); + Fonts[I].Outlined := false; + end; + + Fonts[I].Font.GlyphSpacing := FontIni.ReadFloat(SectionName, 'GlyphSpacing', 0.0); + Fonts[I].Font.Stretch := FontIni.ReadFloat(SectionName, 'Stretch', 1.0); + + AddFontFallbacks(FontIni, Fonts[I].Font); + end; + except + on E: EFontError do + Log.LogCritical(E.Message, 'BuildFont'); + end; // close ini-file FontIni.Free; end; -// Deletes the font -procedure KillFont; -begin - // delete all characters - //glDeleteLists(..., 256); -end; -function glTextWidth(const text: string): real; +// Deletes the font +procedure KillFonts; var - Letter: char; - i: integer; - Font: PFont; + I: integer; begin - Result := 0; - Font := @Fonts[ActFont]; - - for i := 1 to Length(text) do - begin - Letter := Text[i]; - Result := Result + Font.Width[Ord(Letter)] * Font.Tex.H / 30 * Font.AspectW; - end; - - if ((Result > 0) and Font.Italic) then - Result := Result + 12 * Font.Tex.H / 60 * Font.AspectW; + for I := 0 to High(Fonts) do + Fonts[I].Font.Free; end; -procedure glPrintLetter(Letter: char); +function glTextWidth(const text: UTF8String): real; var - TexX, TexY: real; - TexR, TexB: real; - TexHeight: real; - FWidth: real; - PL, PT: real; - PR, PB: real; - XItal: real; // X shift for italic type letter - ReflectionSpacing: real; // Distance of the reflection - Font: PFont; - Tex: PTexture; + Bounds: TBoundsDbl; begin - Font := @Fonts[ActFont]; - Tex := @Font.Tex; - - FWidth := Font.Width[Ord(Letter)]; - - Tex.W := FWidth * (Tex.H/30) * Font.AspectW; - - // set texture positions - TexX := (ord(Letter) mod 16) * 1/16 + 1/32 - FWidth/1024 - Font.Outline/1024; - TexY := (ord(Letter) div 16) * 1/16 + 2/1024; - TexR := (ord(Letter) mod 16) * 1/16 + 1/32 + FWidth/1024 + Font.Outline/1024; - TexB := (1 + ord(Letter) div 16) * 1/16 - 2/1024; - - TexHeight := TexB - TexY; - - // set vector positions - PL := Tex.X - Font.Outline * (Tex.H/30) * Font.AspectW /2; - PT := Tex.Y; - PR := PL + Tex.W + Font.Outline * (Tex.H/30) * Font.AspectW; - PB := PT + Tex.H; - - if (not Font.Italic) then - XItal := 0 - else - XItal := 12; - - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - - glEnable(GL_TEXTURE_2D); - glBindTexture(GL_TEXTURE_2D, Tex.TexNum); - - glBegin(GL_QUADS); - glTexCoord2f(TexX, TexY); glVertex2f(PL+XItal, PT); - glTexCoord2f(TexX, TexB); glVertex2f(PL, PB); - glTexCoord2f(TexR, TexB); glVertex2f(PR, PB); - glTexCoord2f(TexR, TexY); glVertex2f(PR+XItal, PT); - glEnd; - - // <mog> Reflection - // Yes it would make sense to put this in an extra procedure, - // but this works, doesn't take much lines, and is almost lightweight - if Font.Reflection then - begin - ReflectionSpacing := Font.ReflectionSpacing + Tex.H/2; - - glDepthRange(0, 10); - glDepthFunc(GL_LEQUAL); - glEnable(GL_DEPTH_TEST); - - glBegin(GL_QUADS); - glColor4f(TempColor[0], TempColor[1], TempColor[2], 0); - glTexCoord2f(TexX, TexY + TexHeight/2); - glVertex3f(PL, PB + ReflectionSpacing - Tex.H/2, Tex.z); - - glColor4f(TempColor[0], TempColor[1], TempColor[2], Tex.Alpha-0.3); - glTexCoord2f(TexX, TexB ); - glVertex3f(PL + XItal, PT + ReflectionSpacing, Tex.z); - - glTexCoord2f(TexR, TexB ); - glVertex3f(PR + XItal, PT + ReflectionSpacing, Tex.z); - - glColor4f(TempColor[0], TempColor[1], TempColor[2], 0); - glTexCoord2f(TexR, TexY + TexHeight/2); - glVertex3f(PR, PB + ReflectionSpacing - Tex.H/2, Tex.z); - glEnd; - - glDisable(GL_DEPTH_TEST); - end; // reflection - - glDisable(GL_TEXTURE_2D); - glDisable(GL_BLEND); - - Tex.X := Tex.X + Tex.W; - - //write the colour back - glColor4fv(@TempColor); + Bounds := Fonts[ActFont].Font.BBox(Text, true); + Result := Bounds.Right - Bounds.Left; end; // Custom GL "Print" Routine -procedure glPrint(const Text: string); +procedure glPrint(const Text: UTF8String); var - Pos: integer; + GLFont: PGLFont; begin // if there is no text do nothing if (Text = '') then Exit; - //Save the actual color and alpha (for reflection) - glGetFloatv(GL_CURRENT_COLOR, @TempColor); + GLFont := @Fonts[ActFont]; - for Pos := 1 to Length(Text) do - begin - glPrintLetter(Text[Pos]); - end; + glPushMatrix(); + // set font position + glTranslatef(GLFont.X, GLFont.Y + GLFont.Font.Ascender, GLFont.Z); + // draw string + GLFont.Font.Print(Text); + glPopMatrix(); end; procedure ResetFont(); @@ -343,18 +228,18 @@ end; procedure SetFontPos(X, Y: real); begin - Fonts[ActFont].Tex.X := X; - Fonts[ActFont].Tex.Y := Y; + Fonts[ActFont].X := X; + Fonts[ActFont].Y := Y; end; procedure SetFontZ(Z: real); begin - Fonts[ActFont].Tex.Z := Z; + Fonts[ActFont].Z := Z; end; procedure SetFontSize(Size: real); begin - Fonts[ActFont].Tex.H := Size; + Fonts[ActFont].Font.Height := Size; end; procedure SetFontStyle(Style: integer); @@ -364,21 +249,19 @@ end; procedure SetFontItalic(Enable: boolean); begin - Fonts[ActFont].Italic := Enable; -end; - -procedure SetFontAspectW(Aspect: real); -begin - Fonts[ActFont].AspectW := Aspect; + if (Enable) then + Fonts[ActFont].Font.Style := Fonts[ActFont].Font.Style + [Italic] + else + Fonts[ActFont].Font.Style := Fonts[ActFont].Font.Style - [Italic] end; procedure SetFontReflection(Enable: boolean; Spacing: real); begin - Fonts[ActFont].Reflection := Enable; - Fonts[ActFont].ReflectionSpacing := Spacing; + if (Enable) then + Fonts[ActFont].Font.Style := Fonts[ActFont].Font.Style + [Reflect] + else + Fonts[ActFont].Font.Style := Fonts[ActFont].Font.Style - [Reflect]; + Fonts[ActFont].Font.ReflectionSpacing := Spacing - Fonts[ActFont].Font.Descender; end; end. - -{$ENDIF} - diff --git a/cmake/src/base/TextGLFreetype.pas b/cmake/src/base/TextGLFreetype.pas deleted file mode 100644 index 61b26693..00000000 --- a/cmake/src/base/TextGLFreetype.pas +++ /dev/null @@ -1,222 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL: https://ultrastardx.svn.sourceforge.net/svnroot/ultrastardx/trunk/src/base/TextGL.pas $ - * $Id: TextGL.pas 1483 2008-10-28 19:01:20Z tobigun $ - *} - -(* -unit TextGL; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} -*) - -uses - gl, - glext, - SDL, - UTexture, - UFont, - Classes, - ULog; - -type - PGLFont = ^TGLFont; - TGLFont = record - Font: TScalableFont; - X, Y, Z: real; - end; - -var - Fonts: array of TGLFont; - ActFont: integer; - -procedure BuildFont; // build our bitmap font -procedure KillFont; // delete the font -function glTextWidth(const text: string): real; // returns text width -procedure glPrint(const text: string); // custom GL "Print" routine -procedure ResetFont(); // reset font settings of active font -procedure SetFontPos(X, Y: real); // sets X and Y -procedure SetFontZ(Z: real); // sets Z -procedure SetFontSize(Size: real); -procedure SetFontStyle(Style: integer); // sets active font style (normal, bold, etc) -procedure SetFontItalic(Enable: boolean); // sets italic type letter (works for all fonts) -procedure SetFontReflection(Enable:boolean;Spacing: real); // enables/disables text reflection - -implementation - -uses - UMain, - UCommon, - UTextEncoding, - SysUtils, - IniFiles; - -function FindFontFile(FontIni: TCustomIniFile; Font: string): string; -var - Filename: string; -begin - Filename := FontIni.ReadString(Font, 'File', ''); - Result := FontPath + Filename; - // if path does not exist, try as an absolute path - if (not FileExists(Result)) then - Result := Filename; -end; - -procedure BuildFont; -var - FontIni: TMemIniFile; - //BitmapFont: TBitmapFont; - FontFile: string; -begin - ActFont := 0; - - SetLength(Fonts, 4); - FontIni := TMemIniFile.Create(FontPath + 'fontsTTF.ini'); - //FontIni := TMemIniFile.Create(FontPath + 'fonts.ini'); - - try - - // Normal - FontFile := FindFontFile(FontIni, 'Normal'); - Fonts[0].Font := TFTScalableFont.Create(FontFile, 64); - //Fonts[0].Font.GlyphSpacing := 1.4; - //Fonts[0].Font.Aspect := 1.2; - - { - BitmapFont := TBitmapFont.Create(FontFile, 0, 19, 35, -10); - BitmapFont.CorrectWidths(2, 0); - Fonts[0].Font := TScalableFont.Create(BitmapFont, false); - } - - //Fonts[0].Font.Aspect := 0.9; - - // Bold - FontFile := FindFontFile(FontIni, 'Bold'); - Fonts[1].Font := TFTScalableFont.Create(FontFile, 64); - - // Outline1 - FontFile := FindFontFile(FontIni, 'Outline1'); - Fonts[2].Font := TFTScalableOutlineFont.Create(FontFile, 64, 0.06); - //TFTScalableOutlineFont(Fonts[2].Font).SetOutlineColor(0.3, 0.3, 0.3); - - // Outline2 - FontFile := FindFontFile(FontIni, 'Outline2'); - Fonts[3].Font := TFTScalableOutlineFont.Create(FontFile, 64, 0.08); - - except on E: Exception do - Log.LogCritical(E.Message, 'BuildFont'); - end; - - // close ini-file - FontIni.Free; -end; - - -// Deletes the font -procedure KillFont; -begin - // delete all characters - //glDeleteLists(..., 256); -end; - -function glTextWidth(const text: string): real; -var - Bounds: TBoundsDbl; -begin - // FIXME: remove conversion - Bounds := Fonts[ActFont].Font.BBox(RecodeString(Text, encCP1252), true); - Result := Bounds.Right - Bounds.Left; -end; - -// Custom GL "Print" Routine -procedure glPrint(const Text: string); -var - GLFont: PGLFont; -begin - // if there is no text do nothing - if (Text = '') then - Exit; - - GLFont := @Fonts[ActFont]; - - glPushMatrix(); - // set font position - glTranslatef(GLFont.X, GLFont.Y + GLFont.Font.Ascender, GLFont.Z); - // draw string - // FIXME: remove conversion - GLFont.Font.Print(RecodeString(Text, encCP1252)); - glPopMatrix(); -end; - -procedure ResetFont(); -begin - SetFontPos(0, 0); - SetFontZ(0); - SetFontItalic(False); - SetFontReflection(False, 0); -end; - -procedure SetFontPos(X, Y: real); -begin - Fonts[ActFont].X := X; - Fonts[ActFont].Y := Y; -end; - -procedure SetFontZ(Z: real); -begin - Fonts[ActFont].Z := Z; -end; - -procedure SetFontSize(Size: real); -begin - Fonts[ActFont].Font.Height := Size; -end; - -procedure SetFontStyle(Style: integer); -begin - ActFont := Style; -end; - -procedure SetFontItalic(Enable: boolean); -begin - if (Enable) then - Fonts[ActFont].Font.Style := Fonts[ActFont].Font.Style + [Italic] - else - Fonts[ActFont].Font.Style := Fonts[ActFont].Font.Style - [Italic] -end; - -procedure SetFontReflection(Enable: boolean; Spacing: real); -begin - if (Enable) then - Fonts[ActFont].Font.Style := Fonts[ActFont].Font.Style + [Reflect] - else - Fonts[ActFont].Font.Style := Fonts[ActFont].Font.Style - [Reflect]; - Fonts[ActFont].Font.ReflectionSpacing := Spacing - Fonts[ActFont].Font.Descender; -end; - -end. diff --git a/cmake/src/base/UBeatTimer.pas b/cmake/src/base/UBeatTimer.pas index a47a06f9..bc03de76 100644 --- a/cmake/src/base/UBeatTimer.pas +++ b/cmake/src/base/UBeatTimer.pas @@ -1,170 +1,299 @@ - {* UltraStar Deluxe - Karaoke Game
- *
- * UltraStar Deluxe is the legal property of its developers, whose names
- * are too numerous to list here. Please refer to the COPYRIGHT
- * file distributed with this source distribution.
- *
- * This program is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- * Boston, MA 02110-1301, USA.
- *
- * $URL: https://ultrastardx.svn.sourceforge.net/svnroot/ultrastardx/trunk/src/base/USingNotes.pas $
- * $Id: USingNotes.pas 1406 2008-09-23 21:43:52Z k-m_schindler $
- *}
+{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +unit UBeatTimer; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + UTime; + +type + (** + * TLyricsState contains all information concerning the + * state of the lyrics, e.g. the current beat or duration of the lyrics. + *) + TLyricsState = class + private + fTimer: TRelativeTimer; // keeps track of the current time + fSyncSource: TSyncSource; + fAvgSyncDiff: real; + fLastClock: real; // last master clock value + // Note: do not use Timer.GetState() to check if lyrics are paused as + // Timer.Pause() is used for synching. + fPaused: boolean; + + function Synchronize(LyricTime: real): real; + public + OldBeat: integer; // previous discovered beat + CurrentBeat: integer; // current beat (rounded) + MidBeat: real; // current beat (float) + + // now we use this for super synchronization! + // only used when analyzing voice + // TODO: change ...D to ...Detect(ed) + OldBeatD: integer; // previous discovered beat + CurrentBeatD: integer; // current discovered beat (rounded) + MidBeatD: real; // current discovered beat (float) + + // we use this for audible clicks + // TODO: Change ...C to ...Click + OldBeatC: integer; // previous discovered beat + CurrentBeatC: integer; + MidBeatC: real; // like CurrentBeatC + + OldLine: integer; // previous displayed sentence + + StartTime: real; // time till start of lyrics (= Gap) + TotalTime: real; // total song time + + constructor Create(); + + {** + * Resets the LyricsState state. + *} + procedure Reset(); + + procedure UpdateBeats(); + + {** + * Sets a master clock for this LyricsState. If no sync-source is set + * or SyncSource is nil the internal timer is used. + *} + procedure SetSyncSource(SyncSource: TSyncSource); + + {** + * Starts the timer. This is either done + * - immediately if WaitForTrigger is false or + * - after the first call to GetCurrentTime()/SetCurrentTime() or Start(false) + *} + procedure Start(WaitForTrigger: boolean = false); + + {** + * Pauses the timer. + * The counter is preserved and can be resumed by a call to Start(). + *} + procedure Pause(); + + {** + * Stops the timer. + * The counter is reset to 0. + *} + procedure Stop(); + + (** + * Returns/Sets the current song time (in seconds) used as base-timer for lyrics etc. + * If GetCurrentTime()/SetCurrentTime() if Start() was called + *) + function GetCurrentTime(): real; + procedure SetCurrentTime(Time: real); + end; + +implementation + +uses + UNote, + ULog, + SysUtils, + Math; + + +constructor TLyricsState.Create(); +begin + // create a triggered timer, so we can Pause() it, set the time + // and Resume() it afterwards for better synching. + fTimer := TRelativeTimer.Create(); + + // reset state + Reset(); +end; + +procedure TLyricsState.Pause(); +begin + fTimer.Pause(); + fPaused := true; +end; + +procedure TLyricsState.Start(WaitForTrigger: boolean); +begin + fTimer.Start(WaitForTrigger); + fPaused := false; + fLastClock := -1; + fAvgSyncDiff := -1; +end; + +procedure TLyricsState.Stop(); +begin + fTimer.Stop(); + fPaused := false; +end; + +procedure TLyricsState.SetCurrentTime(Time: real); +begin + fTimer.SetTime(Time); + fLastClock := -1; + fAvgSyncDiff := -1; +end; + +{.$DEFINE LOG_SYNC} + +function TLyricsState.Synchronize(LyricTime: real): real; +var + MasterClock: real; + TimeDiff: real; +const + AVG_HISTORY_FACTOR = 0.7;
+ PAUSE_THRESHOLD = 0.010; // 10ms
+ FORWARD_THRESHOLD = 0.010; // 10ms
+begin + MasterClock := fSyncSource.GetClock();
+ Result := LyricTime;
-unit UBeatTimer;
+ // do not sync if lyrics are paused externally or if the timestamp is old
+ if (fPaused or (MasterClock = fLastClock)) then
+ Exit; + + // calculate average time difference (some sort of weighted mean). + // The bigger AVG_HISTORY_FACTOR is, the smoother is the average diff.
+ // This is done as some timestamps might be wrong or even lower
+ // than their predecessor.
+ TimeDiff := MasterClock - LyricTime;
+ if (fAvgSyncDiff = -1) then
+ fAvgSyncDiff := TimeDiff
+ else
+ fAvgSyncDiff := TimeDiff * (1-AVG_HISTORY_FACTOR) +
+ fAvgSyncDiff * AVG_HISTORY_FACTOR;
-interface
+ {$IFDEF LOG_SYNC}
+ //Log.LogError(Format('TimeDiff: %.3f', [TimeDiff]));
+ {$ENDIF}
-{$IFDEF FPC}
- {$MODE Delphi}
-{$ENDIF}
-
-{$I switches.inc}
-
-uses
- UTime;
-
-type
- (**
- * TLyricsState contains all information concerning the
- * state of the lyrics, e.g. the current beat or duration of the lyrics.
- *)
- TLyricsState = class
- private
- Timer: TRelativeTimer; // keeps track of the current time
- public
- OldBeat: integer; // previous discovered beat
- CurrentBeat: integer; // current beat (rounded)
- MidBeat: real; // current beat (float)
-
- // now we use this for super synchronization!
- // only used when analyzing voice
- // TODO: change ...D to ...Detect(ed)
- OldBeatD: integer; // previous discovered beat
- CurrentBeatD: integer; // current discovered beat (rounded)
- MidBeatD: real; // current discovered beat (float)
-
- // we use this for audible clicks
- // TODO: Change ...C to ...Click
- OldBeatC: integer; // previous discovered beat
- CurrentBeatC: integer;
- MidBeatC: real; // like CurrentBeatC
-
- OldLine: integer; // previous displayed sentence
-
- StartTime: real; // time till start of lyrics (= Gap)
- TotalTime: real; // total song time
-
- constructor Create();
- procedure Pause();
- procedure Resume();
-
- procedure Reset();
- procedure UpdateBeats();
-
- (**
- * current song time (in seconds) used as base-timer for lyrics etc.
- *)
- function GetCurrentTime(): real;
- procedure SetCurrentTime(Time: real);
- end;
-
-implementation
-uses UNote, Math;
-
-
-constructor TLyricsState.Create();
-begin
- // create a triggered timer, so we can Pause() it, set the time
- // and Resume() it afterwards for better synching.
- Timer := TRelativeTimer.Create(true);
-
- // reset state
- Reset();
-end;
-
-procedure TLyricsState.Pause();
-begin
- Timer.Pause();
-end;
-
-procedure TLyricsState.Resume();
-begin
- Timer.Resume();
-end;
-
-procedure TLyricsState.SetCurrentTime(Time: real);
-begin
- // do not start the timer (if not started already),
- // after setting the current time
- Timer.SetTime(Time, false);
-end;
-
-function TLyricsState.GetCurrentTime(): real;
-begin
- Result := Timer.GetTime();
+ // do not go backwards in time as this could mess up the score + if (fAvgSyncDiff > FORWARD_THRESHOLD) then + begin + {$IFDEF LOG_SYNC} + Log.LogError('Sync: ' + floatToStr(MasterClock) + ' > ' + floatToStr(LyricTime));
+ {$ENDIF}
+ + Result := LyricTime + fAvgSyncDiff; + fTimer.SetTime(Result); + fTimer.Start(); + fAvgSyncDiff := -1; + end + else if (fAvgSyncDiff < -PAUSE_THRESHOLD) then + begin + // wait until timer and master clock are in sync (> 10ms) + fTimer.Pause(); + + {$IFDEF LOG_SYNC} + Log.LogError('Pause: ' + floatToStr(MasterClock) + ' < ' + floatToStr(LyricTime)); + {$ENDIF} + end + else if (fTimer.GetState = rtsPaused) and (fAvgSyncDiff >= 0) then + begin + fTimer.Start();
+ + {$IFDEF LOG_SYNC} + Log.LogError('Unpause: ' + floatToStr(LyricTime)); + {$ENDIF} + end; + fLastClock := MasterClock; end;
-
-(**
- * Resets the timer and state of the lyrics.
- * The timer will be stopped afterwards so you have to call Resume()
- * to start the lyrics timer.
- *)
-procedure TLyricsState.Reset();
-begin
- Pause();
- SetCurrentTime(0);
-
- StartTime := 0;
- TotalTime := 0;
-
- OldBeat := -1;
- MidBeat := -1;
- CurrentBeat := -1;
-
- OldBeatC := -1;
- MidBeatC := -1;
- CurrentBeatC := -1;
-
- OldBeatD := -1;
- MidBeatD := -1;
- CurrentBeatD := -1;
-end;
-
-(**
- * Updates the beat information (CurrentBeat/MidBeat/...) according to the
- * current lyric time.
- *)
-procedure TLyricsState.UpdateBeats();
-var
- CurLyricsTime: real;
-begin
- CurLyricsTime := GetCurrentTime();
-
- OldBeat := CurrentBeat;
- MidBeat := GetMidBeat(CurLyricsTime - StartTime / 1000);
- CurrentBeat := Floor(MidBeat);
-
- OldBeatC := CurrentBeatC;
- MidBeatC := GetMidBeat(CurLyricsTime - StartTime / 1000);
- CurrentBeatC := Floor(MidBeatC);
-
- OldBeatD := CurrentBeatD;
- // MidBeatD = MidBeat with additional GAP
- MidBeatD := -0.5 + GetMidBeat(CurLyricsTime - (StartTime + 120 + 20) / 1000);
- CurrentBeatD := Floor(MidBeatD);
-end;
-
+ +function TLyricsState.GetCurrentTime(): real; +var + LyricTime: real; +begin + LyricTime := fTimer.GetTime(); + if Assigned(fSyncSource) then + Result := Synchronize(LyricTime) + else + Result := LyricTime; +end; + +procedure TLyricsState.SetSyncSource(SyncSource: TSyncSource); +begin + fSyncSource := SyncSource;
+end; + +(** + * Resets the timer and state of the lyrics. + * The timer will be stopped afterwards so you have to call Resume() + * to start the lyrics timer. + *) +procedure TLyricsState.Reset(); +begin + Stop(); + fPaused := false; + + fSyncSource := nil; + + StartTime := 0; + TotalTime := 0; + + OldBeat := -1; + MidBeat := -1; + CurrentBeat := -1; + + OldBeatC := -1; + MidBeatC := -1; + CurrentBeatC := -1; + + OldBeatD := -1; + MidBeatD := -1; + CurrentBeatD := -1; +end; + +(** + * Updates the beat information (CurrentBeat/MidBeat/...) according to the + * current lyric time. + *) +procedure TLyricsState.UpdateBeats(); +var + CurLyricsTime: real; +begin + CurLyricsTime := GetCurrentTime(); + + OldBeat := CurrentBeat; + MidBeat := GetMidBeat(CurLyricsTime - StartTime / 1000); + CurrentBeat := Floor(MidBeat); + + OldBeatC := CurrentBeatC; + MidBeatC := GetMidBeat(CurLyricsTime - StartTime / 1000); + CurrentBeatC := Floor(MidBeatC); + + OldBeatD := CurrentBeatD; + // MidBeatD = MidBeat with additional GAP + MidBeatD := -0.5 + GetMidBeat(CurLyricsTime - (StartTime + 120 + 20) / 1000); + CurrentBeatD := Floor(MidBeatD); +end; + end.
\ No newline at end of file diff --git a/cmake/src/base/UCatCovers.pas b/cmake/src/base/UCatCovers.pas index 6ef81b68..85cb850f 100644 --- a/cmake/src/base/UCatCovers.pas +++ b/cmake/src/base/UCatCovers.pas @@ -24,10 +24,6 @@ *} unit UCatCovers; -///////////////////////////////////////////////////////////////////////// -// UCatCovers by Whiteshark // -// Class for listing and managing the Category Covers // -///////////////////////////////////////////////////////////////////////// interface @@ -38,20 +34,21 @@ interface {$I switches.inc} uses - UIni; + UIni, + UPath; type TCatCovers = class protected - cNames: array [0..high(ISorting)] of array of string; - cFiles: array [0..high(ISorting)] of array of string; + cNames: array [TSortingType] of array of UTF8String; + cFiles: array [TSortingType] of array of IPath; public constructor Create; procedure Load; //Load Cover aus Cover.ini and Cover Folder - procedure LoadPath(const CoversPath: string); - procedure Add(Sorting: integer; Name, Filename: string); //Add a Cover - function CoverExists(Sorting: integer; Name: string): boolean; //Returns True when a cover with the given Name exists - function GetCover(Sorting: integer; Name: string): string; //Returns the Filename of a Cover + procedure LoadPath(const CoversPath: IPath); + procedure Add(Sorting: TSortingType; const Name: UTF8String; const Filename: IPath); //Add a Cover + function CoverExists(Sorting: TSortingType; const Name: UTF8String): boolean; //Returns True when a cover with the given Name exists + function GetCover(Sorting: TSortingType; const Name: UTF8String): IPath; //Returns the Filename of a Cover end; var @@ -63,10 +60,11 @@ uses IniFiles, SysUtils, Classes, - // UFiles, + UFilesystem, ULog, UMain, - UPath; + UUnicodeUtils, + UPathUtils; constructor TCatCovers.Create; begin @@ -79,90 +77,96 @@ var I: integer; begin for I := 0 to CoverPaths.Count-1 do - LoadPath(CoverPaths[I]); + LoadPath(CoverPaths[I] as IPath); end; (** * Load Cover from Cover.ini and Cover Folder *) -procedure TCatCovers.LoadPath(const CoversPath: string); +procedure TCatCovers.LoadPath(const CoversPath: IPath); var Ini: TMemIniFile; - SR: TSearchRec; List: TStringlist; - I, J: Integer; - Name, Filename, Temp: string; + I: Integer; + SortType: TSortingType; + Filename: IPath; + Name, TmpName: UTF8String; + CatCover: IPath; + Iter: IFileIterator; + FileInfo: TFileInfo; begin Ini := nil; List := nil; try - Ini := TMemIniFile.Create(CoversPath + 'covers.ini'); + Ini := TMemIniFile.Create(CoversPath.Append('covers.ini').ToNative); List := TStringlist.Create; //Add every Cover in Covers Ini for Every Sorting option - for I := 0 to High(ISorting) do + for SortType := Low(TSortingType) to High(TSortingType) do begin - Ini.ReadSection(ISorting[I], List); + Ini.ReadSection(ISorting[Ord(SortType)], List); - for J := 0 to List.Count - 1 do - Add(I, List.Strings[J], CoversPath + Ini.ReadString(ISorting[I], List.Strings[J], 'NoCover.jpg')); + for I := 0 to List.Count - 1 do + begin + CatCover := Path(Ini.ReadString(ISorting[Ord(SortType)], List.Strings[I], 'NoCover.jpg')); + Add(SortType, List.Strings[I], CoversPath.Append(CatCover)); + end; end; finally Ini.Free; List.Free; end; - try - //Add Covers from Folder - if (FindFirst (CoversPath + '*.jpg', faAnyFile, SR) = 0) then - repeat - //Add Cover if it doesn't exist for every Section - Name := SR.Name; - Filename := CoversPath + Name; - Delete (Name, length(Name) - 3, 4); - - for I := 0 to high(ISorting) do - begin - Temp := Name; - if ((I = sTitle) or (I = sTitle2)) and (Pos ('Title', Temp) <> 0) then - Delete (Temp, Pos ('Title', Temp), 5) - else if (I = sArtist) or (I = sArtist2) and (Pos ('Artist', Temp) <> 0) then - Delete (Temp, Pos ('Artist', Temp), 6); - - if not CoverExists(I, Temp) then - Add (I, Temp, Filename); - end; - until FindNext (SR) <> 0; - finally - FindClose (SR); + //Add Covers from Folder + Iter := FileSystem.FileFind(CoversPath.Append('*.jpg'), 0); + while Iter.HasNext do + begin + FileInfo := Iter.Next; + + //Add Cover if it doesn't exist for every Section + Filename := CoversPath.Append(FileInfo.Name); + Name := FileInfo.Name.SetExtension('').ToUTF8; + + for SortType := Low(TSortingType) to High(TSortingType) do + begin + TmpName := Name; + if (SortType = sTitle) and (UTF8Pos('Title', TmpName) <> 0) then + UTF8Delete(TmpName, UTF8Pos('Title', TmpName), 5) + else if (SortType = sArtist) and (UTF8Pos('Artist', TmpName) <> 0) then + UTF8Delete(TmpName, UTF8Pos('Artist', TmpName), 6); + + if not CoverExists(SortType, TmpName) then + Add(SortType, TmpName, Filename); + end; end; end; //Add a Cover -procedure TCatCovers.Add(Sorting: integer; Name, Filename: string); +procedure TCatCovers.Add(Sorting: TSortingType; const Name: UTF8String; const Filename: IPath); begin - if FileExists (Filename) then //If Exists -> Add + if Filename.IsFile then //If Exists -> Add begin - SetLength (CNames[Sorting], Length(CNames[Sorting]) + 1); - SetLength (CFiles[Sorting], Length(CNames[Sorting]) + 1); + SetLength(CNames[Sorting], Length(CNames[Sorting]) + 1); + SetLength(CFiles[Sorting], Length(CNames[Sorting]) + 1); - CNames[Sorting][high(cNames[Sorting])] := Uppercase(Name); + CNames[Sorting][high(cNames[Sorting])] := UTF8Uppercase(Name); CFiles[Sorting][high(cNames[Sorting])] := FileName; end; end; //Returns True when a cover with the given Name exists -function TCatCovers.CoverExists(Sorting: integer; Name: string): boolean; +function TCatCovers.CoverExists(Sorting: TSortingType; const Name: UTF8String): boolean; var I: Integer; + UpperName: UTF8String; begin Result := False; - Name := Uppercase(Name); //Case Insensitiv + UpperName := UTF8Uppercase(Name); //Case Insensitiv for I := 0 to high(cNames[Sorting]) do begin - if (cNames[Sorting][I] = Name) then //Found Name + if (cNames[Sorting][I] = UpperName) then //Found Name begin Result := true; break; //Break For Loop @@ -171,16 +175,18 @@ begin end; //Returns the Filename of a Cover -function TCatCovers.GetCover(Sorting: integer; Name: string): string; +function TCatCovers.GetCover(Sorting: TSortingType; const Name: UTF8String): IPath; var I: Integer; + UpperName: UTF8String; + NoCoverPath: IPath; begin - Result := ''; - Name := Uppercase(Name); + Result := PATH_NONE; + UpperName := UTF8Uppercase(Name); for I := 0 to high(cNames[Sorting]) do begin - if cNames[Sorting][I] = Name then + if cNames[Sorting][I] = UpperName then begin Result := cFiles[Sorting][I]; Break; @@ -188,17 +194,18 @@ begin end; //No Cover - if (Result = '') then + if (Result.IsUnset) then begin for I := 0 to CoverPaths.Count-1 do begin - if (FileExists(CoverPaths[I] + 'NoCover.jpg')) then + NoCoverPath := (CoverPaths[I] as IPath).Append('NoCover.jpg'); + if (NoCoverPath.IsFile) then begin - Result := CoverPaths[I] + 'NoCover.jpg'; + Result := NoCoverPath; Break; end; end; end; end; -end. +end.
\ No newline at end of file diff --git a/cmake/src/base/UCommandLine.pas b/cmake/src/base/UCommandLine.pas index 281a480d..ac0db2c2 100644 --- a/cmake/src/base/UCommandLine.pas +++ b/cmake/src/base/UCommandLine.pas @@ -33,6 +33,9 @@ interface {$I switches.inc} +uses + UPath; + type TScreenMode = (scmDefault, scmFullscreen, scmWindowed); @@ -64,9 +67,9 @@ type Screens: integer; // some strings set when reading infos {Length=0: Not Set} - SongPath: string; - ConfigFile: string; - ScoreFile: string; + SongPath: IPath; + ConfigFile: IPath; + ScoreFile: IPath; // pseudo integer values property Language: integer read GetLanguage; @@ -144,9 +147,9 @@ begin Screens := -1; // some strings set when reading infos {Length=0 Not Set} - SongPath := ''; - ConfigFile := ''; - ScoreFile := ''; + SongPath := PATH_NONE; + ConfigFile := PATH_NONE; + ScoreFile := PATH_NONE; end; {** @@ -248,7 +251,7 @@ begin if (PCount > I) then begin // write value to string - SongPath := ParamStr(I + 1); + SongPath := Path(ParamStr(I + 1)); end; end @@ -258,11 +261,11 @@ begin if (PCount > I) then begin // write value to string - ConfigFile := ParamStr(I + 1); + ConfigFile := Path(ParamStr(I + 1)); // is this a relative path -> then add gamepath - if Not ((Length(ConfigFile) > 2) AND (ConfigFile[2] = ':')) then - ConfigFile := ExtractFilePath(ParamStr(0)) + Configfile; + if (not ConfigFile.IsAbsolute) then + ConfigFile := Platform.GetExecutionDir().Append(ConfigFile); end; end @@ -272,7 +275,7 @@ begin if (PCount > I) then begin // write value to string - ScoreFile := ParamStr(I + 1); + ScoreFile := Path(ParamStr(I + 1)); end; end; diff --git a/cmake/src/base/UCommon.pas b/cmake/src/base/UCommon.pas index d729b6dd..18022337 100644 --- a/cmake/src/base/UCommon.pas +++ b/cmake/src/base/UCommon.pas @@ -39,9 +39,29 @@ uses {$IFDEF MSWINDOWS} Windows, {$ENDIF} - sdl, UConfig, - ULog; + ULog, + UPath; + +type + TStringDynArray = array of string; + TUTF8StringDynArray = array of UTF8String; + +const + SepWhitespace = [#9, #10, #13, ' ']; // tab, lf, cr, space + +{** + * Splits a string into pieces separated by Separators. + * MaxCount specifies the max. number of pieces. If it is <= 0 the number is + * not limited. If > 0 the last array element will hold the rest of the string + * (with leading separators removed). + * + * Examples: + * SplitString(' split me now ', 0) -> ['split', 'me', 'now'] + * SplitString(' split me now ', 1) -> ['split', 'me now'] + *} +function SplitString(const Str: string; MaxCount: integer = 0; Separators: TSysCharSet = SepWhitespace): TStringDynArray; + type TMessageType = (mtInfo, mtError); @@ -50,49 +70,27 @@ procedure ShowMessage(const msg: string; msgType: TMessageType = mtInfo); procedure ConsoleWriteLn(const msg: string); -function RWopsFromStream(Stream: TStream): PSDL_RWops; - {$IFDEF FPC} function RandomRange(aMin: integer; aMax: integer): integer; {$ENDIF} -function StringReplaceW(text: WideString; search, rep: WideChar): WideString; -function AdaptFilePaths(const aPath: WideString): WideString; - procedure DisableFloatingPointExceptions(); procedure SetDefaultNumericLocale(); procedure RestoreNumericLocale(); {$IFNDEF MSWINDOWS} - procedure ZeroMemory(Destination: pointer; Length: dword); - function MakeLong(a, b: word): longint; - (* - #define LOBYTE(a) (BYTE)(a) - #define HIBYTE(a) (BYTE)((a)>>8) - #define LOWORD(a) (WORD)(a) - #define HIWORD(a) (WORD)((a)>>16) - #define MAKEWORD(a,b) (WORD)(((a)&0xff)|((b)<<8)) - *) +procedure ZeroMemory(Destination: pointer; Length: dword); +function MakeLong(a, b: word): longint; {$ENDIF} -function FileExistsInsensitive(var FileName: string): boolean; - -(* - * Character classes - *) - -function IsAlphaChar(ch: WideChar): boolean; -function IsNumericChar(ch: WideChar): boolean; -function IsAlphaNumericChar(ch: WideChar): boolean; -function IsPunctuationChar(ch: WideChar): boolean; -function IsControlChar(ch: WideChar): boolean; - // A stable alternative to TList.Sort() (use TList.Sort() if applicable, see below) procedure MergeSort(List: TList; CompareFunc: TListSortCompare); function GetAlignedMem(Size: cardinal; Alignment: integer): pointer; procedure FreeAlignedMem(P: pointer); +function GetArrayIndex(const SearchArray: array of UTF8String; Value: string; CaseInsensitiv: boolean = false): integer; + implementation @@ -101,8 +99,63 @@ uses {$IFDEF Delphi} Dialogs, {$ENDIF} - UMain; + sdl, + UFilesystem, + UMain, + UUnicodeUtils; +function SplitString(const Str: string; MaxCount: integer; Separators: TSysCharSet): TStringDynArray; + + {* + * Adds Str[StartPos..Endpos-1] to the result array. + *} + procedure AddSplit(StartPos, EndPos: integer); + begin + SetLength(Result, Length(Result)+1); + Result[High(Result)] := Copy(Str, StartPos, EndPos-StartPos); + end; + +var + I: integer; + Start: integer; + Last: integer; +begin + Start := 0; + SetLength(Result, 0); + + for I := 1 to Length(Str) do + begin + if (Str[I] in Separators) then + begin + // end of component found + if (Start > 0) then + begin + AddSplit(Start, I); + Start := 0; + end; + end + else if (Start = 0) then + begin + // mark beginning of component + Start := I; + // check if this is the last component + if (Length(Result) = MaxCount-1) then + begin + // find last non-separator char + Last := Length(Str); + while (Str[Last] in Separators) do + Dec(Last); + // add component up to last non-separator + AddSplit(Start, Last); + Exit; + end; + end; + end; + + // last component + if (Start > 0) then + AddSplit(Start, Length(Str)+1); +end; // data used by the ...Locale() functions {$IF Defined(Linux) or Defined(FreeBSD)} @@ -224,39 +277,6 @@ begin exOverflow, exUnderflow, exPrecision]); end; -function StringReplaceW(text: WideString; search, rep: WideChar): WideString; -var - iPos: integer; -// sTemp: WideString; -begin -(* - result := text; - iPos := Pos(search, result); - while (iPos > 0) do - begin - sTemp := copy(result, iPos + length(search), length(result)); - result := copy(result, 1, iPos - 1) + rep + sTEmp; - iPos := Pos(search, result); - end; -*) - result := text; - - if search = rep then - exit; - - for iPos := 1 to length(result) do - begin - if result[iPos] = search then - result[iPos] := rep; - end; -end; - -function AdaptFilePaths(const aPath: WideString): WideString; -begin - result := StringReplaceW(aPath, '\', PathDelim);//, [rfReplaceAll]); -end; - - {$IFNDEF MSWINDOWS} procedure ZeroMemory(Destination: pointer; Length: dword); begin @@ -268,135 +288,8 @@ begin Result := (LongInt(B) shl 16) + A; end; -(* -function QueryPerformanceCounter(lpPerformanceCount:TLARGEINTEGER): Bool; - - // From http://en.wikipedia.org/wiki/RDTSC - function RDTSC: Int64; register; - asm - rdtsc - end; - -begin - // Use clock_gettime(CLOCK_REALTIME, ...) here (but not from the libc unit) - lpPerformanceCount := RDTSC(); - result := true; -end; - -function QueryPerformanceFrequency(lpFrequency:TLARGEINTEGER):Bool; -begin - // clock_getres(CLOCK_REALTIME, ...) - lpFrequency := 0; - result := true; -end; -*) {$ENDIF} -// Checks if a regular files or directory with the given name exists. -// The comparison is case insensitive. -function FileExistsInsensitive(var FileName: string): boolean; -var - FilePath, LocalFileName: string; - SearchInfo: TSearchRec; -begin -{$IF Defined(Linux) or Defined(FreeBSD)} - // speed up standard case - if FileExists(FileName) then - begin - Result := true; - exit; - end; - - Result := false; - - FilePath := ExtractFilePath(FileName); - if (FindFirst(FilePath + '*', faAnyFile, SearchInfo) = 0) then - begin - LocalFileName := ExtractFileName(FileName); - repeat - if (AnsiSameText(LocalFileName, SearchInfo.Name)) then - begin - FileName := FilePath + SearchInfo.Name; - Result := true; - break; - end; - until (FindNext(SearchInfo) <> 0); - end; - FindClose(SearchInfo); -{$ELSE} - // Windows and Mac OS X do not have case sensitive file systems - Result := FileExists(FileName); -{$IFEND} -end; - -// +++++++++++++++++++++ helpers for RWOpsFromStream() +++++++++++++++ -function SdlStreamSeek(context: PSDL_RWops; offset: integer; whence: integer): integer; cdecl; -var - stream: TStream; - origin: word; -begin - stream := TStream(context.unknown); - if (stream = nil) then - raise EInvalidContainer.Create('SDLStreamSeek on nil'); - case whence of - 0 : origin := soFromBeginning; // Offset is from the beginning of the resource. Seek moves to the position Offset. Offset must be >= 0. - 1 : origin := soFromCurrent; // Offset is from the current position in the resource. Seek moves to Position + Offset. - 2 : origin := soFromEnd; - else - origin := soFromBeginning; // just in case - end; - Result := stream.Seek(offset, origin); -end; - -function SdlStreamRead(context: PSDL_RWops; Ptr: pointer; size: integer; maxnum: integer): integer; cdecl; -var - stream: TStream; -begin - stream := TStream(context.unknown); - if (stream = nil) then - raise EInvalidContainer.Create('SDLStreamRead on nil'); - try - Result := stream.read(Ptr^, Size * maxnum) div size; - except - Result := -1; - end; -end; - -function SDLStreamClose(context: PSDL_RWops): integer; cdecl; -var - stream: TStream; -begin - stream := TStream(context.unknown); - if (stream = nil) then - raise EInvalidContainer.Create('SDLStreamClose on nil'); - stream.Free; - Result := 1; -end; -// ----------------------------------------------- - -(* - * Creates an SDL_RWops handle from a TStream. - * The stream and RWops must be freed by the user after usage. - * Use SDL_FreeRW(...) to free the RWops data-struct. - *) -function RWopsFromStream(Stream: TStream): PSDL_RWops; -begin - Result := SDL_AllocRW(); - if (Result = nil) then - Exit; - - // set RW-callbacks - with Result^ do - begin - unknown := TUnknown(Stream); - seek := SDLStreamSeek; - read := SDLStreamRead; - write := nil; - close := SDLStreamClose; - type_ := 2; - end; -end; - {$IFDEF FPC} function RandomRange(aMin: integer; aMax: integer): integer; begin @@ -541,59 +434,6 @@ begin {$IFEND} end; -function IsAlphaChar(ch: WideChar): boolean; -begin - // TODO: add chars > 255 when unicode-fonts work? - case ch of - 'A'..'Z', // A-Z - 'a'..'z', // a-z - #170,#181,#186, - #192..#214, - #216..#246, - #248..#255: - Result := true; - else - Result := false; - end; -end; - -function IsNumericChar(ch: WideChar): boolean; -begin - case ch of - '0'..'9': - Result := true; - else - Result := false; - end; -end; - -function IsAlphaNumericChar(ch: WideChar): boolean; -begin - Result := (IsAlphaChar(ch) or IsNumericChar(ch)); -end; - -function IsPunctuationChar(ch: WideChar): boolean; -begin - // TODO: add chars outside of Latin1 basic (0..127)? - case ch of - ' '..'/',':'..'@','['..'`','{'..'~': - Result := true; - else - Result := false; - end; -end; - -function IsControlChar(ch: WideChar): boolean; -begin - case ch of - #0..#31, - #127..#159: - Result := true; - else - Result := false; - end; -end; - (* * Recursive part of the MergeSort algorithm. * OutList will be either InList or TempList and will be swapped in each @@ -677,6 +517,28 @@ begin TempList.Free; end; +(** + * Returns the index of Value in SearchArray + * or -1 if Value is not in SearchArray. + *) +function GetArrayIndex(const SearchArray: array of UTF8String; Value: string; + CaseInsensitiv: boolean = false): integer; +var + i: integer; +begin + Result := -1; + + for i := 0 to High(SearchArray) do + begin + if (SearchArray[i] = Value) or + (CaseInsensitiv and (CompareText(SearchArray[i], Value) = 0)) then + begin + Result := i; + Break; + end; + end; +end; + type // stores the unaligned pointer of data allocated by GetAlignedMem() diff --git a/cmake/src/base/UConfig.pas b/cmake/src/base/UConfig.pas index dfb51d54..c0980de4 100644 --- a/cmake/src/base/UConfig.pas +++ b/cmake/src/base/UConfig.pas @@ -58,7 +58,7 @@ unit UConfig; // not possible to use the version-numbers in this uses-clause. // Example: // interface -// uses +// uses // versions, // include this file // {$IF USE_UNIT_XYZ}xyz;{$IFEND} // Error: USE_UNIT_XYZ not defined // const @@ -68,13 +68,13 @@ unit UConfig; // // Even if this file was an include-file no constants could be declared // before the interface's uses clause. -// In FPC macros {$DEFINE VER:= 3} could be used to declare the version-numbers +// In FPC macros {$DEFINE VER:= 3} could be used to declare the version-numbers // but this is incompatible to Delphi. In addition macros do not allow expand -// arithmetic expressions. Although you can define +// arithmetic expressions. Although you can define // {$DEFINE FPC_VER:= FPC_VERSION*1000000+FPC_RELEASE*1000+FPC_PATCH} // the following check would fail: // {$IF FPC_VERSION_INT >= 002002000} -// would fail because FPC_VERSION_INT is interpreted as a string. +// would fail because FPC_VERSION_INT is interpreted as a string. // // PLEASE consider this if you use version numbers in $IF compiler- // directives. Otherwise you might break portability. @@ -88,9 +88,9 @@ interface {$ENDIF} {$I switches.inc} - + uses - Sysutils; + SysUtils; const // IMPORTANT: @@ -107,7 +107,7 @@ const // include config-file (defines + constants) {$IF Defined(MSWindows)} - {$I config-win.inc} + {$I ..\config-win.inc} {$ELSEIF Defined(Linux)} {$I config-linux.inc} {$ELSEIF Defined(FreeBSD)} @@ -130,7 +130,7 @@ const USDX_VERSION_MAJOR = 1; USDX_VERSION_MINOR = 1; USDX_VERSION_RELEASE = 0; - USDX_VERSION_STATE = 'Alpha'; + USDX_VERSION_STATE = 'Beta'; USDX_STRING = 'UltraStar Deluxe'; (* @@ -151,11 +151,17 @@ const FPC_RELEASE = 0; FPC_PATCH = 0; {$ENDIF} - + FPC_VERSION_INT = (FPC_VERSION * VERSION_MAJOR) + (FPC_RELEASE * VERSION_MINOR) + (FPC_PATCH * VERSION_RELEASE); + // FPC 2.2.0 unicode support is very buggy. The cwstring unit for example + // always crashes whenever UTF8ToAnsi() is called on a non UTF8 encoded string + // what is fixed in 2.2.2. + {$IF Defined(FPC) and (FPC_VERSION_INT < 2002002)} // < 2.2.2 + {$MESSAGE FATAL 'FPC >= 2.2.2 required!'} + {$IFEND} {$IFDEF HaveFFmpeg} @@ -179,13 +185,13 @@ const {$ENDIF} - {$IFDEF HaveProjectM} + {$IFDEF HaveProjectM} PROJECTM_VERSION = (PROJECTM_VERSION_MAJOR * VERSION_MAJOR) + (PROJECTM_VERSION_MINOR * VERSION_MINOR) + (PROJECTM_VERSION_RELEASE * VERSION_RELEASE); {$ENDIF} - {$IFDEF HavePortaudio} + {$IFDEF HavePortaudio} PORTAUDIO_VERSION = (PORTAUDIO_VERSION_MAJOR * VERSION_MAJOR) + (PORTAUDIO_VERSION_MINOR * VERSION_MINOR) + (PORTAUDIO_VERSION_RELEASE * VERSION_RELEASE); @@ -223,4 +229,4 @@ begin ' Build'; end; -end. +end.
\ No newline at end of file diff --git a/cmake/src/base/UCovers.pas b/cmake/src/base/UCovers.pas index a1705674..6c7c9e48 100644 --- a/cmake/src/base/UCovers.pas +++ b/cmake/src/base/UCovers.pas @@ -50,7 +50,8 @@ uses SysUtils, Classes, UImage, - UTexture; + UTexture, + UPath; type ECoverDBException = class(Exception) @@ -59,9 +60,9 @@ type TCover = class private ID: int64; - Filename: WideString; + Filename: IPath; public - constructor Create(ID: int64; Filename: WideString); + constructor Create(ID: int64; Filename: IPath); function GetPreviewTexture(): TTexture; function GetTexture(): TTexture; end; @@ -76,19 +77,19 @@ type private DB: TSQLiteDatabase; procedure InitCoverDatabase(); - function CreateThumbnail(const Filename: WideString; var Info: TThumbnailInfo): PSDL_Surface; + function CreateThumbnail(const Filename: IPath; var Info: TThumbnailInfo): PSDL_Surface; function LoadCover(CoverID: int64): TTexture; procedure DeleteCover(CoverID: int64); - function FindCoverIntern(const Filename: WideString): int64; + function FindCoverIntern(const Filename: IPath): int64; procedure Open(); function GetVersion(): integer; procedure SetVersion(Version: integer); public constructor Create(); destructor Destroy; override; - function AddCover(const Filename: WideString): TCover; - function FindCover(const Filename: WideString): TCover; - function CoverExists(const Filename: WideString): boolean; + function AddCover(const Filename: IPath): TCover; + function FindCover(const Filename: IPath): TCover; + function CoverExists(const Filename: IPath): boolean; function GetMaxCoverSize(): integer; procedure SetMaxCoverSize(Size: integer); end; @@ -111,7 +112,7 @@ uses DateUtils; const - COVERDB_FILENAME = 'cover.db'; + COVERDB_FILENAME: UTF8String = 'cover.db'; COVERDB_VERSION = 01; // 0.1 COVER_TBL = 'Cover'; COVER_THUMBNAIL_TBL = 'CoverThumbnail'; @@ -141,7 +142,7 @@ end; { TCover } -constructor TCover.Create(ID: int64; Filename: WideString); +constructor TCover.Create(ID: int64; Filename: IPath); begin Self.ID := ID; Self.Filename := Filename; @@ -210,11 +211,11 @@ end; procedure TCoverDatabase.Open(); var Version: integer; - Filename: string; + Filename: IPath; begin - Filename := UTF8Encode(Platform.GetGameUserPath() + COVERDB_FILENAME); + Filename := Platform.GetGameUserPath().Append(COVERDB_FILENAME); - DB := TSQLiteDatabase.Create(Filename); + DB := TSQLiteDatabase.Create(Filename.ToUTF8()); Version := GetVersion(); // check version, if version is too old/new, delete database file @@ -223,10 +224,10 @@ begin Log.LogInfo('Outdated cover-database file found', 'TCoverDatabase.Open'); // close and delete outdated file DB.Free; - if (not DeleteFile(Filename)) then - raise ECoverDBException.Create('Could not delete ' + Filename); + if (not Filename.DeleteFile()) then + raise ECoverDBException.Create('Could not delete ' + Filename.ToNative); // reopen - DB := TSQLiteDatabase.Create(Filename); + DB := TSQLiteDatabase.Create(Filename.ToUTF8()); Version := 0; end; @@ -266,14 +267,14 @@ begin ')'); end; -function TCoverDatabase.FindCoverIntern(const Filename: WideString): int64; +function TCoverDatabase.FindCoverIntern(const Filename: IPath): int64; begin Result := DB.GetTableValue('SELECT [ID] FROM ['+COVER_TBL+'] ' + 'WHERE [Filename] = ?', - [UTF8Encode(Filename)]); + [Filename.ToUTF8]); end; -function TCoverDatabase.FindCover(const Filename: WideString): TCover; +function TCoverDatabase.FindCover(const Filename: IPath): TCover; var CoverID: int64; begin @@ -287,7 +288,7 @@ begin end; end; -function TCoverDatabase.CoverExists(const Filename: WideString): boolean; +function TCoverDatabase.CoverExists(const Filename: IPath): boolean; begin Result := false; try @@ -297,7 +298,7 @@ begin end; end; -function TCoverDatabase.AddCover(const Filename: WideString): TCover; +function TCoverDatabase.AddCover(const Filename: IPath): TCover; var CoverID: int64; Thumbnail: PSDL_Surface; @@ -329,7 +330,7 @@ begin DB.ExecSQL('INSERT INTO ['+COVER_TBL+'] ' + '([Filename], [Date], [Width], [Height]) VALUES' + '(?, ?, ?, ?)', - [UTF8Encode(Filename), DateTimeToUnixTime(FileDate), + [Filename.ToUTF8, DateTimeToUnixTime(FileDate), Info.CoverWidth, Info.CoverHeight]); // get auto-generated cover ID @@ -358,7 +359,7 @@ var PixelFmt: TImagePixelFmt; Data: PChar; DataSize: integer; - Filename: WideString; + Filename: IPath; Table: TSQLiteUniTable; begin Table := nil; @@ -371,7 +372,7 @@ begin 'USING(ID) ' + 'WHERE [ID] = %d', [CoverID])); - Filename := UTF8Decode(Table.FieldAsString(0)); + Filename := Path(Table.FieldAsString(0)); PixelFmt := TImagePixelFmt(Table.FieldAsInteger(1)); Width := Table.FieldAsInteger(2); Height := Table.FieldAsInteger(3); @@ -384,6 +385,9 @@ begin end else begin + // FillChar() does not decrement the ref-count of ref-counted fields + // -> reset Name field manually + Result.Name := nil; FillChar(Result, SizeOf(TTexture), 0); end; except on E: Exception do @@ -403,7 +407,7 @@ end; * Returns a pointer to an array of bytes containing the texture data in the * requested size *) -function TCoverDatabase.CreateThumbnail(const Filename: WideString; var Info: TThumbnailInfo): PSDL_Surface; +function TCoverDatabase.CreateThumbnail(const Filename: IPath; var Info: TThumbnailInfo): PSDL_Surface; var //TargetAspect, SourceAspect: double; //TargetWidth, TargetHeight: integer; @@ -417,7 +421,7 @@ begin Thumbnail := LoadImage(Filename); if (not assigned(Thumbnail)) then begin - Log.LogError('Could not load cover: "'+ Filename +'"', 'TCoverDatabase.AddCover'); + Log.LogError('Could not load cover: "'+ Filename.ToNative +'"', 'TCoverDatabase.AddCover'); Exit; end; diff --git a/cmake/src/base/UDLLManager.pas b/cmake/src/base/UDLLManager.pas deleted file mode 100644 index 3faa15bf..00000000 --- a/cmake/src/base/UDLLManager.pas +++ /dev/null @@ -1,292 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UDLLManager; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - ModiSDK, - UFiles; - -type - TDLLMan = class - private - hLib: THandle; - P_Init: fModi_Init; - P_Draw: fModi_Draw; - P_Finish: fModi_Finish; - P_RData: pModi_RData; - public - Plugins: array of TPluginInfo; - PluginPaths: array of string; - Selected: ^TPluginInfo; - - constructor Create; - - procedure GetPluginList; - procedure ClearPluginInfo(No: cardinal); - function LoadPluginInfo(Filename: string; No: cardinal): boolean; - - function LoadPlugin(No: cardinal): boolean; - procedure UnLoadPlugin; - - function PluginInit (const TeamInfo: TTeamInfo; - var Playerinfo: TPlayerinfo; - const Sentences: TSentences; - const LoadTex: fModi_LoadTex; - const Print: fModi_Print; - LoadSound: fModi_LoadSound; - PlaySound: pModi_PlaySound) - : boolean; - function PluginDraw (var Playerinfo: TPlayerinfo; const CurSentence: cardinal): boolean; - function PluginFinish (var Playerinfo: TPlayerinfo): byte; - procedure PluginRData (handle: HSTREAM; buffer: Pointer; len: dword; user: dword); - end; - -var - DLLMan: TDLLMan; - -const -{$IF Defined(MSWINDOWS)} - DLLExt = '.dll'; -{$ELSEIF Defined(DARWIN)} - DLLExt = '.dylib'; -{$ELSEIF Defined(UNIX)} - DLLExt = '.so'; -{$IFEND} - -implementation - -uses - {$IFDEF MSWINDOWS} - windows, - {$ELSE} - dynlibs, - {$ENDIF} - UPath, - ULog, - SysUtils; - - -constructor TDLLMan.Create; -begin - inherited; - SetLength(Plugins, 0); - SetLength(PluginPaths, Length(Plugins)); - GetPluginList; -end; - -procedure TDLLMan.GetPluginList; -var - SearchRecord: TSearchRec; -begin - - if FindFirst(PluginPath + '*' + DLLExt, faAnyFile, SearchRecord) = 0 then - begin - repeat - SetLength(Plugins, Length(Plugins)+1); - SetLength(PluginPaths, Length(Plugins)); - - if LoadPluginInfo(SearchRecord.Name, High(Plugins)) then // loaded succesful - begin - PluginPaths[High(PluginPaths)] := SearchRecord.Name; - end - else // error loading - begin - SetLength(Plugins, Length(Plugins)-1); - SetLength(PluginPaths, Length(Plugins)); - end; - - until FindNext(SearchRecord) <> 0; - FindClose(SearchRecord); - end; -end; - -procedure TDLLMan.ClearPluginInfo(No: cardinal); -begin -// set to party modi plugin - Plugins[No].Typ := 8; - - Plugins[No].Name := 'unknown'; - Plugins[No].NumPlayers := 0; - - Plugins[No].Creator := 'Nobody'; - Plugins[No].PluginDesc := 'NO_PLUGIN_DESC'; - - Plugins[No].LoadSong := true; - Plugins[No].ShowScore := true; - Plugins[No].ShowBars := true; - Plugins[No].ShowNotes := true; - Plugins[No].LoadVideo := true; - Plugins[No].LoadBack := true; - - Plugins[No].TeamModeOnly := true; - Plugins[No].GetSoundData := true; - Plugins[No].Dummy := true; - - - Plugins[No].BGShowFull := true; - Plugins[No].BGShowFull_O := true; - - Plugins[No].ShowRateBar := true; - Plugins[No].ShowRateBar_O := true; - - Plugins[No].EnLineBonus := true; - Plugins[No].EnLineBonus_O := true; -end; - -function TDLLMan.LoadPluginInfo(Filename: string; No: cardinal): boolean; -var - hLibg: THandle; - Info: pModi_PluginInfo; -// I: integer; -begin - Result := true; -// clear plugin info - ClearPluginInfo(No); - -{ -// workaround plugins loaded 2 times - for i := low(pluginpaths) to high(pluginpaths) do - if (pluginpaths[i] = filename) then - exit; -} - -// load libary - hLibg := LoadLibrary(PChar(PluginPath + Filename)); -// if loaded - if (hLibg <> 0) then - begin -// load info procedure - @Info := GetProcAddress(hLibg, PChar('PluginInfo')); - -// if loaded - if (@Info <> nil) then - begin -// load plugininfo - Info(Plugins[No]); - Result := true; - end - else - Log.LogError('Could not load plugin "' + Filename + '": Info procedure not found'); - - FreeLibrary (hLibg); - end - else - Log.LogError('Could not load plugin "' + Filename + '": Libary not loaded'); -end; - -function TDLLMan.LoadPlugin(No: cardinal): boolean; -begin - Result := true; -// load libary - hLib := LoadLibrary(PChar(PluginPath + PluginPaths[No])); -// if loaded - if (hLib <> 0) then - begin -// load info procedure - @P_Init := GetProcAddress (hLib, 'Init'); - @P_Draw := GetProcAddress (hLib, 'Draw'); - @P_Finish := GetProcAddress (hLib, 'Finish'); - -// if loaded - if (@P_Init <> nil) and (@P_Draw <> nil) and (@P_Finish <> nil) then - begin - Selected := @Plugins[No]; - Result := true; - end - else - begin - Log.LogError('Could not load plugin "' + PluginPaths[No] + '": Procedures not found'); - end; - end - else - Log.LogError('Could not load plugin "' + PluginPaths[No] + '": Libary not loaded'); -end; - -procedure TDLLMan.UnLoadPlugin; -begin - if (hLib <> 0) then - FreeLibrary (hLib); - -// Selected := nil; - @P_Init := nil; - @P_Draw := nil; - @P_Finish := nil; - @P_RData := nil; -end; - -function TDLLMan.PluginInit (const TeamInfo: TTeamInfo; - var Playerinfo: TPlayerinfo; - const Sentences: TSentences; - const LoadTex: fModi_LoadTex; - const Print: fModi_Print; - LoadSound: fModi_LoadSound; - PlaySound: pModi_PlaySound) - : boolean; -var - Methods: TMethodRec; -begin - Methods.LoadTex := LoadTex; - Methods.Print := Print; - Methods.LoadSound := LoadSound; - Methods.PlaySound := PlaySound; - - if (@P_Init <> nil) then - Result := P_Init (TeamInfo, PlayerInfo, Sentences, Methods) - else - Result := true -end; - -function TDLLMan.PluginDraw (var Playerinfo: TPlayerinfo; const CurSentence: cardinal): boolean; -begin - if (@P_Draw <> nil) then - Result := P_Draw (PlayerInfo, CurSentence) - else - Result := true -end; - -function TDLLMan.PluginFinish (var Playerinfo: TPlayerinfo): byte; -begin - if (@P_Finish <> nil) then - Result := P_Finish (PlayerInfo) - else - Result := 0; -end; - -procedure TDLLMan.PluginRData (handle: HStream; buffer: Pointer; len: dword; user: dword); -begin -if (@P_RData <> nil) then - P_RData (handle, buffer, len, user); -end; - -end. diff --git a/cmake/src/base/UDataBase.pas b/cmake/src/base/UDataBase.pas index 0f9d88a7..cccedc69 100644 --- a/cmake/src/base/UDataBase.pas +++ b/cmake/src/base/UDataBase.pas @@ -34,20 +34,22 @@ interface {$I switches.inc} uses - USongs, - USong, Classes, - SQLiteTable3; + SQLiteTable3, + UPath, + USong, + USongs, + UTextEncoding; //-------------------- -//DataBaseSystem - Class including all DB Methods +//DataBaseSystem - Class including all DB methods //-------------------- type TStatType = ( - stBestScores, // Best Scores - stBestSingers, // Best Singers - stMostSungSong, // Most sung Songs - stMostPopBand // Most popular Band + stBestScores, // Best scores + stBestSingers, // Best singers + stMostSungSong, // Most sung songs + stMostPopBand // Most popular band ); // abstract super-class for statistic results @@ -58,54 +60,57 @@ type TStatResultBestScores = class(TStatResult) public - Singer: WideString; - Score: Word; - Difficulty: Byte; - SongArtist: WideString; - SongTitle: WideString; + Singer: UTF8String; + Score: word; + Difficulty: byte; + SongArtist: UTF8String; + SongTitle: UTF8String; + Date: UTF8String; end; TStatResultBestSingers = class(TStatResult) public - Player: WideString; - AverageScore: Word; + Player: UTF8String; + AverageScore: word; end; TStatResultMostSungSong = class(TStatResult) public - Artist: WideString; - Title: WideString; - TimesSung: Word; + Artist: UTF8String; + Title: UTF8String; + TimesSung: word; end; TStatResultMostPopBand = class(TStatResult) public - ArtistName: WideString; - TimesSungTot: Word; + ArtistName: UTF8String; + TimesSungTot: word; end; - + TDataBaseSystem = class private - ScoreDB: TSQLiteDatabase; - fFilename: string; + ScoreDB: TSQLiteDatabase; + fFilename: IPath; function GetVersion(): integer; procedure SetVersion(Version: integer); public - property Filename: string read fFilename; + property Filename: IPath read fFilename; destructor Destroy; override; - procedure Init(const Filename: string); + procedure Init(const Filename: IPath); + procedure ConvertFrom101To110(); procedure ReadScore(Song: TSong); - procedure AddScore(Song: TSong; Level: integer; const Name: WideString; Score: integer); + procedure AddScore(Song: TSong; Level: integer; const Name: UTF8String; Score: integer); procedure WriteScore(Song: TSong); - function GetStats(Typ: TStatType; Count: Byte; Page: Cardinal; Reversed: Boolean): TList; + function GetStats(Typ: TStatType; Count: byte; Page: cardinal; Reversed: boolean): TList; procedure FreeStats(StatList: TList); - function GetTotalEntrys(Typ: TStatType): Cardinal; + function GetTotalEntrys(Typ: TStatType): cardinal; function GetStatReset: TDateTime; + function FormatDate(time_stamp: integer): UTF8String; end; var @@ -114,53 +119,72 @@ var implementation uses - ULog, DateUtils, + ULanguage, StrUtils, - SysUtils; - + SysUtils, + ULog; + +{ + cDBVersion - history + 0 = USDX 1.01 or no Database + 01 = USDX 1.1 +} const cDBVersion = 01; // 0.1 cUS_Scores = 'us_scores'; cUS_Songs = 'us_songs'; - cUS_Statistics_Info = 'us_statistics_info'; + cUS_Statistics_Info = 'us_statistics_info'; (** - * Opens Database and Create Tables if not Exist + * Open database and create tables if they do not exist *) -procedure TDataBaseSystem.Init(const Filename: string); +procedure TDataBaseSystem.Init(const Filename: IPath); var - Version: integer; + Version: integer; + finalizeConversion: boolean; begin if Assigned(ScoreDB) then Exit; - Log.LogStatus('Initializing database: "'+Filename+'"', 'TDataBaseSystem.Init'); + Log.LogStatus('Initializing database: "' + Filename.ToNative + '"', 'TDataBaseSystem.Init'); try - - // Open Database - ScoreDB := TSQLiteDatabase.Create(Filename); + + // open database + ScoreDB := TSQLiteDatabase.Create(Filename.ToUTF8); fFilename := Filename; - // Close and delete outdated file Version := GetVersion(); - if ((Version <> 0) and (Version <> cDBVersion)) then + + // add Table cUS_Statistics_Info + // needed in the conversion from 1.01 to 1.1 + if not ScoreDB.TableExists(cUS_Statistics_Info) then begin - Log.LogInfo('Outdated cover-database file found', 'TDataBaseSystem.Init'); - // Close and delete outdated file - ScoreDB.Free; - if (not DeleteFile(Filename)) then - raise Exception.Create('Could not delete ' + Filename); - // Reopen - ScoreDB := TSQLiteDatabase.Create(Filename); - Version := 0; + Log.LogInfo('Outdated song database found - missing table"' + cUS_Statistics_Info + '"', 'TDataBaseSystem.Init'); + ScoreDB.ExecSQL('CREATE TABLE IF NOT EXISTS [' + cUS_Statistics_Info + '] (' + + '[ResetTime] INTEGER' + + ');'); + // insert creation timestamp + ScoreDB.ExecSQL(Format('INSERT INTO [' + cUS_Statistics_Info + '] ' + + '([ResetTime]) VALUES(%d);', + [DateTimeToUnix(Now())])); end; - + + // convert data from 1.01 to 1.1 + // part #1 - prearrangement + finalizeConversion := false; + if (Version = 0) AND ScoreDB.TableExists('US_Scores') then + begin + // rename old tables - to be able to insert new table structures + ScoreDB.ExecSQL('ALTER TABLE US_Scores RENAME TO us_scores_101;'); + ScoreDB.ExecSQL('ALTER TABLE US_Songs RENAME TO us_songs_101;'); + finalizeConversion := true; // means: conversion has to be done! + end; + // Set version number after creation if (Version = 0) then SetVersion(cDBVersion); - // SQLite does not handle VARCHAR(n) or INT(n) as expected. // Texts do not have a restricted length, no matter which type is used, @@ -169,30 +193,44 @@ begin // types are used (especially FieldAsInteger). Also take care to write the // types in upper-case letters although SQLite does not care about this - // SQLiteTable3 is very sensitive in this regard. - - ScoreDB.ExecSQL('CREATE TABLE IF NOT EXISTS ['+cUS_Scores+'] (' + + ScoreDB.ExecSQL('CREATE TABLE IF NOT EXISTS [' + cUS_Scores + '] (' + '[SongID] INTEGER NOT NULL, ' + '[Difficulty] INTEGER NOT NULL, ' + '[Player] TEXT NOT NULL, ' + - '[Score] INTEGER NOT NULL' + + '[Score] INTEGER NOT NULL, ' + + '[Date] INTEGER NULL' + ');'); - ScoreDB.ExecSQL('CREATE TABLE IF NOT EXISTS ['+cUS_Songs+'] (' + + ScoreDB.ExecSQL('CREATE TABLE IF NOT EXISTS [' + cUS_Songs + '] (' + '[ID] INTEGER PRIMARY KEY, ' + '[Artist] TEXT NOT NULL, ' + '[Title] TEXT NOT NULL, ' + - '[TimesPlayed] INTEGER NOT NULL' + + '[TimesPlayed] INTEGER NOT NULL, ' + + '[Rating] INTEGER NULL' + ');'); - if not ScoreDB.TableExists(cUS_Statistics_Info) then + //add column date to cUS-Scores + if not ScoreDB.ContainsColumn(cUS_Scores, 'Date') then begin - ScoreDB.ExecSQL('CREATE TABLE IF NOT EXISTS ['+cUS_Statistics_Info+'] (' + - '[ResetTime] INTEGER' + - ');'); - // insert creation timestamp - ScoreDB.ExecSQL(Format('INSERT INTO ['+cUS_Statistics_Info+'] ' + - '([ResetTime]) VALUES(%d);', - [DateTimeToUnix(Now())])); + Log.LogInfo('adding column date to "' + cUS_Scores + '"', 'TDataBaseSystem.Init'); + ScoreDB.ExecSQL('ALTER TABLE ' + cUS_Scores + ' ADD COLUMN [Date] INTEGER NULL'); + end; + + // add column rating to cUS_Songs + // just for users of nightly builds and developers! + if not ScoreDB.ContainsColumn(cUS_Songs, 'Rating') then + begin + Log.LogInfo('Outdated song database found - adding column rating to "' + cUS_Songs + '"', 'TDataBaseSystem.Init'); + ScoreDB.ExecSQL('ALTER TABLE ' + cUS_Songs + ' ADD COLUMN [Rating] INTEGER NULL'); + end; + + // convert data from previous versions + // part #2 - accomplishment + if finalizeConversion then + begin + //convert data from 1.01 to 1.1 + if ScoreDB.TableExists('us_scores_101') then + ConvertFrom101To110(); end; except @@ -206,6 +244,115 @@ begin end; (** + * Convert Database from 1.01 to 1.1 + *) +procedure TDataBaseSystem.ConvertFrom101To110(); +var + TableData: TSQLiteUniTable; + tempUTF8String: UTF8String; +begin + if not ScoreDB.ContainsColumn('us_scores_101', 'Date') then + begin + Log.LogInfo( + 'Outdated song database found - ' + + 'begin conversion from V1.01 to V1.1', 'TDataBaseSystem.Convert101To110'); + + // insert old values into new db-schemes (/tables) + ScoreDB.ExecSQL( + 'INSERT INTO ' + cUS_Scores + + ' SELECT SongID, Difficulty, Player, Score FROM us_scores_101;'); + end else + begin + Log.LogInfo( + 'Outdated song database found - ' + + 'begin conversion from V1.01 Challenge Mod to V1.1', 'TDataBaseSystem.Convert101To110'); + + // insert old values into new db-schemes (/tables) + ScoreDB.ExecSQL( + 'INSERT INTO ' + cUS_Scores + + ' SELECT SongID, Difficulty, Player, Score, Date FROM us_scores_101;'); + end; + + ScoreDB.ExecSQL( + 'INSERT INTO ' + cUS_Songs + + ' SELECT ID, Artist, Title, TimesPlayed, ''NULL'' FROM us_songs_101;'); + + // now we have to convert all the texts for unicode support: + + // player names + TableData := nil; + try + TableData := ScoreDB.GetUniTable( + 'SELECT [rowid], [Player] ' + + 'FROM [' + cUS_Scores + '];'); + + // Go through all Entrys + while (not TableData.EOF) do + begin + // Convert name into UTF8 and alter all entrys + DecodeStringUTF8(TableData.FieldByName['Player'], tempUTF8String, encCP1252); + ScoreDB.ExecSQL( + 'UPDATE [' + cUS_Scores + '] ' + + 'SET [Player] = ? ' + + 'WHERE [rowid] = ? ', + [tempUTF8String, + TableData.FieldAsInteger(TableData.FieldIndex['rowid'])]); + + TableData.Next; + end; // while + + except + on E: Exception do + Log.LogError(E.Message, 'TDataBaseSystem.Convert101To110'); + end; + + TableData.Free; + + // song artist and song title + TableData := nil; + try + TableData := ScoreDB.GetUniTable( + 'SELECT [ID], [Artist], [Title] ' + + 'FROM [' + cUS_Songs + '];'); + + // Go through all Entrys + while (not TableData.EOF) do + begin + // Convert Artist into UTF8 and alter all entrys + DecodeStringUTF8(TableData.FieldByName['Artist'], tempUTF8String, encCP1252); + //Log.LogError(TableData.FieldByName['Artist']+' -> '+tempUTF8String+' (encCP1252)'); + ScoreDB.ExecSQL( + 'UPDATE [' + cUS_Songs + '] ' + + 'SET [Artist] = ? ' + + 'WHERE [ID] = ?', + [tempUTF8String, + TableData.FieldAsInteger(TableData.FieldIndex['ID'])]); + + // Convert Title into UTF8 and alter all entrys + DecodeStringUTF8(TableData.FieldByName['Title'], tempUTF8String, encCP1252); + ScoreDB.ExecSQL( + 'UPDATE [' + cUS_Songs + '] ' + + 'SET [Title] = ? ' + + 'WHERE [ID] = ? ', + [tempUTF8String, + TableData.FieldAsInteger(TableData.FieldIndex['ID'])]); + + TableData.Next; + end; // while + + except + on E: Exception do + Log.LogError(E.Message, 'TDataBaseSystem.Convert101To110'); + end; + + TableData.Free; + + //now drop old tables + ScoreDB.ExecSQL('DROP TABLE us_scores_101;'); + ScoreDB.ExecSQL('DROP TABLE us_songs_101;'); +end; + +(** * Frees Database *) destructor TDataBaseSystem.Destroy; @@ -216,33 +363,55 @@ begin end; (** + * Format a UNIX-Timestamp into DATE (If 0 then '') + *) +function TDataBaseSystem.FormatDate(time_stamp: integer): UTF8String; +var + Year, Month, Day: word; +begin + Result:=''; + try + if time_stamp<>0 then + begin + DecodeDate(UnixToDateTime(time_stamp), Year, Month, Day); + Result := Format(Language.Translate('STAT_FORMAT_DATE'), [Day, Month, Year]); + end; + except + on E: EConvertError do + Log.LogError('Error Parsing FormatString "STAT_FORMAT_DATE": ' + E.Message); + end; +end; + + +(** * Read Scores into SongArray *) procedure TDataBaseSystem.ReadScore(Song: TSong); var - TableData: TSQLiteUniTable; - Difficulty: Integer; + TableData: TSQLiteUniTable; + Difficulty: integer; + I: integer; + PlayerListed: boolean; begin if not Assigned(ScoreDB) then Exit; TableData := nil; - try // Search Song in DB TableData := ScoreDB.GetUniTable( - 'SELECT [Difficulty], [Player], [Score] FROM ['+cUS_Scores+'] ' + + 'SELECT [Difficulty], [Player], [Score], [Date] FROM [' + cUS_Scores + '] ' + 'WHERE [SongID] = (' + - 'SELECT [ID] FROM ['+cUS_Songs+'] ' + + 'SELECT [ID] FROM [' + cUS_Songs + '] ' + 'WHERE [Artist] = ? AND [Title] = ? ' + 'LIMIT 1) ' + - 'ORDER BY [Score] DESC LIMIT 15', - [UTF8Encode(Song.Artist), UTF8Encode(Song.Title)]); + 'ORDER BY [Score] DESC;', //no LIMIT! see filter below! + [Song.Artist, Song.Title]); // Empty Old Scores - SetLength(Song.Score[0], 0); - SetLength(Song.Score[1], 0); - SetLength(Song.Score[2], 0); + SetLength(Song.Score[0], 0); //easy + SetLength(Song.Score[1], 0); //medium + SetLength(Song.Score[2], 0); //hard // Go through all Entrys while (not TableData.EOF) do @@ -252,12 +421,31 @@ begin if ((Difficulty >= 0) and (Difficulty <= 2)) and (Length(Song.Score[Difficulty]) < 5) then begin - SetLength(Song.Score[Difficulty], Length(Song.Score[Difficulty]) + 1); + //filter player + PlayerListed:=false; + if (Length(Song.Score[Difficulty])>0) then + begin + for I := 0 to Length(Song.Score[Difficulty]) - 1 do + begin + if (Song.Score[Difficulty, I].Name = TableData.FieldByName['Player']) then + begin + PlayerListed:=true; + break; + end; + end; + end; + + if not PlayerListed then + begin + SetLength(Song.Score[Difficulty], Length(Song.Score[Difficulty]) + 1); - Song.Score[Difficulty, High(Song.Score[Difficulty])].Name := - UTF8Decode(TableData.FieldByName['Player']); - Song.Score[Difficulty, High(Song.Score[Difficulty])].Score := + Song.Score[Difficulty, High(Song.Score[Difficulty])].Name := + TableData.FieldByName['Player']; + Song.Score[Difficulty, High(Song.Score[Difficulty])].Score := TableData.FieldAsInteger(TableData.FieldIndex['Score']); + Song.Score[Difficulty, High(Song.Score[Difficulty])].Date := + FormatDate(TableData.FieldAsInteger(TableData.FieldIndex['Date'])); + end; end; TableData.Next; @@ -277,70 +465,43 @@ end; (** * Adds one new score to DB *) -procedure TDataBaseSystem.AddScore(Song: TSong; Level: integer; const Name: WideString; Score: integer); +procedure TDataBaseSystem.AddScore(Song: TSong; Level: integer; const Name: UTF8String; Score: integer); var - ID: Integer; + ID: integer; TableData: TSQLiteTable; begin if not Assigned(ScoreDB) then Exit; - // Prevent 0 Scores from being added - if (Score <= 0) then - Exit; + // Prevent 0 Scores from being added EDIT: ==> UScreenTop5.pas! + //if (Score <= 0) then + // Exit; TableData := nil; try ID := ScoreDB.GetTableValue( - 'SELECT [ID] FROM ['+cUS_Songs+'] ' + + 'SELECT [ID] FROM [' + cUS_Songs + '] ' + 'WHERE [Artist] = ? AND [Title] = ?', - [UTF8Encode(Song.Artist), UTF8Encode(Song.Title)]); + [Song.Artist, Song.Title]); if (ID = 0) then begin // Create song if it does not exist ScoreDB.ExecSQL( - 'INSERT INTO ['+cUS_Songs+'] ' + + 'INSERT INTO [' + cUS_Songs + '] ' + '([ID], [Artist], [Title], [TimesPlayed]) VALUES ' + '(NULL, ?, ?, 0);', - [UTF8Encode(Song.Artist), UTF8Encode(Song.Title)]); + [Song.Artist, Song.Title]); // Get song-ID ID := ScoreDB.GetLastInsertRowID(); end; // Create new entry ScoreDB.ExecSQL( - 'INSERT INTO ['+cUS_Scores+'] ' + - '([SongID] ,[Difficulty], [Player], [Score]) VALUES ' + - '(?, ?, ?, ?);', - [ID, Level, UTF8Encode(Name), Score]); - - // Delete last position when there are more than 5 entrys. - // Fixes crash when there are > 5 ScoreEntrys - // Note: GetUniTable is not applicable here, as the results are used while - // table entries are deleted. - TableData := ScoreDB.GetTable( - 'SELECT [Player], [Score] FROM ['+cUS_Scores+'] ' + - 'WHERE [SongID] = ' + InttoStr(ID) + ' AND ' + - '[Difficulty] = ' + InttoStr(Level) +' ' + - 'ORDER BY [Score] DESC LIMIT -1 OFFSET 5'); - - while (not TableData.EOF) do - begin - // Note: Score is an int-value, so in contrast to Player, we do not bind - // this value. Otherwise we had to convert the string to an int to avoid - // an automatic cast of this field to the TEXT type (although it might even - // work that way). - ScoreDB.ExecSQL( - 'DELETE FROM ['+cUS_Scores+'] ' + - 'WHERE [SongID] = ' + InttoStr(ID) + ' AND ' + - '[Difficulty] = ' + InttoStr(Level) +' AND ' + - '[Player] = ? AND ' + - '[Score] = ' + TableData.FieldByName['Score'], - [TableData.FieldByName['Player']]); - - TableData.Next; - end; + 'INSERT INTO [' + cUS_Scores + '] ' + + '([SongID] ,[Difficulty], [Player], [Score], [Date]) VALUES ' + + '(?, ?, ?, ?, ?);', + [ID, Level, Name, Score, DateTimeToUnix(Now())]); except on E: Exception do Log.LogError(E.Message, 'TDataBaseSystem.AddScore'); @@ -350,21 +511,21 @@ begin end; (** - * Not needed with new System. - * Used for increment played count + * Not needed with new system. + * Used to increment played count *) procedure TDataBaseSystem.WriteScore(Song: TSong); begin if not Assigned(ScoreDB) then Exit; - + try // Increase TimesPlayed ScoreDB.ExecSQL( - 'UPDATE ['+cUS_Songs+'] ' + + 'UPDATE [' + cUS_Songs + '] ' + 'SET [TimesPlayed] = [TimesPlayed] + 1 ' + 'WHERE [Title] = ? AND [Artist] = ?;', - [UTF8Encode(Song.Title), UTF8Encode(Song.Artist)]); + [Song.Title, Song.Artist]); except on E: Exception do Log.LogError(E.Message, 'TDataBaseSystem.WriteScore'); end; @@ -376,11 +537,11 @@ end; * entries. * Free the result-list with FreeStats() after usage to avoid memory leaks. *) -function TDataBaseSystem.GetStats(Typ: TStatType; Count: Byte; Page: Cardinal; Reversed: Boolean): TList; +function TDataBaseSystem.GetStats(Typ: TStatType; Count: byte; Page: cardinal; Reversed: boolean): TList; var - Query: String; + Query: string; TableData: TSQLiteUniTable; - Stat: TStatResult; + Stat: TStatResult; begin Result := nil; @@ -392,19 +553,19 @@ begin // Create query case Typ of stBestScores: begin - Query := 'SELECT [Player], [Difficulty], [Score], [Artist], [Title] FROM ['+cUS_Scores+'] ' + - 'INNER JOIN ['+cUS_Songs+'] ON ([SongID] = [ID]) ORDER BY [Score]'; + Query := 'SELECT [Player], [Difficulty], [Score], [Artist], [Title], [Date] FROM [' + cUS_Scores + '] ' + + 'INNER JOIN [' + cUS_Songs + '] ON ([SongID] = [ID]) ORDER BY [Score]'; end; stBestSingers: begin - Query := 'SELECT [Player], ROUND(AVG([Score])) FROM ['+cUS_Scores+'] ' + + Query := 'SELECT [Player], ROUND(AVG([Score])) FROM [' + cUS_Scores + '] ' + 'GROUP BY [Player] ORDER BY AVG([Score])'; end; stMostSungSong: begin - Query := 'SELECT [Artist], [Title], [TimesPlayed] FROM ['+cUS_Songs+'] ' + + Query := 'SELECT [Artist], [Title], [TimesPlayed] FROM [' + cUS_Songs + '] ' + 'ORDER BY [TimesPlayed]'; end; stMostPopBand: begin - Query := 'SELECT [Artist], SUM([TimesPlayed]) FROM ['+cUS_Songs+'] ' + + Query := 'SELECT [Artist], SUM([TimesPlayed]) FROM [' + cUS_Songs + '] ' + 'GROUP BY [Artist] ORDER BY SUM([TimesPlayed])'; end; end; @@ -437,18 +598,19 @@ begin Stat := TStatResultBestScores.Create; with TStatResultBestScores(Stat) do begin - Singer := UTF8Decode(TableData.Fields[0]); + Singer := TableData.Fields[0]; Difficulty := TableData.FieldAsInteger(1); Score := TableData.FieldAsInteger(2); - SongArtist := UTF8Decode(TableData.Fields[3]); - SongTitle := UTF8Decode(TableData.Fields[4]); + SongArtist := TableData.Fields[3]; + SongTitle := TableData.Fields[4]; + Date := FormatDate(TableData.FieldAsInteger(5)); end; end; stBestSingers: begin Stat := TStatResultBestSingers.Create; with TStatResultBestSingers(Stat) do begin - Player := UTF8Decode(TableData.Fields[0]); + Player := TableData.Fields[0]; AverageScore := TableData.FieldAsInteger(1); end; end; @@ -456,8 +618,8 @@ begin Stat := TStatResultMostSungSong.Create; with TStatResultMostSungSong(Stat) do begin - Artist := UTF8Decode(TableData.Fields[0]); - Title := UTF8Decode(TableData.Fields[1]); + Artist := TableData.Fields[0]; + Title := TableData.Fields[1]; TimesSung := TableData.FieldAsInteger(2); end; end; @@ -465,7 +627,7 @@ begin Stat := TStatResultMostPopBand.Create; with TStatResultMostPopBand(Stat) do begin - ArtistName := UTF8Decode(TableData.Fields[0]); + ArtistName := TableData.Fields[0]; TimesSungTot := TableData.FieldAsInteger(1); end; end @@ -484,21 +646,21 @@ end; procedure TDataBaseSystem.FreeStats(StatList: TList); var - I: integer; + Index: integer; begin if (StatList = nil) then Exit; - for I := 0 to StatList.Count-1 do - TStatResult(StatList[I]).Free; + for Index := 0 to StatList.Count-1 do + TStatResult(StatList[Index]).Free; StatList.Free; end; (** * Gets total number of entrys for a stats query *) -function TDataBaseSystem.GetTotalEntrys(Typ: TStatType): Cardinal; +function TDataBaseSystem.GetTotalEntrys(Typ: TStatType): cardinal; var - Query: String; + Query: string; begin Result := 0; @@ -509,13 +671,13 @@ begin // Create query case Typ of stBestScores: - Query := 'SELECT COUNT([SongID]) FROM ['+cUS_Scores+'];'; + Query := 'SELECT COUNT([SongID]) FROM [' + cUS_Scores + '];'; stBestSingers: - Query := 'SELECT COUNT(DISTINCT [Player]) FROM ['+cUS_Scores+'];'; + Query := 'SELECT COUNT(DISTINCT [Player]) FROM [' + cUS_Scores + '];'; stMostSungSong: - Query := 'SELECT COUNT([ID]) FROM ['+cUS_Songs+'];'; + Query := 'SELECT COUNT([ID]) FROM [' + cUS_Songs + '];'; stMostPopBand: - Query := 'SELECT COUNT(DISTINCT [Artist]) FROM ['+cUS_Songs+'];'; + Query := 'SELECT COUNT(DISTINCT [Artist]) FROM [' + cUS_Songs + '];'; end; Result := ScoreDB.GetTableValue(Query); @@ -538,7 +700,7 @@ begin Exit; try - Query := 'SELECT [ResetTime] FROM ['+cUS_Statistics_Info+'];'; + Query := 'SELECT [ResetTime] FROM [' + cUS_Statistics_Info + '];'; Result := UnixToDateTime(ScoreDB.GetTableValue(Query)); except on E: Exception do Log.LogError(E.Message, 'TDataBaseSystem.GetStatReset'); diff --git a/cmake/src/base/UDraw.pas b/cmake/src/base/UDraw.pas index 1783986f..308526b8 100644 --- a/cmake/src/base/UDraw.pas +++ b/cmake/src/base/UDraw.pas @@ -35,11 +35,9 @@ interface uses UThemes, - ModiSDK, UGraphicClasses; procedure SingDraw; -procedure SingModiDraw (PlayerInfo: TPlayerInfo); procedure SingDrawBackground; procedure SingDrawOscilloscope(X, Y, W, H: real; NrSound: integer); procedure SingDrawNoteLines(Left, Top, Right: real; Space: integer); @@ -86,7 +84,6 @@ uses Math, gl, TextGL, - UDLLManager, UDrawTexture, UGraphic, UIni, @@ -96,7 +93,6 @@ uses UMusic, URecord, UScreenSing, - UScreenSingModi, UTexture; procedure SingDrawBackground; @@ -258,19 +254,21 @@ begin // So we exploit this behavior a bit - we give NrLines the playernumber, keep it in playernumber - and then we set NrLines to zero // This could also come quite in handy when we do the duet mode, cause just the notes for the player that has to sing should be drawn then // BUT this is not implemented yet, all notes are drawn! :D + if (ScreenSing.settings.NotesVisible and (1 shl NrLines) <> 0) then + begin - PlayerNumber := NrLines + 1; // Player 1 is 0 - NrLines := 0; + PlayerNumber := NrLines + 1; // Player 1 is 0 + NrLines := 0; -// exploit done + // exploit done - glColor3f(1, 1, 1); - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); + glColor3f(1, 1, 1); + glEnable(GL_TEXTURE_2D); + glEnable(GL_BLEND); + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - lTmpA := (Right-Left); - lTmpB := (Lines[NrLines].Line[Lines[NrLines].Current].End_ - Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start); + lTmpA := (Right-Left); + lTmpB := (Lines[NrLines].Line[Lines[NrLines].Current].End_ - Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start); if ( lTmpA > 0 ) and ( lTmpB > 0 ) then TempR := lTmpA / lTmpB @@ -285,16 +283,17 @@ begin begin if NoteType <> ntFreestyle then begin - if Ini.EffectSing = 0 then - // If Golden note Effect of then Change not Color - begin - case NoteType of - ntNormal: glColor4f(1, 1, 1, 1); // We set alpha to 1, cause we can control the transparency through the png itself - ntGolden: glColor4f(1, 1, 0.3, 1); // no stars, paint yellow -> glColor4f(1, 1, 0.3, 0.85); - we could + + if Ini.EffectSing = 0 then + // If Golden note Effect of then Change not Color + begin + case NoteType of + ntNormal: glColor4f(1, 1, 1, 1); // We set alpha to 1, cause we can control the transparency through the png itself + ntGolden: glColor4f(1, 1, 0.3, 1); // no stars, paint yellow -> glColor4f(1, 1, 0.3, 0.85); - we could end; // case - end //Else all Notes same Color - else - glColor4f(1, 1, 1, 1); // We set alpha to 1, cause we can control the transparency through the png itself + end //Else all Notes same Color + else + glColor4f(1, 1, 1, 1); // We set alpha to 1, cause we can control the transparency through the png itself // left part Rec.Left := (Start-Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start) * TempR + Left + 0.5 + 10*ScreenX; @@ -309,35 +308,35 @@ begin glTexCoord2f(1, 0); glVertex2f(Rec.Right, Rec.Top); glEnd; - //We keep the postion of the top left corner b4 it's overwritten + //We keep the postion of the top left corner b4 it's overwritten GoldenStarPos := Rec.Left; - //done + //done - // middle part - Rec.Left := Rec.Right; - Rec.Right := (Start+Length-Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start) * TempR + Left - NotesW - 0.5 + 10*ScreenX; + // middle part + Rec.Left := Rec.Right; + Rec.Right := (Start+Length-Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start) * TempR + Left - NotesW - 0.5 + 10*ScreenX; - glBindTexture(GL_TEXTURE_2D, Tex_plain_Mid[PlayerNumber].TexNum); - glTexParameterf( GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT ); - glTexParameterf( GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT ); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(round((Rec.Right-Rec.Left)/32), 1); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(round((Rec.Right-Rec.Left)/32), 0); glVertex2f(Rec.Right, Rec.Top); - glEnd; + glBindTexture(GL_TEXTURE_2D, Tex_plain_Mid[PlayerNumber].TexNum); + glTexParameterf( GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT ); + glTexParameterf( GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT ); + glBegin(GL_QUADS); + glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); + glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); + glTexCoord2f(round((Rec.Right-Rec.Left)/32), 1); glVertex2f(Rec.Right, Rec.Bottom); + glTexCoord2f(round((Rec.Right-Rec.Left)/32), 0); glVertex2f(Rec.Right, Rec.Top); + glEnd; // right part Rec.Left := Rec.Right; Rec.Right := Rec.Right + NotesW; - glBindTexture(GL_TEXTURE_2D, Tex_plain_Right[PlayerNumber].TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(1, 1); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(1, 0); glVertex2f(Rec.Right, Rec.Top); - glEnd; + glBindTexture(GL_TEXTURE_2D, Tex_plain_Right[PlayerNumber].TexNum); + glBegin(GL_QUADS); + glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); + glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); + glTexCoord2f(1, 1); glVertex2f(Rec.Right, Rec.Bottom); + glTexCoord2f(1, 0); glVertex2f(Rec.Right, Rec.Top); + glEnd; // Golden Star Patch if (NoteType = ntGolden) and (Ini.EffectSing=1) then @@ -345,13 +344,14 @@ begin GoldenRec.SaveGoldenStarsRec(GoldenStarPos, Rec.Top, Rec.Right, Rec.Bottom); end; - end; // if not FreeStyle - end; // with - end; // for - end; // with + end; // if not FreeStyle + end; // with + end; // for + end; // with - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); + glDisable(GL_BLEND); + glDisable(GL_TEXTURE_2D); + end; end; // draw sung notes @@ -481,7 +481,7 @@ var W, H: real; lTmpA, lTmpB: real; begin - if (Player[PlayerIndex].ScoreTotalInt >= 0) then + if (ScreenSing.settings.NotesVisible and (1 shl PlayerIndex) <> 0) then begin glColor4f(1, 1, 1, sqrt((1+sin( AudioPlayback.Position * 3))/4)/ 2 + 0.5 ); glEnable(GL_TEXTURE_2D); @@ -683,20 +683,25 @@ begin // draw note-lines - if (PlayersPlay = 1) and (Ini.NoteLines = 1) then + // to-do : needs fix when party mode works w/ 2 screens + if (PlayersPlay = 1) and (Ini.NoteLines = 1) and (ScreenSing.settings.NotesVisible and (1) <> 0) then SingDrawNoteLines(NR.Left + 10*ScreenX, Skin_P2_NotesB - 105, NR.Right + 10*ScreenX, 15); if ((PlayersPlay = 2) or (PlayersPlay = 4)) and (Ini.NoteLines = 1) then begin - SingDrawNoteLines(NR.Left + 10*ScreenX, Skin_P1_NotesB - 105, NR.Right + 10*ScreenX, 15); - SingDrawNoteLines(NR.Left + 10*ScreenX, Skin_P2_NotesB - 105, NR.Right + 10*ScreenX, 15); + if (ScreenSing.settings.NotesVisible and (1 shl 0) <> 0) then + SingDrawNoteLines(Nr.Left + 10*ScreenX, Skin_P1_NotesB - 105, Nr.Right + 10*ScreenX, 15); + if (ScreenSing.settings.NotesVisible and (1 shl 1) <> 0) then + SingDrawNoteLines(Nr.Left + 10*ScreenX, Skin_P2_NotesB - 105, Nr.Right + 10*ScreenX, 15); end; - if ((PlayersPlay = 3) or (PlayersPlay = 6)) and (Ini.NoteLines = 1) then - begin - SingDrawNoteLines(NR.Left + 10*ScreenX, 120, NR.Right + 10*ScreenX, 12); - SingDrawNoteLines(NR.Left + 10*ScreenX, 245, NR.Right + 10*ScreenX, 12); - SingDrawNoteLines(NR.Left + 10*ScreenX, 370, NR.Right + 10*ScreenX, 12); + if ((PlayersPlay = 3) or (PlayersPlay = 6)) and (Ini.NoteLines = 1) then begin + if (ScreenSing.settings.NotesVisible and (1 shl 0) <> 0) then + SingDrawNoteLines(Nr.Left + 10*ScreenX, 120, Nr.Right + 10*ScreenX, 12); + if (ScreenSing.settings.NotesVisible and (1 shl 1) <> 0) then + SingDrawNoteLines(Nr.Left + 10*ScreenX, 245, Nr.Right + 10*ScreenX, 12); + if (ScreenSing.settings.NotesVisible and (1 shl 2) <> 0) then + SingDrawNoteLines(Nr.Left + 10*ScreenX, 370, Nr.Right + 10*ScreenX, 12); end; // draw Lyrics @@ -895,259 +900,6 @@ begin glDisable(GL_TEXTURE_2D); end; -// q'n'd for using the game mode dll's -procedure SingModiDraw (PlayerInfo: TPlayerInfo); -var - NR: TRecR; -begin - // positions - if Ini.SingWindow = 0 then - begin - NR.Left := 120; - end - else - begin - NR.Left := 20; - end; - - NR.Right := 780; - NR.Width := NR.Right - NR.Left; - NR.WMid := NR.Width / 2; - NR.Mid := NR.Left + NR.WMid; - - // time bar - SingDrawTimeBar(); - - if DLLMan.Selected.ShowNotes then - begin - if PlayersPlay = 1 then - SingDrawNoteLines(NR.Left + 10*ScreenX, Skin_P2_NotesB - 105, NR.Right + 10*ScreenX, 15); - if (PlayersPlay = 2) or (PlayersPlay = 4) then - begin - SingDrawNoteLines(NR.Left + 10*ScreenX, Skin_P1_NotesB - 105, NR.Right + 10*ScreenX, 15); - SingDrawNoteLines(NR.Left + 10*ScreenX, Skin_P2_NotesB - 105, NR.Right + 10*ScreenX, 15); - end; - - if (PlayersPlay = 3) or (PlayersPlay = 6) then - begin - SingDrawNoteLines(NR.Left + 10*ScreenX, 120, NR.Right + 10*ScreenX, 12); - SingDrawNoteLines(NR.Left + 10*ScreenX, 245, NR.Right + 10*ScreenX, 12); - SingDrawNoteLines(NR.Left + 10*ScreenX, 370, NR.Right + 10*ScreenX, 12); - end; - end; - - // Draw Lyrics - ScreenSingModi.Lyrics.Draw(LyricsState.MidBeat); - // TODO: Lyrics helper - - // oscilloscope | the thing that moves when you yell into your mic (imho) - if (((Ini.Oscilloscope = 1) and (DLLMan.Selected.ShowRateBar_O)) and (not DLLMan.Selected.ShowRateBar)) then - begin - if PlayersPlay = 1 then - if PlayerInfo.Playerinfo[0].Enabled then - SingDrawOscilloscope(190 + 10*ScreenX, 55, 180, 40, 0); - - if PlayersPlay = 2 then - begin - if PlayerInfo.Playerinfo[0].Enabled then - SingDrawOscilloscope(190 + 10*ScreenX, 55, 180, 40, 0); - if PlayerInfo.Playerinfo[1].Enabled then - SingDrawOscilloscope(425 + 10*ScreenX, 55, 180, 40, 1); - end; - - if PlayersPlay = 4 then - begin - if ScreenAct = 1 then - begin - if PlayerInfo.Playerinfo[0].Enabled then - SingDrawOscilloscope(190 + 10*ScreenX, 55, 180, 40, 0); - if PlayerInfo.Playerinfo[1].Enabled then - SingDrawOscilloscope(425 + 10*ScreenX, 55, 180, 40, 1); - end; - if ScreenAct = 2 then - begin - if PlayerInfo.Playerinfo[2].Enabled then - SingDrawOscilloscope(190 + 10*ScreenX, 55, 180, 40, 2); - if PlayerInfo.Playerinfo[3].Enabled then - SingDrawOscilloscope(425 + 10*ScreenX, 55, 180, 40, 3); - end; - end; - - if PlayersPlay = 3 then - begin - if PlayerInfo.Playerinfo[0].Enabled then - SingDrawOscilloscope( 75 + 10*ScreenX, 95, 100, 20, 0); - if PlayerInfo.Playerinfo[1].Enabled then - SingDrawOscilloscope(370 + 10*ScreenX, 95, 100, 20, 1); - if PlayerInfo.Playerinfo[2].Enabled then - SingDrawOscilloscope(670 + 10*ScreenX, 95, 100, 20, 2); - end; - - if PlayersPlay = 6 then - begin - if ScreenAct = 1 then - begin - if PlayerInfo.Playerinfo[0].Enabled then - SingDrawOscilloscope( 75 + 10*ScreenX, 95, 100, 20, 0); - if PlayerInfo.Playerinfo[1].Enabled then - SingDrawOscilloscope(370 + 10*ScreenX, 95, 100, 20, 1); - if PlayerInfo.Playerinfo[2].Enabled then - SingDrawOscilloscope(670 + 10*ScreenX, 95, 100, 20, 2); - end; - if ScreenAct = 2 then - begin - if PlayerInfo.Playerinfo[3].Enabled then - SingDrawOscilloscope( 75 + 10*ScreenX, 95, 100, 20, 3); - if PlayerInfo.Playerinfo[4].Enabled then - SingDrawOscilloscope(370 + 10*ScreenX, 95, 100, 20, 4); - if PlayerInfo.Playerinfo[5].Enabled then - SingDrawOscilloscope(670 + 10*ScreenX, 95, 100, 20, 5); - end; - end; - - end; - -// resize the notes according to the difficulty level - case Ini.Difficulty of - 0: - begin - NotesH := 11; // 9 - NotesW := 6; // 5 - end; - 1: - begin - NotesH := 8; // 7 - NotesW := 4; // 4 - end; - 2: - begin - NotesH := 5; - NotesW := 3; - end; - end; - - if (DLLMAn.Selected.ShowNotes and DLLMan.Selected.LoadSong) then - begin - if (PlayersPlay = 1) and PlayerInfo.Playerinfo[0].Enabled then - begin - SingDrawPlayerBGLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 0, 15); - SingDrawLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 15); - SingDrawPlayerLine(NR.Left + 20, Skin_P2_NotesB, NR.Width - 40, 0, 15); - end; - - if PlayersPlay = 2 then - begin - if PlayerInfo.Playerinfo[0].Enabled then - begin - SingDrawPlayerBGLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 0, 15); - SingDrawLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 15); - SingDrawPlayerLine(NR.Left + 20, Skin_P1_NotesB, NR.Width - 40, 0, 15); - end; - if PlayerInfo.Playerinfo[1].Enabled then - begin - SingDrawPlayerBGLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 1, 15); - SingDrawLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 15); - SingDrawPlayerLine(NR.Left + 20, Skin_P2_NotesB, NR.Width - 40, 1, 15); - end; - - end; - - if PlayersPlay = 3 then - begin - NotesW := NotesW * 0.8; - NotesH := NotesH * 0.8; - - if PlayerInfo.Playerinfo[0].Enabled then - begin - SingDrawPlayerBGLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 0, 12); - SingDrawLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 12); - SingDrawPlayerLine(NR.Left + 20, 120+95, NR.Width - 40, 0, 12); - end; - - if PlayerInfo.Playerinfo[1].Enabled then - begin - SingDrawPlayerBGLine(NR.Left + 20, 245+95, NR.Right - 20, 0, 1, 12); - SingDrawLine(NR.Left + 20, 245+95, NR.Right - 20, 0, 12); - SingDrawPlayerLine(NR.Left + 20, 245+95, NR.Width - 40, 1, 12); - end; - - if PlayerInfo.Playerinfo[2].Enabled then - begin - SingDrawPlayerBGLine(NR.Left + 20, 370+95, NR.Right - 20, 0, 2, 12); - SingDrawLine(NR.Left + 20, 370+95, NR.Right - 20, 0, 12); - SingDrawPlayerLine(NR.Left + 20, 370+95, NR.Width - 40, 2, 12); - end; - end; - - if PlayersPlay = 4 then - begin - if ScreenAct = 1 then - begin - SingDrawPlayerBGLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 0, 15); - SingDrawPlayerBGLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 1, 15); - end; - if ScreenAct = 2 then - begin - SingDrawPlayerBGLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 2, 15); - SingDrawPlayerBGLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 3, 15); - end; - - SingDrawLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 15); - SingDrawLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 15); - - if ScreenAct = 1 then - begin - SingDrawPlayerLine(NR.Left + 20, Skin_P1_NotesB, NR.Width - 40, 0, 15); - SingDrawPlayerLine(NR.Left + 20, Skin_P2_NotesB, NR.Width - 40, 1, 15); - end; - if ScreenAct = 2 then - begin - SingDrawPlayerLine(NR.Left + 20, Skin_P1_NotesB, NR.Width - 40, 2, 15); - SingDrawPlayerLine(NR.Left + 20, Skin_P2_NotesB, NR.Width - 40, 3, 15); - end; - end; - - if PlayersPlay = 6 then - begin - NotesW := NotesW * 0.8; - NotesH := NotesH * 0.8; - - if ScreenAct = 1 then - begin - SingDrawPlayerBGLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 0, 12); - SingDrawPlayerBGLine(NR.Left + 20, 245+95, NR.Right - 20, 0, 1, 12); - SingDrawPlayerBGLine(NR.Left + 20, 370+95, NR.Right - 20, 0, 2, 12); - end; - if ScreenAct = 2 then - begin - SingDrawPlayerBGLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 3, 12); - SingDrawPlayerBGLine(NR.Left + 20, 245+95, NR.Right - 20, 0, 4, 12); - SingDrawPlayerBGLine(NR.Left + 20, 370+95, NR.Right - 20, 0, 5, 12); - end; - - SingDrawLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 12); - SingDrawLine(NR.Left + 20, 245+95, NR.Right - 20, 0, 12); - SingDrawLine(NR.Left + 20, 370+95, NR.Right - 20, 0, 12); - - if ScreenAct = 1 then - begin - SingDrawPlayerLine(NR.Left + 20, 120+95, NR.Width - 40, 0, 12); - SingDrawPlayerLine(NR.Left + 20, 245+95, NR.Width - 40, 1, 12); - SingDrawPlayerLine(NR.Left + 20, 370+95, NR.Width - 40, 2, 12); - end; - if ScreenAct = 2 then - begin - SingDrawPlayerLine(NR.Left + 20, 120+95, NR.Width - 40, 3, 12); - SingDrawPlayerLine(NR.Left + 20, 245+95, NR.Width - 40, 4, 12); - SingDrawPlayerLine(NR.Left + 20, 370+95, NR.Width - 40, 5, 12); - end; - end; - end; - - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); -end; - {//SingBar Mod procedure SingDrawSingbar(X, Y, W, H: real; Percent: integer); var diff --git a/cmake/src/base/UEditorLyrics.pas b/cmake/src/base/UEditorLyrics.pas index ef9d8dd6..0eacd1f9 100644 --- a/cmake/src/base/UEditorLyrics.pas +++ b/cmake/src/base/UEditorLyrics.pas @@ -74,7 +74,7 @@ type procedure SetSize(Value: real); procedure SetSelected(Value: integer); procedure SetFontStyle(Value: integer); - procedure AddWord(Text: string); + procedure AddWord(Text: UTF8String); procedure Refresh; public ColR: real; @@ -179,7 +179,7 @@ begin FontStyleI := Value; end; -procedure TEditorLyrics.AddWord(Text: string); +procedure TEditorLyrics.AddWord(Text: UTF8String); var WordNum: integer; begin diff --git a/cmake/src/base/UFiles.pas b/cmake/src/base/UFiles.pas index 0495dfbb..5a258e3e 100644 --- a/cmake/src/base/UFiles.pas +++ b/cmake/src/base/UFiles.pas @@ -34,24 +34,23 @@ interface uses SysUtils, + Classes, ULog, UMusic, USongs, - USong; + USong, + UPath; procedure ResetSingTemp; -function SaveSong(Song: TSong; Lines: TLines; Name: string; Relative: boolean): boolean; +type + TSaveSongResult = (ssrOK, ssrFileError, ssrEncodingError); -var - SongFile: TextFile; // all procedures in this unit operates on this file - FileLineNo: integer; //Line which is readed at Last, for error reporting - - // variables available for all procedures - Base : array[0..1] of integer; - Rel : array[0..1] of integer; - Mult : integer = 1; - MultBPM : integer = 4; +{** + * Throws a TEncodingException if the song's fields cannot be encoded in the + * requested encoding. + *} +function SaveSong(const Song: TSong; const Lines: TLines; const Name: IPath; Relative: boolean): TSaveSongResult; implementation @@ -59,7 +58,9 @@ uses TextGL, UIni, UNote, - UPlatform; + UPlatform, + UUnicodeUtils, + UTextEncoding; //-------------------- // Resets the temporary Sentence Arrays for each Player and some other Variables @@ -77,101 +78,135 @@ begin Player[Count].LengthNote := 0; Player[Count].HighNote := -1; end; - - (* FIXME - //Reset Path and Filename Values to Prevent Errors in Editor - if assigned( CurrentSong ) then - begin - SetLength(CurrentSong.BPM, 0); - CurrentSong.Path := ''; - CurrentSong.FileName := ''; - end; - *) - -// CurrentSong := nil; end; - //-------------------- // Saves a Song //-------------------- -function SaveSong(Song: TSong; Lines: TLines; Name: string; Relative: boolean): boolean; +function SaveSong(const Song: TSong; const Lines: TLines; const Name: IPath; Relative: boolean): TSaveSongResult; var C: integer; N: integer; - S: string; + S: AnsiString; B: integer; - RelativeSubTime: integer; - NoteState: String; + RelativeSubTime: integer; + NoteState: AnsiString; + SongFile: TTextFileStream; -begin -// Relative := true; // override (idea - use shift+S to save with relative) - AssignFile(SongFile, Name); - Rewrite(SongFile); - - Writeln(SongFile, '#TITLE:' + Song.Title + ''); - Writeln(SongFile, '#ARTIST:' + Song.Artist); - - if Song.Creator <> '' then Writeln(SongFile, '#CREATOR:' + Song.Creator); - if Song.Edition <> 'Unknown' then Writeln(SongFile, '#EDITION:' + Song.Edition); - if Song.Genre <> 'Unknown' then Writeln(SongFile, '#GENRE:' + Song.Genre); - if Song.Language <> 'Unknown' then Writeln(SongFile, '#LANGUAGE:' + Song.Language); - - Writeln(SongFile, '#MP3:' + Song.Mp3); - - if Song.Cover <> '' then Writeln(SongFile, '#COVER:' + Song.Cover); - if Song.Background <> '' then Writeln(SongFile, '#BACKGROUND:' + Song.Background); - if Song.Video <> '' then Writeln(SongFile, '#VIDEO:' + Song.Video); - if Song.VideoGAP <> 0 then Writeln(SongFile, '#VIDEOGAP:' + FloatToStr(Song.VideoGAP)); - if Song.Resolution <> 4 then Writeln(SongFile, '#RESOLUTION:' + IntToStr(Song.Resolution)); - if Song.NotesGAP <> 0 then Writeln(SongFile, '#NOTESGAP:' + IntToStr(Song.NotesGAP)); - if Song.Start <> 0 then Writeln(SongFile, '#START:' + FloatToStr(Song.Start)); - if Song.Finish <> 0 then Writeln(SongFile, '#END:' + IntToStr(Song.Finish)); - if Relative then Writeln(SongFile, '#RELATIVE:yes'); - - Writeln(SongFile, '#BPM:' + FloatToStr(Song.BPM[0].BPM / 4)); - Writeln(SongFile, '#GAP:' + FloatToStr(Song.GAP)); - - RelativeSubTime := 0; - for B := 1 to High(CurrentSong.BPM) do - Writeln(SongFile, 'B ' + FloatToStr(CurrentSong.BPM[B].StartBeat) + ' ' + FloatToStr(CurrentSong.BPM[B].BPM/4)); - - for C := 0 to Lines.High do begin - for N := 0 to Lines.Line[C].HighNote do begin - with Lines.Line[C].Note[N] do begin - - - //Golden + Freestyle Note Patch - case Lines.Line[C].Note[N].NoteType of - ntFreestyle: NoteState := 'F '; - ntNormal: NoteState := ': '; - ntGolden: NoteState := '* '; - end; // case - S := NoteState + IntToStr(Start-RelativeSubTime) + ' ' + IntToStr(Length) + ' ' + IntToStr(Tone) + ' ' + Text; - - - Writeln(SongFile, S); - end; // with - end; // N - - if C < Lines.High then begin // don't write end of last sentence - if not Relative then - S := '- ' + IntToStr(Lines.Line[C+1].Start) - else begin - S := '- ' + IntToStr(Lines.Line[C+1].Start - RelativeSubTime) + - ' ' + IntToStr(Lines.Line[C+1].Start - RelativeSubTime); - RelativeSubTime := Lines.Line[C+1].Start; - end; - Writeln(SongFile, S); - end; + function EncodeToken(const Str: UTF8String): RawByteString; + var + Success: boolean; + begin + Success := EncodeStringUTF8(Str, Result, Song.Encoding); + if (not Success) then + SaveSong := ssrEncodingError; + end; - end; // C + procedure WriteCustomTags; + var + I: integer; + Line: RawByteString; + begin + for I := 0 to High(Song.CustomTags) do + begin + Line := EncodeToken(Song.CustomTags[I].Content); + if (Length(Song.CustomTags[I].Tag) > 0) then + Line := EncodeToken(Song.CustomTags[I].Tag) + ':' + Line; + SongFile.WriteLine('#' + Line); + end; - Writeln(SongFile, 'E'); - CloseFile(SongFile); + end; - Result := true; +begin + // Relative := true; // override (idea - use shift+S to save with relative) + Result := ssrOK; + + try + SongFile := TMemTextFileStream.Create(Name, fmCreate); + try + // to-do: should we really write the BOM? + // it causes problems w/ older versions + // e.g. usdx 1.0.1a or ultrastar < 0.7.0 + if (Song.Encoding = encUTF8) then + SongFile.WriteString(UTF8_BOM); + + SongFile.WriteLine('#ENCODING:' + EncodingName(Song.Encoding)); + SongFile.WriteLine('#TITLE:' + EncodeToken(Song.Title)); + SongFile.WriteLine('#ARTIST:' + EncodeToken(Song.Artist)); + + if Song.Creator <> '' then SongFile.WriteLine('#CREATOR:' + EncodeToken(Song.Creator)); + if Song.Edition <> 'Unknown' then SongFile.WriteLine('#EDITION:' + EncodeToken(Song.Edition)); + if Song.Genre <> 'Unknown' then SongFile.WriteLine('#GENRE:' + EncodeToken(Song.Genre)); + if Song.Language <> 'Unknown' then SongFile.WriteLine('#LANGUAGE:' + EncodeToken(Song.Language)); + if Song.Year <> 0 then SongFile.WriteLine('#YEAR:' + IntToStr(Song.Year)); + + SongFile.WriteLine('#MP3:' + EncodeToken(Song.Mp3.ToUTF8)); + if Song.Cover.IsSet then SongFile.WriteLine('#COVER:' + EncodeToken(Song.Cover.ToUTF8)); + if Song.Background.IsSet then SongFile.WriteLine('#BACKGROUND:' + EncodeToken(Song.Background.ToUTF8)); + if Song.Video.IsSet then SongFile.WriteLine('#VIDEO:' + EncodeToken(Song.Video.ToUTF8)); + + if Song.VideoGAP <> 0 then SongFile.WriteLine('#VIDEOGAP:' + FloatToStr(Song.VideoGAP)); + if Song.Resolution <> 4 then SongFile.WriteLine('#RESOLUTION:' + IntToStr(Song.Resolution)); + if Song.NotesGAP <> 0 then SongFile.WriteLine('#NOTESGAP:' + IntToStr(Song.NotesGAP)); + if Song.Start <> 0 then SongFile.WriteLine('#START:' + FloatToStr(Song.Start)); + if Song.Finish <> 0 then SongFile.WriteLine('#END:' + IntToStr(Song.Finish)); + if Relative then SongFile.WriteLine('#RELATIVE:yes'); + + SongFile.WriteLine('#BPM:' + FloatToStr(Song.BPM[0].BPM / 4)); + SongFile.WriteLine('#GAP:' + FloatToStr(Song.GAP)); + + // write custom header tags + WriteCustomTags; + + RelativeSubTime := 0; + for B := 1 to High(Song.BPM) do + SongFile.WriteLine('B ' + FloatToStr(Song.BPM[B].StartBeat) + ' ' + + FloatToStr(Song.BPM[B].BPM/4)); + + for C := 0 to Lines.High do + begin + for N := 0 to Lines.Line[C].HighNote do + begin + with Lines.Line[C].Note[N] do + begin + //Golden + Freestyle Note Patch + case Lines.Line[C].Note[N].NoteType of + ntFreestyle: NoteState := 'F '; + ntNormal: NoteState := ': '; + ntGolden: NoteState := '* '; + end; // case + S := NoteState + IntToStr(Start-RelativeSubTime) + ' ' + + IntToStr(Length) + ' ' + + IntToStr(Tone) + ' ' + + EncodeToken(Text); + + SongFile.WriteLine(S); + end; // with + end; // N + + if C < Lines.High then // don't write end of last sentence + begin + if not Relative then + S := '- ' + IntToStr(Lines.Line[C+1].Start) + else + begin + S := '- ' + IntToStr(Lines.Line[C+1].Start - RelativeSubTime) + + ' ' + IntToStr(Lines.Line[C+1].Start - RelativeSubTime); + RelativeSubTime := Lines.Line[C+1].Start; + end; + SongFile.WriteLine(S); + end; + end; // C + + SongFile.WriteLine('E'); + finally + SongFile.Free; + end; + except + Result := ssrFileError; + end; end; end. + diff --git a/cmake/src/base/UFilesystem.pas b/cmake/src/base/UFilesystem.pas new file mode 100644 index 00000000..805bcfe5 --- /dev/null +++ b/cmake/src/base/UFilesystem.pas @@ -0,0 +1,692 @@ +{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +unit UFilesystem; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + SysUtils, + Classes, + {$IFDEF MSWINDOWS} + Windows, + TntSysUtils, + {$ENDIF} + UPath; + +type + {$IFDEF MSWINDOWS} + TSytemSearchRec = TSearchRecW; + {$ELSE} + TSytemSearchRec = TSearchRec; + {$ENDIF} + + TFileInfo = record + Time: integer; // timestamp + Size: int64; // file size (byte) + Attr: integer; // file attributes + Name: IPath; // basename with extension + end; + + {** + * Iterates through the search results retrieved by FileFind(). + * Example usage: + * while(Iter.HasNext()) do + * SearchRec := Iter.Next(); + *} + IFileIterator = interface + function HasNext(): boolean; + function Next(): TFileInfo; + end; + + {** + * Wrapper for SysUtils file functions. + * For documentation and examples, check the SysUtils equivalent. + *} + IFileSystem = interface + function ExpandFileName(const FileName: IPath): IPath; + function FileCreate(const FileName: IPath): TFileHandle; + function DirectoryCreate(const Dir: IPath): boolean; + function FileOpen(const FileName: IPath; Mode: longword): TFileHandle; + function FileAge(const FileName: IPath): integer; overload; + function FileAge(const FileName: IPath; out FileDateTime: TDateTime): boolean; overload; + + function DirectoryExists(const Name: IPath): boolean; + + {** + * On Windows: returns true only for files (not directories) + * On Apple/Unix: returns true for all kind of files (even directories) + * @seealso SysUtils.FileExists() + *} + function FileExists(const Name: IPath): boolean; + + function FileGetAttr(const FileName: IPath): Cardinal; + function FileSetAttr(const FileName: IPath; Attr: integer): boolean; + function FileIsReadOnly(const FileName: IPath): boolean; + function FileSetReadOnly(const FileName: IPath; ReadOnly: boolean): boolean; + function FileIsAbsolute(const FileName: IPath): boolean; + function ForceDirectories(const Dir: IPath): boolean; + function RenameFile(const OldName, NewName: IPath): boolean; + function DeleteFile(const FileName: IPath): boolean; + function RemoveDir(const Dir: IPath): boolean; + + {** + * Copies file Source to Target. If FailIfExists is true, the file is not + * copied if it already exists. + * Returns true if the file was successfully copied. + *} + function CopyFile(const Source, Target: IPath; FailIfExists: boolean): boolean; + + function ExtractFileDrive(const FileName: IPath): IPath; + function ExtractFilePath(const FileName: IPath): IPath; + function ExtractFileDir(const FileName: IPath): IPath; + function ExtractFileName(const FileName: IPath): IPath; + function ExtractFileExt(const FileName: IPath): IPath; + function ExtractRelativePath(const BaseName: IPath; const FileName: IPath): IPath; + + function ChangeFileExt(const FileName: IPath; const Extension: IPath): IPath; + + function IncludeTrailingPathDelimiter(const FileName: IPath): IPath; + function ExcludeTrailingPathDelimiter(const FileName: IPath): IPath; + + {** + * Searches for a file with filename Name in the directories given in DirList. + *} + function FileSearch(const Name: IPath; DirList: array of IPath): IPath; + + {** + * More convenient version of FindFirst/Next/Close with iterator support. + *} + function FileFind(const FilePattern: IPath; Attr: integer): IFileIterator; + + {** + * Old style search functions. Use FileFind() instead. + *} + function FindFirst(const FilePattern: IPath; Attr: integer; var F: TSytemSearchRec): integer; + function FindNext(var F: TSytemSearchRec): integer; + procedure FindClose(var F: TSytemSearchRec); + + function GetCurrentDir: IPath; + function SetCurrentDir(const Dir: IPath): boolean; + + {** + * Returns true if the filesystem is case-sensitive. + *} + function IsCaseSensitive(): boolean; + end; + + function FileSystem(): IFileSystem; + +implementation + +type + TFileSystemImpl = class(TInterfacedObject, IFileSystem) + public + function ExpandFileName(const FileName: IPath): IPath; + function FileCreate(const FileName: IPath): TFileHandle; + function DirectoryCreate(const Dir: IPath): boolean; + function FileOpen(const FileName: IPath; Mode: longword): TFileHandle; + function FileAge(const FileName: IPath): integer; overload; + function FileAge(const FileName: IPath; out FileDateTime: TDateTime): boolean; overload; + function DirectoryExists(const Name: IPath): boolean; + function FileExists(const Name: IPath): boolean; + function FileGetAttr(const FileName: IPath): Cardinal; + function FileSetAttr(const FileName: IPath; Attr: integer): boolean; + function FileIsReadOnly(const FileName: IPath): boolean; + function FileSetReadOnly(const FileName: IPath; ReadOnly: boolean): boolean; + function FileIsAbsolute(const FileName: IPath): boolean; + function ForceDirectories(const Dir: IPath): boolean; + function RenameFile(const OldName, NewName: IPath): boolean; + function DeleteFile(const FileName: IPath): boolean; + function RemoveDir(const Dir: IPath): boolean; + function CopyFile(const Source, Target: IPath; FailIfExists: boolean): boolean; + + function ExtractFileDrive(const FileName: IPath): IPath; + function ExtractFilePath(const FileName: IPath): IPath; + function ExtractFileDir(const FileName: IPath): IPath; + function ExtractFileName(const FileName: IPath): IPath; + function ExtractFileExt(const FileName: IPath): IPath; + function ExtractRelativePath(const BaseName: IPath; const FileName: IPath): IPath; + function ChangeFileExt(const FileName: IPath; const Extension: IPath): IPath; + function IncludeTrailingPathDelimiter(const FileName: IPath): IPath; + function ExcludeTrailingPathDelimiter(const FileName: IPath): IPath; + + function FileSearch(const Name: IPath; DirList: array of IPath): IPath; + function FileFind(const FilePattern: IPath; Attr: integer): IFileIterator; + + function FindFirst(const FilePattern: IPath; Attr: integer; var F: TSytemSearchRec): integer; + function FindNext(var F: TSytemSearchRec): integer; + procedure FindClose(var F: TSytemSearchRec); + + function GetCurrentDir: IPath; + function SetCurrentDir(const Dir: IPath): boolean; + + function IsCaseSensitive(): boolean; + end; + + TFileIterator = class(TInterfacedObject, IFileIterator) + private + fHasNext: boolean; + fSearchRec: TSytemSearchRec; + public + constructor Create(const FilePattern: IPath; Attr: integer); + destructor Destroy(); override; + + function HasNext(): boolean; + function Next(): TFileInfo; + end; + + +var + FileSystem_Singleton: IFileSystem; + +function FileSystem(): IFileSystem; +begin + Result := FileSystem_Singleton; +end; + +function TFileSystemImpl.FileFind(const FilePattern: IPath; Attr: integer): IFileIterator; +begin + Result := TFileIterator.Create(FilePattern, Attr); +end; + +function TFileSystemImpl.IsCaseSensitive(): boolean; +begin + // Windows and Mac OS X do not have case sensitive file systems + {$IF Defined(MSWINDOWS) or Defined(DARWIN)} + Result := false; + {$ELSE} + Result := true; + {$IFEND} +end; + +function TFileSystemImpl.FileIsAbsolute(const FileName: IPath): boolean; +var + NameStr: UTF8String; +begin + Result := true; + NameStr := FileName.ToUTF8(); + + {$IFDEF MSWINDOWS} + // check if drive is given 'C:...' + if (FileName.GetDrive().ToUTF8 <> '') then + Exit; + // check if path starts with '\\' + if (Length(NameStr) >= 2) and + (NameStr[1] = PathDelim) and (NameStr[2] = PathDelim) then + Exit; + {$ELSE} // Unix based systems + // check if root dir given '/...' + if (Length(NameStr) >= 1) and (NameStr[1] = PathDelim) then + Exit; + {$ENDIF} + + Result := false; +end; + +{$IFDEF MSWINDOWS} + +function TFileSystemImpl.ExpandFileName(const FileName: IPath): IPath; +begin + Result := Path(WideExpandFileName(FileName.ToWide())); +end; + +function TFileSystemImpl.FileCreate(const FileName: IPath): TFileHandle; +begin + Result := WideFileCreate(FileName.ToWide()); +end; + +function TFileSystemImpl.DirectoryCreate(const Dir: IPath): boolean; +begin + Result := WideCreateDir(Dir.ToWide()); +end; + +function TFileSystemImpl.FileOpen(const FileName: IPath; Mode: longword): TFileHandle; +begin + Result := WideFileOpen(FileName.ToWide(), Mode); +end; + +function TFileSystemImpl.FileAge(const FileName: IPath): integer; +begin + Result := WideFileAge(FileName.ToWide()); +end; + +function TFileSystemImpl.FileAge(const FileName: IPath; out FileDateTime: TDateTime): boolean; +begin + Result := WideFileAge(FileName.ToWide(), FileDateTime); +end; + +function TFileSystemImpl.DirectoryExists(const Name: IPath): boolean; +begin + Result := WideDirectoryExists(Name.ToWide()); +end; + +function TFileSystemImpl.FileExists(const Name: IPath): boolean; +begin + Result := WideFileExists(Name.ToWide()); +end; + +function TFileSystemImpl.FileGetAttr(const FileName: IPath): Cardinal; +begin + Result := WideFileGetAttr(FileName.ToWide()); +end; + +function TFileSystemImpl.FileSetAttr(const FileName: IPath; Attr: integer): boolean; +begin + Result := WideFileSetAttr(FileName.ToWide(), Attr); +end; + +function TFileSystemImpl.FileIsReadOnly(const FileName: IPath): boolean; +begin + Result := WideFileIsReadOnly(FileName.ToWide()); +end; + +function TFileSystemImpl.FileSetReadOnly(const FileName: IPath; ReadOnly: boolean): boolean; +begin + Result := WideFileSetReadOnly(FileName.ToWide(), ReadOnly); +end; + +function TFileSystemImpl.ForceDirectories(const Dir: IPath): boolean; +begin + Result := WideForceDirectories(Dir.ToWide()); +end; + +function TFileSystemImpl.FileSearch(const Name: IPath; DirList: array of IPath): IPath; +var + I: integer; + DirListStr: WideString; +begin + DirListStr := ''; + for I := 0 to High(DirList) do + begin + if (I > 0) then + DirListStr := DirListStr + PathSep; + DirListStr := DirListStr + DirList[I].ToWide(); + end; + Result := Path(WideFileSearch(Name.ToWide(), DirListStr)); +end; + +function TFileSystemImpl.RenameFile(const OldName, NewName: IPath): boolean; +begin + Result := WideRenameFile(OldName.ToWide(), NewName.ToWide()); +end; + +function TFileSystemImpl.DeleteFile(const FileName: IPath): boolean; +begin + Result := WideDeleteFile(FileName.ToWide()); +end; + +function TFileSystemImpl.RemoveDir(const Dir: IPath): boolean; +begin + Result := WideRemoveDir(Dir.ToWide()); +end; + +function TFileSystemImpl.CopyFile(const Source, Target: IPath; FailIfExists: boolean): boolean; +begin + Result := WideCopyFile(Source.ToWide(), Target.ToWide(), FailIfExists); +end; + +function TFileSystemImpl.ExtractFileDrive(const FileName: IPath): IPath; +begin + Result := Path(WideExtractFileDrive(FileName.ToWide())); +end; + +function TFileSystemImpl.ExtractFilePath(const FileName: IPath): IPath; +begin + Result := Path(WideExtractFilePath(FileName.ToWide())); +end; + +function TFileSystemImpl.ExtractFileDir(const FileName: IPath): IPath; +begin + Result := Path(WideExtractFileDir(FileName.ToWide())); +end; + +function TFileSystemImpl.ExtractFileName(const FileName: IPath): IPath; +begin + Result := Path(WideExtractFileName(FileName.ToWide())); +end; + +function TFileSystemImpl.ExtractFileExt(const FileName: IPath): IPath; +begin + Result := Path(WideExtractFileExt(FileName.ToWide())); +end; + +function TFileSystemImpl.ExtractRelativePath(const BaseName: IPath; const FileName: IPath): IPath; +begin + Result := Path(WideExtractRelativePath(BaseName.ToWide(), FileName.ToWide())); +end; + +function TFileSystemImpl.ChangeFileExt(const FileName: IPath; const Extension: IPath): IPath; +begin + Result := Path(WideChangeFileExt(FileName.ToWide(), Extension.ToWide())); +end; + +function TFileSystemImpl.IncludeTrailingPathDelimiter(const FileName: IPath): IPath; +begin + Result := Path(WideIncludeTrailingPathDelimiter(FileName.ToWide())); +end; + +function TFileSystemImpl.ExcludeTrailingPathDelimiter(const FileName: IPath): IPath; +begin + Result := Path(WideExcludeTrailingPathDelimiter(FileName.ToWide())); +end; + +function TFileSystemImpl.FindFirst(const FilePattern: IPath; Attr: integer; var F: TSytemSearchRec): integer; +begin + Result := WideFindFirst(FilePattern.ToWide(), Attr, F); +end; + +function TFileSystemImpl.FindNext(var F: TSytemSearchRec): integer; +begin + Result := WideFindNext(F); +end; + +procedure TFileSystemImpl.FindClose(var F: TSytemSearchRec); +begin + WideFindClose(F); +end; + +function TFileSystemImpl.GetCurrentDir: IPath; +begin + Result := Path(WideGetCurrentDir()); +end; + +function TFileSystemImpl.SetCurrentDir(const Dir: IPath): boolean; +begin + Result := WideSetCurrentDir(Dir.ToWide()); +end; + +{$ELSE} // UNIX + +function TFileSystemImpl.ExpandFileName(const FileName: IPath): IPath; +begin + Result := Path(SysUtils.ExpandFileName(FileName.ToNative())); +end; + +function TFileSystemImpl.FileCreate(const FileName: IPath): TFileHandle; +begin + Result := SysUtils.FileCreate(FileName.ToNative()); +end; + +function TFileSystemImpl.DirectoryCreate(const Dir: IPath): boolean; +begin + Result := SysUtils.CreateDir(Dir.ToNative()); +end; + +function TFileSystemImpl.FileOpen(const FileName: IPath; Mode: longword): TFileHandle; +begin + Result := SysUtils.FileOpen(FileName.ToNative(), Mode); +end; + +function TFileSystemImpl.FileAge(const FileName: IPath): integer; +begin + Result := SysUtils.FileAge(FileName.ToNative()); +end; + +function TFileSystemImpl.FileAge(const FileName: IPath; out FileDateTime: TDateTime): boolean; +var + FileDate: integer; +begin + FileDate := SysUtils.FileAge(FileName.ToNative()); + Result := (FileDate <> -1); + if (Result) then + FileDateTime := FileDateToDateTime(FileDate); +end; + +function TFileSystemImpl.DirectoryExists(const Name: IPath): boolean; +begin + Result := SysUtils.DirectoryExists(Name.ToNative()); +end; + +function TFileSystemImpl.FileExists(const Name: IPath): boolean; +begin + Result := SysUtils.FileExists(Name.ToNative()); +end; + +function TFileSystemImpl.FileGetAttr(const FileName: IPath): Cardinal; +begin + Result := SysUtils.FileGetAttr(FileName.ToNative()); +end; + +function TFileSystemImpl.FileSetAttr(const FileName: IPath; Attr: integer): boolean; +begin + Result := (SysUtils.FileSetAttr(FileName.ToNative(), Attr) = 0); +end; + +function TFileSystemImpl.FileIsReadOnly(const FileName: IPath): boolean; +begin + Result := SysUtils.FileIsReadOnly(FileName.ToNative()); +end; + +function TFileSystemImpl.FileSetReadOnly(const FileName: IPath; ReadOnly: boolean): boolean; +begin + Result := (SysUtils.FileSetAttr(FileName.ToNative(), faReadOnly) = 0); +end; + +function TFileSystemImpl.ForceDirectories(const Dir: IPath): boolean; +begin + Result := SysUtils.ForceDirectories(Dir.ToNative()); +end; + +function TFileSystemImpl.FileSearch(const Name: IPath; DirList: array of IPath): IPath; +var + I: integer; + DirListStr: AnsiString; +begin + DirListStr := ''; + for I := 0 to High(DirList) do + begin + if (I > 0) then + DirListStr := DirListStr + PathSep; + DirListStr := DirListStr + DirList[I].ToNative(); + end; + Result := Path(SysUtils.FileSearch(Name.ToNative(), DirListStr)); +end; + +function TFileSystemImpl.RenameFile(const OldName, NewName: IPath): boolean; +begin + Result := SysUtils.RenameFile(OldName.ToNative(), NewName.ToNative()); +end; + +function TFileSystemImpl.DeleteFile(const FileName: IPath): boolean; +begin + Result := SysUtils.DeleteFile(FileName.ToNative()); +end; + +function TFileSystemImpl.RemoveDir(const Dir: IPath): boolean; +begin + Result := SysUtils.RemoveDir(Dir.ToNative()); +end; + +function TFileSystemImpl.CopyFile(const Source, Target: IPath; FailIfExists: boolean): boolean; +const + COPY_BUFFER_SIZE = 4096; // a good tradeoff between speed and memory consumption +var + SourceFile, TargetFile: TFileStream; + FileCopyBuffer: array [0..COPY_BUFFER_SIZE-1] of byte; // temporary copy-buffer. + NumberOfBytes: integer; // number of bytes read from SourceFile +begin + Result := false; + SourceFile := nil; + TargetFile := nil; + + // if overwrite is disabled return if the target file already exists + if (FailIfExists and FileExists(Target)) then + Exit; + + try + try + // open source and target file (might throw an exception on error) + SourceFile := TFileStream.Create(Source.ToNative(), fmOpenRead); + TargetFile := TFileStream.Create(Target.ToNative(), fmCreate or fmOpenWrite); + + while true do + begin + // read a block from the source file and check for errors or EOF + NumberOfBytes := SourceFile.Read(FileCopyBuffer, SizeOf(FileCopyBuffer)); + if (NumberOfBytes <= 0) then + Break; + // write block to target file and check if everything was written + if (TargetFile.Write(FileCopyBuffer, NumberOfBytes) <> NumberOfBytes) then + Exit; + end; + except + Exit; + end; + finally + SourceFile.Free; + TargetFile.Free; + end; + + Result := true; +end; + +function TFileSystemImpl.ExtractFileDrive(const FileName: IPath): IPath; +begin + Result := Path(SysUtils.ExtractFileDrive(FileName.ToNative())); +end; + +function TFileSystemImpl.ExtractFilePath(const FileName: IPath): IPath; +begin + Result := Path(SysUtils.ExtractFilePath(FileName.ToNative())); +end; + +function TFileSystemImpl.ExtractFileDir(const FileName: IPath): IPath; +begin + Result := Path(SysUtils.ExtractFileDir(FileName.ToNative())); +end; + +function TFileSystemImpl.ExtractFileName(const FileName: IPath): IPath; +begin + Result := Path(SysUtils.ExtractFileName(FileName.ToNative())); +end; + +function TFileSystemImpl.ExtractFileExt(const FileName: IPath): IPath; +begin + Result := Path(SysUtils.ExtractFileExt(FileName.ToNative())); +end; + +function TFileSystemImpl.ExtractRelativePath(const BaseName: IPath; const FileName: IPath): IPath; +begin + Result := Path(SysUtils.ExtractRelativePath(BaseName.ToNative(), FileName.ToNative())); +end; + +function TFileSystemImpl.ChangeFileExt(const FileName: IPath; const Extension: IPath): IPath; +begin + Result := Path(SysUtils.ChangeFileExt(FileName.ToNative(), Extension.ToNative())); +end; + +function TFileSystemImpl.IncludeTrailingPathDelimiter(const FileName: IPath): IPath; +begin + Result := Path(SysUtils.IncludeTrailingPathDelimiter(FileName.ToNative())); +end; + +function TFileSystemImpl.ExcludeTrailingPathDelimiter(const FileName: IPath): IPath; +begin + Result := Path(SysUtils.ExcludeTrailingPathDelimiter(FileName.ToNative())); +end; + +function TFileSystemImpl.FindFirst(const FilePattern: IPath; Attr: integer; var F: TSytemSearchRec): integer; +begin + Result := SysUtils.FindFirst(FilePattern.ToNative(), Attr, F); +end; + +function TFileSystemImpl.FindNext(var F: TSytemSearchRec): integer; +begin + Result := SysUtils.FindNext(F); +end; + +procedure TFileSystemImpl.FindClose(var F: TSytemSearchRec); +begin + SysUtils.FindClose(F); +end; + +function TFileSystemImpl.GetCurrentDir: IPath; +begin + Result := Path(SysUtils.GetCurrentDir()); +end; + +function TFileSystemImpl.SetCurrentDir(const Dir: IPath): boolean; +begin + Result := SysUtils.SetCurrentDir(Dir.ToNative()); +end; + +{$ENDIF} + + +{ TFileIterator } + +constructor TFileIterator.Create(const FilePattern: IPath; Attr: integer); +begin + inherited Create(); + fHasNext := (FileSystem.FindFirst(FilePattern, Attr, fSearchRec) = 0); +end; + +destructor TFileIterator.Destroy(); +begin + FileSystem.FindClose(fSearchRec); + inherited; +end; + +function TFileIterator.HasNext(): boolean; +begin + Result := fHasNext; +end; + +function TFileIterator.Next(): TFileInfo; +begin + if (not fHasNext) then + begin + // Note: do not use FillChar() on records with ref-counted fields + Result.Time := 0; + Result.Size := 0; + Result.Attr := 0; + Result.Name := nil; + Exit; + end; + + Result.Time := fSearchRec.Time; + Result.Size := fSearchRec.Size; + Result.Attr := fSearchRec.Attr; + Result.Name := Path(fSearchRec.Name); + + // fetch next entry + fHasNext := (FileSystem.FindNext(fSearchRec) = 0); +end; + + +initialization + FileSystem_Singleton := TFileSystemImpl.Create; + +finalization + FileSystem_Singleton := nil; + +end. diff --git a/cmake/src/base/UFont.pas b/cmake/src/base/UFont.pas index a72bca21..49a19a1a 100644 --- a/cmake/src/base/UFont.pas +++ b/cmake/src/base/UFont.pas @@ -41,18 +41,23 @@ interface {$DEFINE BITMAP_FONT} {$ENDIF} +// Enables the Freetype font cache +{$DEFINE ENABLE_FT_FACE_CACHE} + uses FreeType, gl, glext, glu, sdl, + Math, + Classes, + SysUtils, + UUnicodeUtils, {$IFDEF BITMAP_FONT} UTexture, {$ENDIF} - Math, - Classes, - SysUtils; + UPath; type @@ -60,7 +65,7 @@ type TGLubyteArray = array[0 .. (MaxInt div SizeOf(GLubyte))-1] of GLubyte; TGLubyteDynArray = array of GLubyte; - TWideStringArray = array of WideString; + TUCS4StringArray = array of UCS4String; TGLColor = packed record case byte of @@ -86,6 +91,8 @@ type Width, Height: integer; end; + EFontError = class(Exception); + {** * Abstract base class representing a glyph. *} @@ -117,6 +124,7 @@ type procedure ResetIntern(); protected + fFilename: IPath; fStyle: TFontStyle; fUseKerning: boolean; fLineSpacing: single; // must be inited by subclass @@ -126,34 +134,34 @@ type {** * Splits lines in Text seperated by newline (char-code #13). - * @param Text UTF-8 encoded string - * @param Lines splitted WideString lines + * @param Text UCS-4 encoded string + * @param Lines splitted UCS4String lines *} - procedure SplitLines(const Text: UTF8String; var Lines: TWideStringArray); + procedure SplitLines(const Text: UCS4String; var Lines: TUCS4StringArray); {** - * Print an array of WideStrings. Each array-item is a line of text. + * Print an array of UCS4Strings. Each array-item is a line of text. * Lines of text are seperated by the line-spacing. * This is the base function for all text drawing. *} - procedure Print(const Text: TWideStringArray); overload; virtual; + procedure Print(const Text: TUCS4StringArray); overload; virtual; {** * Draws an underline. *} - procedure DrawUnderline(const Text: WideString); virtual; + procedure DrawUnderline(const Text: UCS4String); virtual; {** * Renders (one) line of text. *} - procedure Render(const Text: WideString); virtual; abstract; + procedure Render(const Text: UCS4String); virtual; abstract; {** * Returns the bounds of text-lines contained in Text. * @param(Advance if true the right bound is set to the advance instead * of the minimal right bound.) *} - function BBox(const Text: TWideStringArray; Advance: boolean): TBoundsDbl; overload; virtual; abstract; + function BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; overload; virtual; abstract; {** * Resets all user settings to default values. @@ -182,15 +190,17 @@ type property ReflectionPass: boolean read fReflectionPass write SetReflectionPass; public - constructor Create(); + constructor Create(const Filename: IPath); destructor Destroy(); override; {** * Prints a text. *} + procedure Print(const Text: UCS4String); overload; + {** UTF-16 version of @link(Print) } procedure Print(const Text: WideString); overload; {** UTF-8 version of @link(Print) } - procedure Print(const Text: string); overload; + procedure Print(const Text: UTF8String); overload; {** * Calculates the bounding box (width and height) around Text. @@ -203,10 +213,18 @@ type * bigger than the text's width as it additionally contains the advance * and glyph-spacing of the last character. *} + function BBox(const Text: UCS4String; Advance: boolean = true): TBoundsDbl; overload; + {** UTF-16 version of @link(BBox) } function BBox(const Text: WideString; Advance: boolean = true): TBoundsDbl; overload; {** UTF-8 version of @link(BBox) } function BBox(const Text: UTF8String; Advance: boolean = true): TBoundsDbl; overload; + {** + * Adds a new font that is used if the default font misses a glyph + * @raises EFontError if the fallback could not be initialized + *} + procedure AddFallback(const Filename: IPath); virtual; abstract; + {** Font height } property Height: single read GetHeight; {** Vertical distance from baseline to top of glyph } @@ -223,6 +241,8 @@ type property Style: TFontStyle read GetStyle write SetStyle; {** If set to true (default) kerning will be used if available } property UseKerning: boolean read GetUseKerning write SetUseKerning; + {** Filename } + property Filename: IPath read fFilename; end; const @@ -242,16 +262,16 @@ type procedure ResetIntern(); protected - fScale: single; //**< current height to base-font height ratio - fAspect: single; //**< width to height aspect + fScale: single; //**< current height to base-font height ratio + fStretch: single; //**< stretch factor for width (Width * fStretch) fBaseFont: TFont; //**< shortcut for fMipmapFonts[0] fUseMipmaps: boolean; //**< true if mipmap fonts are generated /// Mipmap fonts (size[level+1] = size[level]/2) fMipmapFonts: array[0..cMaxMipmapLevel] of TFont; - procedure Render(const Text: WideString); override; - procedure Print(const Text: TWideStringArray); override; - function BBox(const Text: TWideStringArray; Advance: boolean): TBoundsDbl; override; + procedure Render(const Text: UCS4String); override; + procedure Print(const Text: TUCS4StringArray); override; + function BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; override; {** * Callback called for creation of each mipmap font. @@ -280,8 +300,8 @@ type procedure SetHeight(Height: single); virtual; function GetHeight(): single; override; - procedure SetAspect(Aspect: single); virtual; - function GetAspect(): single; virtual; + procedure SetStretch(Stretch: single); virtual; + function GetStretch(): single; virtual; function GetAscender(): single; override; function GetDescender(): single; override; procedure SetLineSpacing(Spacing: single); override; @@ -316,13 +336,13 @@ type {** Font height } property Height: single read GetHeight write SetHeight; - {** Factor for font stretching (NewWidth = Width*Aspect), 1.0 by default } - property Aspect: single read GetAspect write SetAspect; + {** Factor for font stretching (NewWidth = Width*Stretch), 1.0 by default } + property Stretch: single read GetStretch write SetStretch; end; {** * Table for storage of max. 256 glyphs. - * Used for the second cache level. Indexed by the LSB of the WideChar + * Used for the second cache level. Indexed by the LSB of the UCS4Char * char-code. *} PGlyphTable = ^TGlyphTable; @@ -332,7 +352,7 @@ type * Cache for glyphs of a single font. * The cached glyphs are stored inside a hash-list. * Hashing is performed in two steps: - * 1. the least significant byte (LSB) of the WideChar character code + * 1. the least significant byte (LSB) of the UCS4Char character code * is removed (shr 8) and the result (we call it BaseCode here) looked up in * the hash-list. * 2. Each entry of the hash-list contains a table with max. 256 entries. @@ -359,22 +379,22 @@ type * Add glyph Glyph with char-code ch to the cache. * @returns @true on success, @false otherwise *} - function AddGlyph(ch: WideChar; const Glyph: TGlyph): boolean; + function AddGlyph(ch: UCS4Char; const Glyph: TGlyph): boolean; {** * Removes the glyph with char-code ch from the cache. *} - procedure DeleteGlyph(ch: WideChar); + procedure DeleteGlyph(ch: UCS4Char); {** * Removes the glyph with char-code ch from the cache. *} - function GetGlyph(ch: WideChar): TGlyph; + function GetGlyph(ch: UCS4Char): TGlyph; {** * Checks if a glyph with char-code ch is cached. *} - function HasGlyph(ch: WideChar): boolean; + function HasGlyph(ch: UCS4Char): boolean; {** * Remove and free all cached glyphs. If KeepBaseSet is set to @@ -408,16 +428,16 @@ type * Retrieves a cached glyph with char-code ch from cache. * If the glyph is not already cached, it is loaded with LoadGlyph(). *} - function GetGlyph(ch: WideChar): TGlyph; + function GetGlyph(ch: UCS4Char): TGlyph; {** * Callback to create (load) a glyph with char-code ch. * Implemented by subclasses. *} - function LoadGlyph(ch: WideChar): TGlyph; virtual; abstract; + function LoadGlyph(ch: UCS4Char): TGlyph; virtual; abstract; public - constructor Create(); + constructor Create(const Filename: IPath); destructor Destroy(); override; {** @@ -431,11 +451,55 @@ type TFTFont = class; {** + * Freetype font face class. + *} + TFTFontFace = class + private + fFilename: IPath; //**< filename of the font-file + fFace: FT_Face; //**< Holds the height of the font + fFontUnitScale: TPositionDbl; //**< FT font-units to pixel ratio + fSize: integer; + + public + {** + * @raises EFontError if the glyph could not be initialized + *} + constructor Create(const Filename: IPath; Size: integer); + + destructor Destroy(); override; + + property Filename: IPath read fFilename; + property Data: FT_Face read fFace; + property FontUnitScale: TPositionDbl read fFontUnitScale; + property Size: integer read fSize; + end; + + {** + * Loading font faces with freetype is a slow process. + * Especially loading a font (e.g. fallback fonts) more than once is a waste + * of time. Just cache already loaded faces here. + *} + TFTFontFaceCache = class + private + fFaces: array of TFTFontFace; + fFacesRefCnt: array of integer; + public + {** + * @raises EFontError if the font could not be initialized + *} + function LoadFace(const Filename: IPath; Size: integer): TFTFontFace; + + procedure UnloadFace(Face: TFTFontFace); + end; + + {** * Freetype glyph. * Each glyph stores a texture with the glyph's image. *} TFTGlyph = class(TGlyph) private + fCharCode: UCS4Char; //**< Char code + fFace: TFTFontFace; //**< Freetype face used for this glyph fCharIndex: FT_UInt; //**< Freetype specific char-index (<> char-code) fDisplayList: GLuint; //**< Display-list ID fTexture: GLuint; //**< Texture ID @@ -458,13 +522,13 @@ type * The bitmap must be 2* pixels wider and higher than the * original glyph's bitmap with the latter centered in it. *} - procedure Extrude(var TexBuffer: TGLubyteDynArray; Outset: single); + procedure StrokeBorder(var Glyph: FT_Glyph); {** * Creates an OpenGL texture (and display list) for the glyph. * The glyph's and bitmap's metrics are set correspondingly. * @param LoadFlags flags passed to FT_Load_Glyph() - * @raises Exception if the glyph could not be initialized + * @raises EFontError if the glyph could not be initialized *} procedure CreateTexture(LoadFlags: FT_Int32); @@ -477,7 +541,7 @@ type * Creates a glyph with char-code ch from font Font. * @param LoadFlags flags passed to FT_Load_Glyph() *} - constructor Create(Font: TFTFont; ch: WideChar; Outset: single; + constructor Create(Font: TFTFont; ch: UCS4Char; Outset: single; LoadFlags: FT_Int32); destructor Destroy(); override; @@ -488,29 +552,36 @@ type {** Freetype specific char-index (<> char-code) } property CharIndex: FT_UInt read fCharIndex; + + {** Freetype face used for this glyph } + property Face: TFTFontFace read fFace; end; + TFontPart = ( fpNone, fpInner, fpOutline ); + TFTFontFaceArray = array of TFTFontFace; + {** * Freetype font class. *} TFTFont = class(TCachedFont) private procedure ResetIntern(); + class function GetFaceCache(): TFTFontFaceCache; protected - fFilename: string; //**< filename of the font-file + fFace: TFTFontFace; //**< Default font face fSize: integer; //**< Font base size (in pixels) fOutset: single; //**< size of outset extrusion (in pixels) - fFace: FT_Face; //**< Holds the height of the font fLoadFlags: FT_Int32; //**< FT glpyh load-flags - fFontUnitScale: TPositionDbl; //**< FT font-units to pixel ratio fUseDisplayLists: boolean; //**< true: use display-lists, false: direct drawing + fPart: TFontPart; //**< indicates the part of an outline font + fFallbackFaces: TFTFontFaceArray; //**< available fallback faces, ordered by priority {** @seealso TCachedFont.LoadGlyph } - function LoadGlyph(ch: WideChar): TGlyph; override; + function LoadGlyph(ch: UCS4Char): TGlyph; override; - procedure Render(const Text: WideString); override; - function BBox(const Text: TWideStringArray; Advance: boolean): TBoundsDbl; override; + procedure Render(const Text: UCS4String); override; + function BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; override; function GetHeight(): single; override; function GetAscender(): single; override; @@ -518,17 +589,15 @@ type function GetUnderlinePosition(): single; override; function GetUnderlineThickness(): single; override; - property Face: FT_Face read fFace; - public {** * Creates a font of size Size (in pixels) from the file Filename. * If Outset (in pixels) is set to a value > 0 the glyphs will be extruded * at their borders. Use it for e.g. a bold effect. * @param LoadFlags flags passed to FT_Load_Glyph() - * @raises Exception if the font-file could not be loaded + * @raises EFontError if the font-file could not be loaded *} - constructor Create(const Filename: string; + constructor Create(const Filename: IPath; Size: integer; Outset: single = 0.0; LoadFlags: FT_Int32 = FT_LOAD_DEFAULT); @@ -539,11 +608,19 @@ type {** @seealso TFont.Reset } procedure Reset(); override; - + + procedure AddFallback(const Filename: IPath); override; + {** Size of the base font } property Size: integer read fSize; {** Outset size } property Outset: single read fOutset; + {** The part (inner/outline/none) this font represents in a composite font } + property Part: TFontPart read fPart write fPart; + {** Freetype face of this font } + property DefaultFace: TFTFontFace read fFace; + {** Available freetype fallback faces, ordered by priority } + property FallbackFaces: TFTFontFaceArray read fFallbackFaces; end; TFTScalableFont = class(TScalableFont) @@ -557,11 +634,27 @@ type * OutsetAmount is the ratio of the glyph extrusion. * The extrusion in pixels is Size*OutsetAmount * (0.0 -> no extrusion, 0.1 -> 10%). + * + * The memory size (in bytes) consumed by a scalable font + * - with UseMipmaps=false: + * mem = size^2 * #cached_glyphs + * - with UseMipmaps=true (all mipmap levels): + * mem = size^2 * #cached_glyphs * Sum[i=1..cMaxMipmapLevel](1/i^2) + * - with UseMipmaps=true (5 <= cMaxMipmapLevel <= 10): + * mem ~= size^2 * #cached_glyphs * 1.5 + * + * Examples (for 128 cached glyphs): + * - Size: 64 pixels: 768 KB (mipmapped) or 512 KB (non-mipmapped). + * - Size 128 pixels: 3 MB (mipmapped) or 2 MB (non-mipmapped) + * + * Note: once a glyph is cached there will *} - constructor Create(const Filename: string; + constructor Create(const Filename: IPath; Size: integer; OutsetAmount: single = 0.0; UseMipmaps: boolean = true); + procedure AddFallback(const Filename: IPath); override; + {** @seealso TGlyphCache.FlushCache } procedure FlushCache(KeepBaseSet: boolean); @@ -576,7 +669,6 @@ type *} TFTOutlineFont = class(TFont) private - fFilename: string; fSize: integer; fOutset: single; fInnerFont, fOutlineFont: TFTFont; @@ -585,9 +677,9 @@ type procedure ResetIntern(); protected - procedure DrawUnderline(const Text: WideString); override; - procedure Render(const Text: WideString); override; - function BBox(const Text: TWideStringArray; Advance: boolean): TBoundsDbl; override; + procedure DrawUnderline(const Text: UCS4String); override; + procedure Render(const Text: UCS4String); override; + function BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; override; function GetHeight(): single; override; function GetAscender(): single; override; @@ -603,7 +695,7 @@ type procedure SetReflectionPass(Enable: boolean); override; public - constructor Create(const Filename: string; + constructor Create(const Filename: IPath; Size: integer; Outset: single; LoadFlags: FT_Int32 = FT_LOAD_DEFAULT); destructor Destroy; override; @@ -618,6 +710,8 @@ type {** @seealso TGlyphCache.FlushCache } procedure FlushCache(KeepBaseSet: boolean); + procedure AddFallback(const Filename: IPath); override; + {** @seealso TFont.Reset } procedure Reset(); override; @@ -637,7 +731,7 @@ type function CreateMipmap(Level: integer; Scale: single): TFont; override; public - constructor Create(const Filename: string; + constructor Create(const Filename: IPath; Size: integer; OutsetAmount: single; UseMipmaps: boolean = true); @@ -647,6 +741,8 @@ type {** @seealso TGlyphCache.FlushCache } procedure FlushCache(KeepBaseSet: boolean); + procedure AddFallback(const Filename: IPath); override; + {** Outset size } property Outset: single read GetOutset; end; @@ -672,18 +768,18 @@ type procedure ResetIntern(); - procedure RenderChar(ch: WideChar; var AdvanceX: real); + procedure RenderChar(ch: UCS4Char; var AdvanceX: real); {** * Load font widths from an info file. * @param InfoFile the name of the info (.dat) file - * @raises Exception if the file is corrupted + * @raises EFontError if the file is corrupted *} - procedure LoadFontInfo(const InfoFile: string); + procedure LoadFontInfo(const InfoFile: IPath); protected - procedure Render(const Text: WideString); override; - function BBox(const Text: TWideStringArray; Advance: boolean): TBoundsDbl; override; + procedure Render(const Text: UCS4String); override; + function BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; override; function GetHeight(): single; override; function GetAscender(): single; override; @@ -699,7 +795,7 @@ type * (y-axis up) and from the lower edge of the glyphs bounding box) * @param(Ascender pixels from baseline to top of highest glyph) *} - constructor Create(const Filename: string; Outline: integer; + constructor Create(const Filename: IPath; Outline: integer; Baseline, Ascender, Descender: integer); destructor Destroy(); override; @@ -711,6 +807,8 @@ type {** @seealso TFont.Reset } procedure Reset(); override; + + procedure AddFallback(const Filename: IPath); override; end; {$ENDIF BITMAP_FONT} @@ -720,7 +818,7 @@ type {** * Returns a pointer to the freetype library singleton. * If non exists, freetype will be initialized. - * @raises Exception if initialization failed + * @raises EFontError if initialization failed *} class function GetLibrary(): FT_Library; class procedure FreeLibrary(); @@ -773,9 +871,10 @@ end; * TFont *} -constructor TFont.Create(); +constructor TFont.Create(const Filename: IPath); begin - inherited; + inherited Create(); + fFilename := Filename; ResetIntern(); end; @@ -801,37 +900,61 @@ begin ResetIntern(); end; -procedure TFont.SplitLines(const Text: UTF8String; var Lines: TWideStringArray); +procedure TFont.SplitLines(const Text: UCS4String; var Lines: TUCS4StringArray); var - LineList: TStringList; - LineIndex: integer; + CharIndex: integer; + LineStart: integer; + LineLength: integer; + EOT: boolean; // End-Of-Text begin - // split lines on newline (there is no WideString version of ExtractStrings) - LineList := TStringList.Create(); - ExtractStrings([#13], [], PChar(Text), LineList); + // split lines on newline + SetLength(Lines, 0); + EOT := false; + LineStart := 0; - // create an array of WideStrins from the UTF-8 string-list - SetLength(Lines, LineList.Count); - for LineIndex := 0 to LineList.Count-1 do - Lines[LineIndex] := UTF8Decode(LineList[LineIndex]); - LineList.Free(); + for CharIndex := 0 to High(Text) do + begin + // check for end of text (UCS4Strings are zero-terminated) + if (CharIndex = High(Text)) then + EOT := true; + + // check for newline (carriage return (#13)) or end of text + if (Text[CharIndex] = 13) or EOT then + begin + LineLength := CharIndex - LineStart; + // check if last character was a newline + if (EOT and (LineLength = 0)) then + Break; + + // copy line (even if LineLength is 0) + SetLength(Lines, Length(Lines)+1); + Lines[High(Lines)] := UCS4Copy(Text, LineStart, LineLength); + + LineStart := CharIndex+1; + end; + end; end; -function TFont.BBox(const Text: UTF8String; Advance: boolean): TBoundsDbl; +function TFont.BBox(const Text: UCS4String; Advance: boolean): TBoundsDbl; var - LineArray: TWideStringArray; + LineArray: TUCS4StringArray; begin SplitLines(Text, LineArray); Result := BBox(LineArray, Advance); SetLength(LineArray, 0); end; +function TFont.BBox(const Text: UTF8String; Advance: boolean): TBoundsDbl; +begin + Result := BBox(UTF8Decode(Text), Advance); +end; + function TFont.BBox(const Text: WideString; Advance: boolean): TBoundsDbl; begin - Result := BBox(UTF8Encode(Text), Advance); + Result := BBox(WideStringToUCS4String(Text), Advance); end; -procedure TFont.Print(const Text: TWideStringArray); +procedure TFont.Print(const Text: TUCS4StringArray); var LineIndex: integer; begin @@ -912,21 +1035,26 @@ begin glPopAttrib(); end; -procedure TFont.Print(const Text: string); +procedure TFont.Print(const Text: UCS4String); var - LineArray: TWideStringArray; + LineArray: TUCS4StringArray; begin SplitLines(Text, LineArray); Print(LineArray); SetLength(LineArray, 0); end; +procedure TFont.Print(const Text: UTF8String); +begin + Print(UTF8Decode(Text)); +end; + procedure TFont.Print(const Text: WideString); begin - Print(UTF8Encode(Text)); + Print(WideStringToUCS4String(Text)); end; -procedure TFont.DrawUnderline(const Text: WideString); +procedure TFont.DrawUnderline(const Text: UCS4String); var UnderlineY1, UnderlineY2: single; Bounds: TBoundsDbl; @@ -1001,7 +1129,7 @@ constructor TScalableFont.Create(Font: TFont; UseMipmaps: boolean); var MipmapLevel: integer; begin - inherited Create(); + inherited Create(Font.Filename); fBaseFont := Font; fMipmapFonts[0] := Font; @@ -1033,7 +1161,7 @@ end; procedure TScalableFont.ResetIntern(); begin fScale := 1.0; - fAspect := 1.0; + fStretch := 1.0; end; procedure TScalableFont.Reset(); @@ -1049,7 +1177,7 @@ end; {** * Returns the mipmap level to use with regard to the current projection - * and modelview matrix, font scale and aspect. + * and modelview matrix, font scale and stretch. * * Note: * - for Freetype fonts, hinting and grid-fitting must be disabled, otherwise @@ -1088,7 +1216,7 @@ var ModelMatrix, ProjMatrix: T16dArray; WinCoords: array[0..2, 0..2] of GLdouble; ViewPortArray: TViewPortArray; - Dist, Dist2: double; + Dist, Dist2, DistSum: double; WidthScale, HeightScale: double; const // width/height of square used for determining the scale @@ -1128,12 +1256,24 @@ begin // projected width ||(x1, y1) - (x2, y1)|| Dist := (WinCoords[0][0] - WinCoords[1][0]); Dist2 := (WinCoords[0][1] - WinCoords[1][1]); - WidthScale := cTestSize / Sqrt(Dist*Dist + Dist2*Dist2); + + WidthScale := 1; + DistSum := Dist*Dist + Dist2*Dist2; + if (DistSum > 0) then + begin + WidthScale := cTestSize / Sqrt(DistSum); + end; // projected height ||(x1, y1) - (x1, y2)|| Dist := (WinCoords[0][0] - WinCoords[2][0]); Dist2 := (WinCoords[0][1] - WinCoords[2][1]); - HeightScale := cTestSize / Sqrt(Dist*Dist + Dist2*Dist2); + + HeightScale := 1; + DistSum := Dist*Dist + Dist2*Dist2; + if (DistSum > 0) then + begin + HeightScale := cTestSize / Sqrt(DistSum); + end; //writeln(Format('Scale %f, %f', [WidthScale, HeightScale])); @@ -1194,12 +1334,12 @@ begin glScalef(MipmapScale, MipmapScale, 0); end; -procedure TScalableFont.Print(const Text: TWideStringArray); +procedure TScalableFont.Print(const Text: TUCS4StringArray); begin glPushMatrix(); // set scale and stretching - glScalef(fScale * fAspect, fScale, 0); + glScalef(fScale * fStretch, fScale, 0); // print text if (fUseMipmaps) then @@ -1210,16 +1350,16 @@ begin glPopMatrix(); end; -procedure TScalableFont.Render(const Text: WideString); +procedure TScalableFont.Render(const Text: UCS4String); begin Assert(false, 'Unused TScalableFont.Render() was called'); end; -function TScalableFont.BBox(const Text: TWideStringArray; Advance: boolean): TBoundsDbl; +function TScalableFont.BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; begin Result := fBaseFont.BBox(Text, Advance); - Result.Left := Result.Left * fScale * fAspect; - Result.Right := Result.Right * fScale * fAspect; + Result.Left := Result.Left * fScale * fStretch; + Result.Right := Result.Right * fScale * fStretch; Result.Top := Result.Top * fScale; Result.Bottom := Result.Bottom * fScale; end; @@ -1234,14 +1374,14 @@ begin Result := fBaseFont.GetHeight() * fScale; end; -procedure TScalableFont.SetAspect(Aspect: single); +procedure TScalableFont.SetStretch(Stretch: single); begin - fAspect := Aspect; + fStretch := Stretch; end; -function TScalableFont.GetAspect(): single; +function TScalableFont.GetStretch(): single; begin - Result := fAspect; + Result := fStretch; end; function TScalableFont.GetAscender(): single; @@ -1287,7 +1427,7 @@ var Level: integer; begin for Level := 0 to High(fMipmapFonts) do - if (fMipmapFonts[Level] <> nil) then + if ((fMipmapFonts[Level] <> nil) AND (GetMipmapScale(Level) > 0)) then fMipmapFonts[Level].SetReflectionSpacing(Spacing / GetMipmapScale(Level)); end; @@ -1334,9 +1474,9 @@ end; * TCachedFont *} -constructor TCachedFont.Create(); +constructor TCachedFont.Create(const Filename: IPath); begin - inherited; + inherited Create(Filename); fCache := TGlyphCache.Create(); end; @@ -1346,7 +1486,7 @@ begin inherited; end; -function TCachedFont.GetGlyph(ch: WideChar): TGlyph; +function TCachedFont.GetGlyph(ch: UCS4Char): TGlyph; begin Result := fCache.GetGlyph(ch); if (Result = nil) then @@ -1362,60 +1502,155 @@ begin fCache.FlushCache(KeepBaseSet); end; +{* + * TFTFontFaceCache + *} {* - * TFTFont + * TFTFontFace *} -constructor TFTFont.Create( - const Filename: string; - Size: integer; Outset: single; - LoadFlags: FT_Int32); -var - i: WideChar; +constructor TFTFontFace.Create(const Filename: IPath; Size: integer); begin inherited Create(); fFilename := Filename; fSize := Size; - fOutset := Outset; - fLoadFlags := LoadFlags; - fUseDisplayLists := true; // load font information - if (FT_New_Face(TFreeType.GetLibrary(), PChar(Filename), 0, fFace) <> 0) then - raise Exception.Create('FT_New_Face: Could not load font ''' + Filename + ''''); + if (FT_New_Face(TFreeType.GetLibrary(), PChar(Filename.ToNative), 0, fFace) <> 0) then + raise EFontError.Create('FT_New_Face: Could not load font ''' + Filename.ToNative + ''''); // support scalable fonts only if (not FT_IS_SCALABLE(fFace)) then - raise Exception.Create('Font is not scalable'); + raise EFontError.Create('Font is not scalable'); if (FT_Set_Pixel_Sizes(fFace, 0, Size) <> 0) then - raise Exception.Create('FT_Set_Pixel_Sizes failes'); + raise EFontError.Create('FT_Set_Pixel_Sizes failes'); // get scale factor for font-unit to pixel-size transformation fFontUnitScale.X := fFace.size.metrics.x_ppem / fFace.units_per_EM; fFontUnitScale.Y := fFace.size.metrics.y_ppem / fFace.units_per_EM; +end; + +destructor TFTFontFace.Destroy(); +begin + // free face data + FT_Done_Face(fFace); + inherited; +end; + + +{* + * TFTFontFaceCache + *} + +function TFTFontFaceCache.LoadFace(const Filename: IPath; Size: integer): TFTFontFace; +var + I: Integer; + Face: TFTFontFace; +begin + {$IFDEF ENABLE_FT_FACE_CACHE} + for I := 0 to High(fFaces) do + begin + Face := fFaces[I]; + // check if we have this file in our cache + if ((Face.Filename.Equals(Filename)) and (Face.Size = Size)) then + begin + // true -> return cached face and increment ref-count + Inc(fFacesRefCnt[I]); + Result := Face; + Exit; + end; + end; + {$ENDIF} + + // face not in cache -> load it + Face := TFTFontFace.Create(Filename, Size); + + // add face to cache + SetLength(fFaces, Length(fFaces)+1); + SetLength(fFacesRefCnt, Length(fFaces)+1); + fFaces[High(fFaces)] := Face; + fFacesRefCnt[High(fFaces)] := 1; + + Result := Face; +end; + +procedure TFTFontFaceCache.UnloadFace(Face: TFTFontFace); +var + I: Integer; +begin + for I := 0 to High(fFaces) do + begin + // search face in cache + if (fFaces[I] = Face) then + begin + // decrement ref-count and free face if ref-count is 0 + Dec(fFacesRefCnt[I]); + if (fFacesRefCnt[I] <= 0) then + fFaces[I].Free; + Exit; + end; + end; +end; + + +{* + * TFTFont + *} + +constructor TFTFont.Create( + const Filename: IPath; + Size: integer; Outset: single; + LoadFlags: FT_Int32); +var + ch: UCS4Char; +begin + inherited Create(Filename); + + fSize := Size; + fOutset := Outset; + fLoadFlags := LoadFlags; + fUseDisplayLists := true; + fPart := fpNone; + + fFace := GetFaceCache.LoadFace(Filename, Size); ResetIntern(); // pre-cache some commonly used glyphs (' ' - '~') - for i := #32 to #126 do - fCache.AddGlyph(i, TFTGlyph.Create(Self, i, Outset, LoadFlags)); + for ch := 32 to 126 do + fCache.AddGlyph(ch, TFTGlyph.Create(Self, ch, Outset, LoadFlags)); end; destructor TFTFont.Destroy(); +var + I: integer; begin - // free face - FT_Done_Face(fFace); + // free faces + GetFaceCache.UnloadFace(fFace); + for I := 0 to High(fFallbackFaces) do + GetFaceCache.UnloadFace(fFallbackFaces[I]); + inherited; end; +var + FontFaceCache: TFTFontFaceCache = nil; + +class function TFTFont.GetFaceCache(): TFTFontFaceCache; +begin + if (FontFaceCache = nil) then + FontFaceCache := TFTFontFaceCache.Create; + Result := FontFaceCache; +end; + procedure TFTFont.ResetIntern(); begin // Note: outset and non outset fonts use same spacing - fLineSpacing := fFace.height * fFontUnitScale.Y; - fReflectionSpacing := -2*fFace.descender * fFontUnitScale.Y; + fLineSpacing := fFace.Data.height * fFace.FontUnitScale.Y; + fReflectionSpacing := -2*fFace.Data.descender * fFace.FontUnitScale.Y; end; procedure TFTFont.Reset(); @@ -1424,15 +1659,24 @@ begin ResetIntern(); end; -function TFTFont.LoadGlyph(ch: WideChar): TGlyph; +procedure TFTFont.AddFallback(const Filename: IPath); +var + FontFace: TFTFontFace; +begin + FontFace := GetFaceCache.LoadFace(Filename, Size); + SetLength(fFallbackFaces, Length(fFallbackFaces) + 1); + fFallbackFaces[High(fFallbackFaces)] := FontFace; +end; + +function TFTFont.LoadGlyph(ch: UCS4Char): TGlyph; begin Result := TFTGlyph.Create(Self, ch, Outset, fLoadFlags); end; -function TFTFont.BBox(const Text: TWideStringArray; Advance: boolean): TBoundsDbl; +function TFTFont.BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; var Glyph, PrevGlyph: TFTGlyph; - TextLine: WideString; + TextLine: UCS4String; LineYOffset: single; LineIndex, CharIndex: integer; LineBounds: TBoundsDbl; @@ -1462,17 +1706,17 @@ begin LineBounds.Top := 0; // for each glyph image, compute its bounding box - for CharIndex := 1 to Length(TextLine) do + for CharIndex := 0 to LengthUCS4(TextLine)-1 do begin Glyph := TFTGlyph(GetGlyph(TextLine[CharIndex])); if (Glyph <> nil) then begin // get kerning - if (fUseKerning and FT_HAS_KERNING(fFace) and (PrevGlyph <> nil)) then + if (fUseKerning and FT_HAS_KERNING(fFace.Data) and (PrevGlyph <> nil)) then begin - FT_Get_Kerning(fFace, PrevGlyph.CharIndex, Glyph.CharIndex, + FT_Get_Kerning(fFace.Data, PrevGlyph.CharIndex, Glyph.CharIndex, FT_KERNING_UNSCALED, KernDelta); - LineBounds.Right := LineBounds.Right + KernDelta.x * fFontUnitScale.X; + LineBounds.Right := LineBounds.Right + KernDelta.x * fFace.FontUnitScale.X; end; // update left bound (must be done before right bound is updated) @@ -1480,9 +1724,9 @@ begin LineBounds.Left := LineBounds.Right + Glyph.Bounds.Left; // update right bound - if (CharIndex < Length(TextLine)) or // not the last character - (TextLine[CharIndex] = ' ') or // on space char (Bounds.Right = 0) - Advance then // or in advance mode + if (CharIndex < LengthUCS4(TextLine)-1) or // not the last character + (TextLine[CharIndex] = Ord(' ')) or // on space char (Bounds.Right = 0) + Advance then // or in advance mode begin // add advance and glyph spacing LineBounds.Right := LineBounds.Right + Glyph.Advance.x + GlyphSpacing @@ -1534,13 +1778,13 @@ begin end; // if left or bottom bound was not set, set them to 0 - if (Result.Left = Infinity) then + if (IsInfinite(Result.Left)) then Result.Left := 0.0; - if (Result.Bottom = Infinity) then + if (IsInfinite(Result.Bottom)) then Result.Bottom := 0.0; end; -procedure TFTFont.Render(const Text: WideString); +procedure TFTFont.Render(const Text: UCS4String); var CharIndex: integer; Glyph, PrevGlyph: TFTGlyph; @@ -1550,17 +1794,17 @@ begin PrevGlyph := nil; // draw current line - for CharIndex := 1 to Length(Text) do + for CharIndex := 0 to LengthUCS4(Text)-1 do begin Glyph := TFTGlyph(GetGlyph(Text[CharIndex])); if (Assigned(Glyph)) then begin // get kerning - if (fUseKerning and FT_HAS_KERNING(fFace) and (PrevGlyph <> nil)) then + if (fUseKerning and FT_HAS_KERNING(fFace.Data) and (PrevGlyph <> nil)) then begin - FT_Get_Kerning(fFace, PrevGlyph.CharIndex, Glyph.CharIndex, + FT_Get_Kerning(fFace.Data, PrevGlyph.CharIndex, Glyph.CharIndex, FT_KERNING_UNSCALED, KernDelta); - glTranslatef(KernDelta.x * fFontUnitScale.X, 0, 0); + glTranslatef(KernDelta.x * fFace.FontUnitScale.X, 0, 0); end; if (ReflectionPass) then @@ -1582,23 +1826,23 @@ end; function TFTFont.GetAscender(): single; begin - Result := fFace.ascender * fFontUnitScale.Y + Outset*2; + Result := fFace.Data.ascender * fFace.FontUnitScale.Y + Outset*2; end; function TFTFont.GetDescender(): single; begin // Note: outset is not part of the descender as the baseline is lifted - Result := fFace.descender * fFontUnitScale.Y; + Result := fFace.Data.descender * fFace.FontUnitScale.Y; end; function TFTFont.GetUnderlinePosition(): single; begin - Result := fFace.underline_position * fFontUnitScale.Y - Outset; + Result := fFace.Data.underline_position * fFace.FontUnitScale.Y - Outset; end; function TFTFont.GetUnderlineThickness(): single; begin - Result := fFace.underline_thickness * fFontUnitScale.Y + Outset*2; + Result := fFace.Data.underline_thickness * fFace.FontUnitScale.Y + Outset*2; end; @@ -1606,7 +1850,7 @@ end; * TFTScalableFont *} -constructor TFTScalableFont.Create(const Filename: string; +constructor TFTScalableFont.Create(const Filename: IPath; Size: integer; OutsetAmount: single; UseMipmaps: boolean); var @@ -1637,8 +1881,8 @@ begin // do not create mipmap fonts < 8 pixels if (ScaledSize < 8) then Exit; - Result := TFTFont.Create(BaseFont.fFilename, - ScaledSize, BaseFont.fOutset * Scale, + Result := TFTFont.Create(BaseFont.Filename, + ScaledSize, BaseFont.Outset * Scale, FT_LOAD_DEFAULT or FT_LOAD_NO_HINTING); end; @@ -1647,6 +1891,15 @@ begin Result := TFTFont(fBaseFont).Outset * fScale; end; +procedure TFTScalableFont.AddFallback(const Filename: IPath); +var + Level: integer; +begin + for Level := 0 to High(fMipmapFonts) do + if (fMipmapFonts[Level] <> nil) then + TFTFont(fMipmapFonts[Level]).AddFallback(Filename); +end; + procedure TFTScalableFont.FlushCache(KeepBaseSet: boolean); var Level: integer; @@ -1662,18 +1915,19 @@ end; *} constructor TFTOutlineFont.Create( - const Filename: string; + const Filename: IPath; Size: integer; Outset: single; LoadFlags: FT_Int32); begin - inherited Create(); + inherited Create(Filename); - fFilename := Filename; fSize := Size; fOutset := Outset; fInnerFont := TFTFont.Create(Filename, Size, 0.0, LoadFlags); + fInnerFont.Part := fpInner; fOutlineFont := TFTFont.Create(Filename, Size, Outset, LoadFlags); + fOutlineFont.Part := fpOutline; ResetIntern(); end; @@ -1705,7 +1959,7 @@ begin ResetIntern(); end; -procedure TFTOutlineFont.DrawUnderline(const Text: WideString); +procedure TFTOutlineFont.DrawUnderline(const Text: UCS4String); var CurrentColor: TGLColor; OutlineColor: TGLColor; @@ -1730,7 +1984,7 @@ begin glPopMatrix(); end; -procedure TFTOutlineFont.Render(const Text: WideString); +procedure TFTOutlineFont.Render(const Text: UCS4String); var CurrentColor: TGLColor; OutlineColor: TGLColor; @@ -1770,7 +2024,13 @@ begin fInnerFont.FlushCache(KeepBaseSet); end; -function TFTOutlineFont.BBox(const Text: TWideStringArray; Advance: boolean): TBoundsDbl; +procedure TFTOutlineFont.AddFallback(const Filename: IPath); +begin + fOutlineFont.AddFallback(Filename); + fInnerFont.AddFallback(Filename); +end; + +function TFTOutlineFont.BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; begin Result := fOutlineFont.BBox(Text, Advance); end; @@ -1852,7 +2112,7 @@ end; *} constructor TFTScalableOutlineFont.Create( - const Filename: string; + const Filename: IPath; Size: integer; OutsetAmount: single; UseMipmaps: boolean); var @@ -1906,6 +2166,15 @@ begin TFTOutlineFont(fMipmapFonts[Level]).FlushCache(KeepBaseSet); end; +procedure TFTScalableOutlineFont.AddFallback(const Filename: IPath); +var + Level: integer; +begin + for Level := 0 to High(fMipmapFonts) do + if (fMipmapFonts[Level] <> nil) then + TFTOutlineFont(fMipmapFonts[Level]).AddFallback(Filename); +end; + {* * TFTGlyph @@ -1935,82 +2204,119 @@ const *} cTexSmoothBorder = 1; -procedure TFTGlyph.Extrude(var TexBuffer: TGLubyteDynArray; Outset: single); +procedure TFTGlyph.StrokeBorder(var Glyph: FT_Glyph); +var + Outline: PFT_Outline; + OuterStroker, InnerStroker: FT_Stroker; + OuterNumPoints, InnerNumPoints, GlyphNumPoints: FT_UInt; + OuterNumContours, InnerNumContours, GlyphNumContours: FT_UInt; + OuterBorder, InnerBorder: FT_StrokerBorder; + OutlineFlags: FT_Int; + UseStencil: boolean; +begin + // It is possible to extrude the borders of a glyph with FT_Glyph_Stroke + // but it will extrude the border to the outside and the inside of a glyph + // although we just want to extrude to the outside. + // FT_Glyph_StrokeBorder extrudes to the outside but also fills the interior + // (this is what we need for bold fonts). + // In both cases the inner font and outline font (border) will overlap. + // Normally this does not matter but it does if alpha blending is active. + // In this case if e.g. the inner color is set to white, the outline to red + // and alpha to 0.5 the inner part will not be white it will be pink. + + InnerStroker := nil; + OuterStroker := nil; + + // If we are to create the interior of an outlined font (fInner = true) + // we have to create two borders: + // - one extruded to the outside by fOutset pixels and + // - one extruded to the inside by almost 0 zero pixels. + // The second one is used as a stencil for the first one, clearing the + // interiour of the glyph. + // The stencil is not needed to create bold fonts. + UseStencil := (fFont.Part = fpInner); + + // we cannot extrude bitmaps, only vector based glyphs. + // Check for FT_GLYPH_FORMAT_OUTLINE otherwise a cast to FT_OutlineGlyph is + // invalid and FT_Stroker_ParseOutline() will crash + if (Glyph.format <> FT_GLYPH_FORMAT_OUTLINE) then + Exit; + + Outline := @FT_OutlineGlyph(Glyph).outline; + + OuterBorder := FT_Outline_GetOutsideBorder(Outline); + if (OuterBorder = FT_STROKER_BORDER_LEFT) then + InnerBorder := FT_STROKER_BORDER_RIGHT + else + InnerBorder := FT_STROKER_BORDER_LEFT; + + { extrude outer border } + + if (FT_Stroker_New(Glyph.library_, OuterStroker) <> 0) then + raise EFontError.Create('FT_Stroker_New failed!'); + FT_Stroker_Set( + OuterStroker, + Round(fOutset * 64), + FT_STROKER_LINECAP_ROUND, + FT_STROKER_LINEJOIN_BEVEL, + 0); + + // similar to FT_Glyph_StrokeBorder(inner = FT_FALSE) but it is possible to + // use FT_Stroker_ExportBorder() afterwards to combine inner and outer borders + if (FT_Stroker_ParseOutline(OuterStroker, Outline, FT_FALSE) <> 0) then + raise EFontError.Create('FT_Stroker_ParseOutline failed!'); - procedure SetToMax(var Val1: GLubyte; Val2: GLubyte); {$IFDEF HasInline}inline;{$ENDIF} + FT_Stroker_GetBorderCounts(OuterStroker, OuterBorder, OuterNumPoints, OuterNumContours); + + { extrude inner border (= stencil) } + + if (UseStencil) then begin - if (Val1 < Val2) then - Val1 := Val2; + if (FT_Stroker_New(Glyph.library_, InnerStroker) <> 0) then + raise EFontError.Create('FT_Stroker_New failed!'); + FT_Stroker_Set( + InnerStroker, + 63, // extrude at most one pixel to avoid a black border + FT_STROKER_LINECAP_ROUND, + FT_STROKER_LINEJOIN_BEVEL, + 0); + + if (FT_Stroker_ParseOutline(InnerStroker, Outline, FT_FALSE) <> 0) then + raise EFontError.Create('FT_Stroker_ParseOutline failed!'); + + FT_Stroker_GetBorderCounts(InnerStroker, InnerBorder, InnerNumPoints, InnerNumContours); + end else begin + InnerNumPoints := 0; + InnerNumContours := 0; end; -var - I, X, Y: integer; - SrcBuffer,TmpBuffer: TGLubyteDynArray; - TexLine, TexLinePrev, TexLineNext: PGLubyteArray; - SrcLine: PGLubyteArray; - AlphaScale: single; - Value, ValueNeigh, ValueDiag: GLubyte; -const - // square-root of 2 used for diagonal neighbor pixels - cSqrt2 = 1.4142; - // number of ignored pixels on each edge of the bitmap. Consists of: - // - border used for font smoothing and - // - outer (extruded) bitmap pixel (because it is just written but never read) - cBorder = cTexSmoothBorder + 1; -begin - // allocate memory for temporary buffer - SetLength(SrcBuffer, Length(TexBuffer)); - FillChar(SrcBuffer[0], Length(TexBuffer), 0); - - // extrude pixel by pixel - for I := 1 to Ceil(Outset) do - begin - // swap arrays - TmpBuffer := TexBuffer; - TexBuffer := SrcBuffer; - SrcBuffer := TmpBuffer; - - // as long as we add an entire pixel of outset, use a solid color. - // If the fractional part is reached blend, e.g. outline=3.2 -> 3 solid - // pixels and one blended with alpha=0.2. - // For the fractional part I = Ceil(Outset) is always true. - if (I <= Outset) then - AlphaScale := 1 - else - AlphaScale := Outset - Trunc(Outset); - - // copy data to the expanded bitmap. - for Y := cBorder to fTexSize.Height - 2*cBorder do - begin - TexLine := @TexBuffer[Y*fTexSize.Width]; - TexLinePrev := @TexBuffer[(Y-1)*fTexSize.Width]; - TexLineNext := @TexBuffer[(Y+1)*fTexSize.Width]; - SrcLine := @SrcBuffer[Y*fTexSize.Width]; + { combine borders (subtract: OuterBorder - InnerBorder) } - // expand current line's pixels - for X := cBorder to fTexSize.Width - 2*cBorder do - begin - Value := SrcLine[X]; - ValueNeigh := Round(Value * AlphaScale); - ValueDiag := Round(ValueNeigh / cSqrt2); + GlyphNumPoints := InnerNumPoints + OuterNumPoints; + GlyphNumContours := InnerNumContours + OuterNumContours; - SetToMax(TexLine[X], Value); - SetToMax(TexLine[X-1], ValueNeigh); - SetToMax(TexLine[X+1], ValueNeigh); + // save flags before deletion (TODO: set them on the resulting outline) + OutlineFlags := Outline.flags; - SetToMax(TexLinePrev[X], ValueNeigh); - SetToMax(TexLinePrev[X-1], ValueDiag); - SetToMax(TexLinePrev[X+1], ValueDiag); + // resize glyph outline to hold inner and outer border + FT_Outline_Done(Glyph.Library_, Outline); + if (FT_Outline_New(Glyph.Library_, GlyphNumPoints, GlyphNumContours, Outline) <> 0) then + raise EFontError.Create('FT_Outline_New failed!'); - SetToMax(TexLineNext[X], ValueNeigh); - SetToMax(TexLineNext[X-1], ValueDiag); - SetToMax(TexLineNext[X+1], ValueDiag); - end; - end; - end; + Outline.n_points := 0; + Outline.n_contours := 0; - TmpBuffer := nil; - SetLength(SrcBuffer, 0); + // add points to outline. The inner-border is used as a stencil. + FT_Stroker_ExportBorder(OuterStroker, OuterBorder, Outline); + if (UseStencil) then + FT_Stroker_ExportBorder(InnerStroker, InnerBorder, Outline); + if (FT_Outline_Check(outline) <> 0) then + raise EFontError.Create('FT_Stroker_ExportBorder failed!'); + + if (InnerStroker <> nil) then + FT_Stroker_Done(InnerStroker); + if (OuterStroker <> nil) then + FT_Stroker_Done(OuterStroker); end; procedure TFTGlyph.CreateTexture(LoadFlags: FT_Int32); @@ -2025,17 +2331,26 @@ var TexLine: PGLubyteArray; CBox: FT_BBox; begin + // we need vector data for outlined glyphs so do not load bitmaps. + // This is necessary for mixed fonts that contain bitmap versions of smaller + // glyphs, for example in CJK fonts. + if (fOutset > 0) then + LoadFlags := LoadFlags or FT_LOAD_NO_BITMAP; + // load the Glyph for our character - if (FT_Load_Glyph(fFont.Face, fCharIndex, LoadFlags) <> 0) then - raise Exception.Create('FT_Load_Glyph failed'); + if (FT_Load_Glyph(fFace.Data, fCharIndex, LoadFlags) <> 0) then + raise EFontError.Create('FT_Load_Glyph failed'); // move the face's glyph into a Glyph object - if (FT_Get_Glyph(fFont.Face^.glyph, Glyph) <> 0) then - raise Exception.Create('FT_Get_Glyph failed'); + if (FT_Get_Glyph(fFace.Data^.glyph, Glyph) <> 0) then + raise EFontError.Create('FT_Get_Glyph failed'); + + if (fOutset > 0) then + StrokeBorder(Glyph); // store scaled advance width/height in glyph-object - fAdvance.X := fFont.Face^.glyph^.advance.x / 64 + fOutset*2; - fAdvance.Y := fFont.Face^.glyph^.advance.y / 64 + fOutset*2; + fAdvance.X := fFace.Data^.glyph^.advance.x / 64 + fOutset*2; + fAdvance.Y := fFace.Data^.glyph^.advance.y / 64 + fOutset*2; // get the contour's bounding box (in 1/64th pixels, not font-units) FT_Glyph_Get_CBox(Glyph, FT_GLYPH_BBOX_UNSCALED, CBox); @@ -2114,9 +2429,6 @@ begin end; end; - if (fOutset > 0) then - Extrude(TexBuffer, fOutset); - // allocate resources for textures and display lists glGenTextures(1, @fTexture); @@ -2151,16 +2463,36 @@ begin FT_Done_Glyph(Glyph); end; -constructor TFTGlyph.Create(Font: TFTFont; ch: WideChar; Outset: single; +constructor TFTGlyph.Create(Font: TFTFont; ch: UCS4Char; Outset: single; LoadFlags: FT_Int32); +var + I: integer; begin inherited Create(); fFont := Font; fOutset := Outset; + fCharCode := ch; - // get the Freetype char-index (use default UNICODE charmap) - fCharIndex := FT_Get_Char_Index(Font.fFace, FT_ULONG(ch)); + // Note: the default face is also used if no face (neither default nor fallback) + // contains a glyph for the given char. + fFace := Font.DefaultFace; + + // search the Freetype char-index (use default UNICODE charmap) in the default face + fCharIndex := FT_Get_Char_Index(fFace.Data, FT_ULONG(ch)); + if (fCharIndex = 0) then + begin + // glyph not in default font, search in fallback font faces + for I := 0 to High(Font.FallbackFaces) do + begin + fCharIndex := FT_Get_Char_Index(Font.FallbackFaces[I].Data, FT_ULONG(ch)); + if (fCharIndex <> 0) then + begin + fFace := Font.FallbackFaces[I]; + Break; + end; + end; + end; CreateTexture(LoadFlags); end; @@ -2336,7 +2668,7 @@ begin InsertPos := fHash.Count; end; -function TGlyphCache.AddGlyph(ch: WideChar; const Glyph: TGlyph): boolean; +function TGlyphCache.AddGlyph(ch: UCS4Char; const Glyph: TGlyph): boolean; var BaseCode: cardinal; GlyphCode: integer; @@ -2346,7 +2678,7 @@ var begin Result := false; - BaseCode := cardinal(ch) shr 8; + BaseCode := Ord(ch) shr 8; GlyphTable := FindGlyphTable(BaseCode, InsertPos); if (GlyphTable = nil) then begin @@ -2356,7 +2688,7 @@ begin end; // get glyph table offset - GlyphCode := cardinal(ch) and $FF; + GlyphCode := Ord(ch) and $FF; // insert glyph into table if not present if (GlyphTable[GlyphCode] = nil) then begin @@ -2365,19 +2697,19 @@ begin end; end; -procedure TGlyphCache.DeleteGlyph(ch: WideChar); +procedure TGlyphCache.DeleteGlyph(ch: UCS4Char); var Table: PGlyphTable; TableIndex, GlyphIndex: integer; TableEmpty: boolean; begin // find table - Table := FindGlyphTable(cardinal(ch) shr 8, TableIndex); + Table := FindGlyphTable(Ord(ch) shr 8, TableIndex); if (Table = nil) then Exit; // find glyph - GlyphIndex := cardinal(ch) and $FF; + GlyphIndex := Ord(ch) and $FF; if (Table[GlyphIndex] <> nil) then begin // destroy glyph @@ -2402,19 +2734,19 @@ begin end; end; -function TGlyphCache.GetGlyph(ch: WideChar): TGlyph; +function TGlyphCache.GetGlyph(ch: UCS4Char): TGlyph; var InsertPos: integer; Table: PGlyphTable; begin - Table := FindGlyphTable(cardinal(ch) shr 8, InsertPos); + Table := FindGlyphTable(Ord(ch) shr 8, InsertPos); if (Table = nil) then Result := nil else - Result := Table[cardinal(ch) and $FF]; + Result := Table[Ord(ch) and $FF]; end; -function TGlyphCache.HasGlyph(ch: WideChar): boolean; +function TGlyphCache.HasGlyph(ch: UCS4Char): boolean; begin Result := (GetGlyph(ch) <> nil); end; @@ -2464,7 +2796,7 @@ begin begin // initialize freetype if (FT_Init_FreeType(LibraryInst) <> 0) then - raise Exception.Create('FT_Init_FreeType failed'); + raise EFontError.Create('FT_Init_FreeType failed'); end; Result := LibraryInst; end; @@ -2482,10 +2814,10 @@ end; * TBitmapFont *} -constructor TBitmapFont.Create(const Filename: string; Outline: integer; +constructor TBitmapFont.Create(const Filename: IPath; Outline: integer; Baseline, Ascender, Descender: integer); begin - inherited Create(); + inherited Create(Filename); fTex := Texture.LoadTexture(true, Filename, TEXTURE_TYPE_TRANSPARENT, 0); fTexSize := 1024; @@ -2494,7 +2826,7 @@ begin fAscender := Ascender; fDescender := Descender; - LoadFontInfo(ChangeFileExt(Filename, '.dat')); + LoadFontInfo(Filename.SetExtension('.dat')); ResetIntern(); end; @@ -2516,6 +2848,11 @@ begin ResetIntern(); end; +procedure TBitmapFont.AddFallback(const Filename: IPath); +begin + // no support for fallbacks +end; + procedure TBitmapFont.CorrectWidths(WidthMult: real; WidthAdd: integer); var Count: integer; @@ -2524,27 +2861,27 @@ begin fWidths[Count] := Round(fWidths[Count] * WidthMult) + WidthAdd; end; -procedure TBitmapFont.LoadFontInfo(const InfoFile: string); +procedure TBitmapFont.LoadFontInfo(const InfoFile: IPath); var - Stream: TFileStream; + Stream: TStream; begin FillChar(fWidths[0], Length(fWidths), 0); Stream := nil; try - Stream := TFileStream.Create(InfoFile, fmOpenRead); + Stream := TBinaryFileStream.Create(InfoFile, fmOpenRead); Stream.Read(fWidths, 256); except - raise Exception.Create('Could not read font info file ''' + InfoFile + ''''); + raise EFontError.Create('Could not read font info file ''' + InfoFile.ToNative + ''''); end; Stream.Free; end; -function TBitmapFont.BBox(const Text: TWideStringArray; Advance: boolean): TBoundsDbl; +function TBitmapFont.BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; var LineIndex, CharIndex: integer; CharCode: cardinal; - Line: WideString; + Line: UCS4String; LineWidth: double; begin Result.Left := 0; @@ -2556,7 +2893,7 @@ begin begin Line := Text[LineIndex]; LineWidth := 0; - for CharIndex := 1 to Length(Line) do + for CharIndex := 0 to LengthUCS4(Line)-1 do begin CharCode := Ord(Line[CharIndex]); if (CharCode < Length(fWidths)) then @@ -2567,7 +2904,7 @@ begin end; end; -procedure TBitmapFont.RenderChar(ch: WideChar; var AdvanceX: real); +procedure TBitmapFont.RenderChar(ch: UCS4Char; var AdvanceX: real); var TexX, TexY: real; TexR, TexB: real; @@ -2659,20 +2996,20 @@ begin AdvanceX := AdvanceX + GlyphWidth; end; -procedure TBitmapFont.Render(const Text: WideString); +procedure TBitmapFont.Render(const Text: UCS4String); var CharIndex: integer; AdvanceX: real; begin // if there is no text do nothing - if (Text = '') then + if (Text = nil) or (Text[0] = 0) then Exit; //Save the current color and alpha (for reflection) glGetFloatv(GL_CURRENT_COLOR, @fTempColor); AdvanceX := 0; - for CharIndex := 1 to Length(Text) do + for CharIndex := 0 to LengthUCS4(Text)-1 do begin RenderChar(Text[CharIndex], AdvanceX); end; diff --git a/cmake/src/base/UGraphic.pas b/cmake/src/base/UGraphic.pas index 818e49aa..4f0c8c77 100644 --- a/cmake/src/base/UGraphic.pas +++ b/cmake/src/base/UGraphic.pas @@ -45,7 +45,6 @@ uses UImage, UMusic, UScreenLoading, - UScreenWelcome, UScreenMain, UScreenName, UScreenLevel, @@ -71,12 +70,12 @@ uses UScreenSongMenu, UScreenSongJumpto, {Party Screens} - UScreenSingModi, UScreenPartyNewRound, UScreenPartyScore, UScreenPartyOptions, UScreenPartyWin, UScreenPartyPlayer, + UScreenPartyRounds, {Stats Screens} UScreenStatMain, UScreenStatDetail, @@ -107,7 +106,6 @@ var ScreenX: integer; ScreenLoading: TScreenLoading; - ScreenWelcome: TScreenWelcome; ScreenMain: TScreenMain; ScreenName: TScreenName; ScreenLevel: TScreenLevel; @@ -133,12 +131,13 @@ var ScreenSongJumpto: TScreenSongJumpto; //Party Screens - ScreenSingModi: TScreenSingModi; + //ScreenSingModi: TScreenSingModi; ScreenPartyNewRound: TScreenPartyNewRound; ScreenPartyScore: TScreenPartyScore; ScreenPartyWin: TScreenPartyWin; ScreenPartyOptions: TScreenPartyOptions; ScreenPartyPlayer: TScreenPartyPlayer; + ScreenPartyRounds: TScreenPartyRounds; //StatsScreens ScreenStatMain: TScreenStatMain; @@ -150,11 +149,12 @@ var //popup mod ScreenPopupCheck: TScreenPopupCheck; ScreenPopupError: TScreenPopupError; + ScreenPopupInfo: TScreenPopupInfo; //Notes - Tex_Left: array[0..6] of TTexture; //rename to tex_note_left - Tex_Mid: array[0..6] of TTexture; //rename to tex_note_mid - Tex_Right: array[0..6] of TTexture; //rename to tex_note_right + Tex_Left: array[1..6] of TTexture; //rename to tex_note_left + Tex_Mid: array[1..6] of TTexture; //rename to tex_note_mid + Tex_Right: array[1..6] of TTexture; //rename to tex_note_right Tex_plain_Left: array[1..6] of TTexture; //rename to tex_notebg_left Tex_plain_Mid: array[1..6] of TTexture; //rename to tex_notebg_mid @@ -206,6 +206,10 @@ var // textures for software mouse cursor Tex_Cursor_Unpressed: TTexture; Tex_Cursor_Pressed: TTexture; + + + PboSupported: boolean; + const Skin_BGColorR = 1; Skin_BGColorG = 1; @@ -261,6 +265,7 @@ const Skin_P2_ScoreL = 640; procedure Initialize3D (Title: string); +procedure Finalize3D; procedure Reinitialize3D; procedure SwapBuffers; @@ -268,7 +273,7 @@ procedure LoadTextures; procedure InitializeScreen; procedure LoadLoadingScreen; procedure LoadScreens; -procedure UnLoadScreens; +procedure UnloadScreens; function LoadingThreadFunction: integer; @@ -281,12 +286,18 @@ uses UIni, UDisplay, UCommandLine, - UPath; + UPathUtils; procedure LoadFontTextures; begin Log.LogStatus('Building Fonts', 'LoadTextures'); - BuildFont; + BuildFonts; +end; + +procedure UnloadFontTextures; +begin + Log.LogStatus('Kill Fonts', 'UnloadFontTextures'); + KillFonts; end; procedure LoadTextures; @@ -298,15 +309,6 @@ var begin Log.LogStatus('Loading Textures', 'LoadTextures'); - // FIXME: do we need this? (REMOVE otherwise) - Tex_Left[0] := Texture.LoadTexture(Skin.GetTextureFileName('GrayLeft'), TEXTURE_TYPE_TRANSPARENT, 0); - // FIXME: do we need this? (REMOVE otherwise) - Tex_Mid[0] := Texture.LoadTexture(Skin.GetTextureFileName('GrayMid'), TEXTURE_TYPE_PLAIN, 0); - // FIXME: do we need this? (REMOVE otherwise) - Tex_Right[0] := Texture.LoadTexture(Skin.GetTextureFileName('GrayRight'), TEXTURE_TYPE_TRANSPARENT, 0); - - Log.LogStatus('Loading Textures - A', 'LoadTextures'); - // P1-6 // TODO... do it once for each player... this is a bit crappy !! // can we make it any better !? @@ -314,7 +316,29 @@ begin begin LoadColor(R, G, B, 'P' + IntToStr(P) + 'Light'); Col := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - + + { some colors for tests + Col := $10000 * Round(0.02*255) + $100 * Round(0.6 *255) + Round(0.8 *255); //blue + Col := $10000 * Round(0.8 *255) ; //red + Col := $100 * Round(0.85*255) ; //green + Col := $10000 * 255 + $100 * Round(0.52*255) ; //orange + Col := $10000 * 255 + $100 * 255 ; //yellow + Col := $10000 * Round(0.82*255) + 255 ; //purple + Col := $10000 * Round(0.22*255) + $100 * Round(0.39*255) + Round(0.64*255); //dark blue + Col := $10000 * Round(0 *255) + $100 * Round(0 *255) + Round(0 *255); //black + Col := $10000 * Round(1.0 *255) + $100 * Round(0.43*255) + Round(0.70*255); //pink + Col := 0; //black + Col := $FFFFFF; //white + Col := $FF0000; //red + Col := $00FF00; //green + Col := $002200; //light green + Col := $002222; //light greenblue + Col := $222200; //light yellow + Col := $340000; //red + Col := $FF6EB4; //pink + Col := $333333; //grey + } + Tex_Left[P] := Texture.LoadTexture(Skin.GetTextureFileName('GrayLeft'), TEXTURE_TYPE_COLORIZED, Col); Tex_Mid[P] := Texture.LoadTexture(Skin.GetTextureFileName('GrayMid'), TEXTURE_TYPE_COLORIZED, Col); Tex_Right[P] := Texture.LoadTexture(Skin.GetTextureFileName('GrayRight'), TEXTURE_TYPE_COLORIZED, Col); @@ -340,7 +364,7 @@ begin Tex_Cursor_Unpressed := Texture.LoadTexture(Skin.GetTextureFileName('Cursor'), TEXTURE_TYPE_TRANSPARENT, 0); - if (Skin.GetTextureFileName('Cursor_Pressed') <> '') then + if (Skin.GetTextureFileName('Cursor_Pressed').IsSet) then Tex_Cursor_Pressed := Texture.LoadTexture(Skin.GetTextureFileName('Cursor_Pressed'), TEXTURE_TYPE_TRANSPARENT, 0) else Tex_Cursor_Pressed.TexNum := 0; @@ -389,14 +413,14 @@ begin End; Col := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - Tex_SingLineBonusBack[P] := Texture.LoadTexture(pchar(Skin.GetTextureFileName('LineBonusBack')), TEXTURE_TYPE_COLORIZED, Col); + Tex_SingLineBonusBack[P] := Texture.LoadTexture(Skin.GetTextureFileName('LineBonusBack'), TEXTURE_TYPE_COLORIZED, Col); end; //## backgrounds for the scores ## for P := 0 to 5 do begin LoadColor(R, G, B, 'P' + IntToStr(P+1) + 'Light'); Col := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - Tex_ScoreBG[P] := Texture.LoadTexture(pchar(Skin.GetTextureFileName('ScoreBG')), TEXTURE_TYPE_COLORIZED, Col); + Tex_ScoreBG[P] := Texture.LoadTexture(Skin.GetTextureFileName('ScoreBG'), TEXTURE_TYPE_COLORIZED, Col); end; @@ -411,23 +435,23 @@ begin //NoteBar ScoreBar LoadColor(R, G, B, 'P' + IntToStr(P) + 'Dark'); Col := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - Tex_Score_NoteBarLevel_Dark[P] := Texture.LoadTexture(pchar(Skin.GetTextureFileName('ScoreLevel_Dark')), TEXTURE_TYPE_COLORIZED, Col); - Tex_Score_NoteBarRound_Dark[P] := Texture.LoadTexture(pchar(Skin.GetTextureFileName('ScoreLevel_Dark_Round')), TEXTURE_TYPE_COLORIZED, Col); + Tex_Score_NoteBarLevel_Dark[P] := Texture.LoadTexture(Skin.GetTextureFileName('ScoreLevel_Dark'), TEXTURE_TYPE_COLORIZED, Col); + Tex_Score_NoteBarRound_Dark[P] := Texture.LoadTexture(Skin.GetTextureFileName('ScoreLevel_Dark_Round'), TEXTURE_TYPE_COLORIZED, Col); //LineBonus ScoreBar LoadColor(R, G, B, 'P' + IntToStr(P) + 'Light'); Col := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - Tex_Score_NoteBarLevel_Light[P] := Texture.LoadTexture(pchar(Skin.GetTextureFileName('ScoreLevel_Light')), TEXTURE_TYPE_COLORIZED, Col); - Tex_Score_NoteBarRound_Light[P] := Texture.LoadTexture(pchar(Skin.GetTextureFileName('ScoreLevel_Light_Round')), TEXTURE_TYPE_COLORIZED, Col); + Tex_Score_NoteBarLevel_Light[P] := Texture.LoadTexture(Skin.GetTextureFileName('ScoreLevel_Light'), TEXTURE_TYPE_COLORIZED, Col); + Tex_Score_NoteBarRound_Light[P] := Texture.LoadTexture(Skin.GetTextureFileName('ScoreLevel_Light_Round'), TEXTURE_TYPE_COLORIZED, Col); //GoldenNotes ScoreBar LoadColor(R, G, B, 'P' + IntToStr(P) + 'Lightest'); Col := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - Tex_Score_NoteBarLevel_Lightest[P] := Texture.LoadTexture(pchar(Skin.GetTextureFileName('ScoreLevel_Lightest')), TEXTURE_TYPE_COLORIZED, Col); - Tex_Score_NoteBarRound_Lightest[P] := Texture.LoadTexture(pchar(Skin.GetTextureFileName('ScoreLevel_Lightest_Round')), TEXTURE_TYPE_COLORIZED, Col); + Tex_Score_NoteBarLevel_Lightest[P] := Texture.LoadTexture(Skin.GetTextureFileName('ScoreLevel_Lightest'), TEXTURE_TYPE_COLORIZED, Col); + Tex_Score_NoteBarRound_Lightest[P] := Texture.LoadTexture(Skin.GetTextureFileName('ScoreLevel_Lightest_Round'), TEXTURE_TYPE_COLORIZED, Col); end; //## rating pictures that show a picture according to your rate ## for P := 0 to 7 do begin - Tex_Score_Ratings[P] := Texture.LoadTexture(pchar(Skin.GetTextureFileName('Rating_'+IntToStr(P))), TEXTURE_TYPE_TRANSPARENT, 0); + Tex_Score_Ratings[P] := Texture.LoadTexture(Skin.GetTextureFileName('Rating_'+IntToStr(P)), TEXTURE_TYPE_TRANSPARENT, 0); end; Log.LogStatus('Loading Textures - Done', 'LoadTextures'); @@ -448,6 +472,12 @@ begin // Other extensions e.g. OpenGL 1.3-2.0 or Framebuffer-Object might be loaded here // ... //Load_GL_EXT_framebuffer_object(); + + // PBO functions are loaded with VBO + //PboSupported := Load_GL_ARB_pixel_buffer_object() + // and Load_GL_ARB_vertex_buffer_object(); + //Log.LogWarn('PBOSupported: ' + BoolToStr(PboSupported, true), 'LoadOpenGLExtensions'); + PboSupported := false; end; const @@ -464,12 +494,17 @@ begin end; // load icon image (must be 32x32 for win32) - Icon := LoadImage(ResourcesPath + WINDOW_ICON); + Icon := LoadImage(ResourcesPath.Append(WINDOW_ICON)); if (Icon <> nil) then - SDL_WM_SetIcon(Icon, 0); + SDL_WM_SetIcon(Icon, nil); SDL_WM_SetCaption(PChar(Title), nil); + { center window } + SDL_putenv('SDL_VIDEO_WINDOW_POS=center'); + { workaround for buggy Intel 3D driver on Linux } + SDL_putenv('texture_tiling=false'); + //Log.BenchmarkStart(2); InitializeScreen; @@ -573,6 +608,13 @@ begin glMatrixMode(GL_MODELVIEW); end; +procedure Finalize3D; +begin + // TODO: finalize other stuff + UnloadFontTextures; + SDL_QuitSubSystem(SDL_INIT_VIDEO); +end; + procedure Reinitialize3D; begin InitializeScreen; @@ -667,7 +709,7 @@ end; procedure LoadLoadingScreen; begin ScreenLoading := TScreenLoading.Create; - ScreenLoading.onShow; + ScreenLoading.OnShow; Display.CurrentScreen := @ScreenLoading; @@ -682,15 +724,13 @@ end; procedure LoadScreens; begin { ScreenLoading := TScreenLoading.Create; - ScreenLoading.onShow; + ScreenLoading.OnShow; Display.CurrentScreen := @ScreenLoading; ScreenLoading.Draw; Display.Draw; SwapBuffers; } Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Loading', 3); Log.BenchmarkStart(3); -{ ScreenWelcome := TScreenWelcome.Create; //'BG', 4, 3); - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Welcome', 3); Log.BenchmarkStart(3);} ScreenMain := TScreenMain.Create; Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Main', 3); Log.BenchmarkStart(3); ScreenName := TScreenName.Create; @@ -733,8 +773,8 @@ begin // Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Edit Header', 3); Log.BenchmarkStart(3); ScreenOpen := TScreenOpen.Create; Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Open', 3); Log.BenchmarkStart(3); - ScreenSingModi := TScreenSingModi.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Sing with Modi support', 3); Log.BenchmarkStart(3); + //ScreenSingModi := TScreenSingModi.Create; + //Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Sing with Modi support', 3); Log.BenchmarkStart(3); ScreenSongMenu := TScreenSongMenu.Create; Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen SongMenu', 3); Log.BenchmarkStart(3); ScreenSongJumpto := TScreenSongJumpto.Create; @@ -743,6 +783,8 @@ begin Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Popup (Check)', 3); Log.BenchmarkStart(3); ScreenPopupError := TScreenPopupError.Create; Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Popup (Error)', 3); Log.BenchmarkStart(3); + ScreenPopupInfo := TScreenPopupInfo.Create; + Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Popup (Info)', 3); Log.BenchmarkStart(3); ScreenPartyNewRound := TScreenPartyNewRound.Create; Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen PartyNewRound', 3); Log.BenchmarkStart(3); ScreenPartyScore := TScreenPartyScore.Create; @@ -753,6 +795,8 @@ begin Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen PartyOptions', 3); Log.BenchmarkStart(3); ScreenPartyPlayer := TScreenPartyPlayer.Create; Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen PartyPlayer', 3); Log.BenchmarkStart(3); + ScreenPartyRounds := TScreenPartyRounds.Create; + Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen PartyRounds', 3); Log.BenchmarkStart(3); ScreenStatMain := TScreenStatMain.Create; Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Stat Main', 3); Log.BenchmarkStart(3); ScreenStatDetail := TScreenStatDetail.Create; @@ -768,39 +812,41 @@ begin Result:= 1; end; -procedure UnLoadScreens; +procedure UnloadScreens; begin - ScreenMain.Destroy; - ScreenName.Destroy; - ScreenLevel.Destroy; - ScreenSong.Destroy; - ScreenSing.Destroy; - ScreenScore.Destroy; - ScreenTop5.Destroy; - ScreenOptions.Destroy; - ScreenOptionsGame.Destroy; - ScreenOptionsGraphics.Destroy; - ScreenOptionsSound.Destroy; - ScreenOptionsLyrics.Destroy; -// ScreenOptionsThemes.Destroy; - ScreenOptionsRecord.Destroy; - ScreenOptionsAdvanced.Destroy; - ScreenEditSub.Destroy; - ScreenEdit.Destroy; - ScreenEditConvert.Destroy; - ScreenOpen.Destroy; - ScreenSingModi.Destroy; - ScreenSongMenu.Destroy; - ScreenSongJumpto.Destroy; - ScreenPopupCheck.Destroy; - ScreenPopupError.Destroy; - ScreenPartyNewRound.Destroy; - ScreenPartyScore.Destroy; - ScreenPartyWin.Destroy; - ScreenPartyOptions.Destroy; - ScreenPartyPlayer.Destroy; - ScreenStatMain.Destroy; - ScreenStatDetail.Destroy; + ScreenMain.Free; + ScreenName.Free; + ScreenLevel.Free; + ScreenSong.Free; + ScreenSing.Free; + ScreenScore.Free; + ScreenTop5.Free; + ScreenOptions.Free; + ScreenOptionsGame.Free; + ScreenOptionsGraphics.Free; + ScreenOptionsSound.Free; + ScreenOptionsLyrics.Free; +// ScreenOptionsThemes.Free; + ScreenOptionsRecord.Free; + ScreenOptionsAdvanced.Free; + ScreenEditSub.Free; + ScreenEdit.Free; + ScreenEditConvert.Free; + ScreenOpen.Free; + //ScreenSingModi.Free; + ScreenSongMenu.Free; + ScreenSongJumpto.Free; + ScreenPopupCheck.Free; + ScreenPopupError.Free; + ScreenPopupInfo.Free; + ScreenPartyNewRound.Free; + ScreenPartyScore.Free; + ScreenPartyWin.Free; + ScreenPartyOptions.Free; + ScreenPartyPlayer.Free; + ScreenPartyRounds.Free; + ScreenStatMain.Free; + ScreenStatDetail.Free; end; end. diff --git a/cmake/src/base/UImage.pas b/cmake/src/base/UImage.pas index 60b0a3a2..1866316e 100644 --- a/cmake/src/base/UImage.pas +++ b/cmake/src/base/UImage.pas @@ -34,7 +34,8 @@ interface {$I switches.inc} uses - SDL; + SDL, + UPath; {$DEFINE HavePNG} {$DEFINE HaveBMP} @@ -131,20 +132,20 @@ type *******************************************************) {$IFDEF HavePNG} -function WritePNGImage(const FileName: string; Surface: PSDL_Surface): boolean; +function WritePNGImage(const FileName: IPath; Surface: PSDL_Surface): boolean; {$ENDIF} {$IFDEF HaveBMP} -function WriteBMPImage(const FileName: string; Surface: PSDL_Surface): boolean; +function WriteBMPImage(const FileName: IPath; Surface: PSDL_Surface): boolean; {$ENDIF} {$IFDEF HaveJPG} -function WriteJPGImage(const FileName: string; Surface: PSDL_Surface; Quality: integer): boolean; +function WriteJPGImage(const FileName: IPath; Surface: PSDL_Surface; Quality: integer): boolean; {$ENDIF} (******************************************************* * Image loading *******************************************************) -function LoadImage(const Filename: string): PSDL_Surface; +function LoadImage(const Filename: IPath): PSDL_Surface; (******************************************************* * Image manipulation @@ -181,6 +182,7 @@ uses zlib, sdl_image, sdlutils, + sdlstreams, UCommon, ULog; @@ -282,26 +284,26 @@ end; procedure user_read_data(png_ptr: png_structp; data: png_bytep; length: png_size_t); cdecl; var - inFile: TFileStream; + inFile: TStream; begin - inFile := TFileStream(png_get_io_ptr(png_ptr)); + inFile := TStream(png_get_io_ptr(png_ptr)); inFile.Read(data^, length); end; procedure user_write_data(png_ptr: png_structp; data: png_bytep; length: png_size_t); cdecl; var - outFile: TFileStream; + outFile: TStream; begin - outFile := TFileStream(png_get_io_ptr(png_ptr)); + outFile := TStream(png_get_io_ptr(png_ptr)); outFile.Write(data^, length); end; procedure user_flush_data(png_ptr: png_structp); cdecl; //var -// outFile: TFileStream; +// outFile: TStream; begin // binary files are flushed automatically, Flush() works with Text-files only - //outFile := TFileStream(png_get_io_ptr(png_ptr)); + //outFile := TStream(png_get_io_ptr(png_ptr)); //outFile.Flush(); end; @@ -323,11 +325,11 @@ end; (* * ImageData must be in RGB-format *) -function WritePNGImage(const FileName: string; Surface: PSDL_Surface): boolean; +function WritePNGImage(const FileName: IPath; Surface: PSDL_Surface): boolean; var png_ptr: png_structp; info_ptr: png_infop; - pngFile: TFileStream; + pngFile: TStream; row: integer; rowData: array of png_bytep; // rowStride: integer; @@ -339,9 +341,9 @@ begin // open file for writing try - pngFile := TFileStream.Create(FileName, fmCreate); + pngFile := TBinaryFileStream.Create(FileName, fmCreate); except - Log.LogError('Could not open file: "' + FileName + '"', 'WritePngImage'); + Log.LogError('Could not open file: "' + FileName.ToNative + '"', 'WritePngImage'); Exit; end; @@ -500,9 +502,9 @@ type (* * ImageData must be in BGR-format *) -function WriteBMPImage(const FileName: string; Surface: PSDL_Surface): boolean; +function WriteBMPImage(const FileName: IPath; Surface: PSDL_Surface): boolean; var - bmpFile: TFileStream; + bmpFile: TStream; FileInfo: BITMAPINFOHEADER; FileHeader: BITMAPFILEHEADER; Converted: boolean; @@ -513,9 +515,9 @@ begin // open file for writing try - bmpFile := TFileStream.Create(FileName, fmCreate); + bmpFile := TBinaryFileStream.Create(FileName, fmCreate); except - Log.LogError('Could not open file: "' + FileName + '"', 'WriteBMPImage'); + Log.LogError('Could not open file: "' + FileName.ToNative + '"', 'WriteBMPImage'); Exit; end; @@ -579,7 +581,7 @@ begin Result := true; finally - Log.LogError('Could not write file: "' + FileName + '"', 'WriteBMPImage'); + Log.LogError('Could not write file: "' + FileName.ToNative + '"', 'WriteBMPImage'); end; if (Converted) then @@ -597,20 +599,21 @@ end; {$IFDEF HaveJPG} -function WriteJPGImage(const FileName: string; Surface: PSDL_Surface; Quality: integer): boolean; +function WriteJPGImage(const FileName: IPath; Surface: PSDL_Surface; Quality: integer): boolean; var {$IFDEF Delphi} - Bitmap: TBitmap; + Bitmap: TBitmap; BitmapInfo: TBitmapInfo; - Jpeg: TJpegImage; - row: integer; + Jpeg: TJpegImage; + row: integer; + FileStream: TBinaryFileStream; {$ELSE} cinfo: jpeg_compress_struct; jerr : jpeg_error_mgr; - jpgFile: TFileStream; + jpgFile: TBinaryFileStream; rowPtr: array[0..0] of JSAMPROW; {$ENDIF} - converted: boolean; + converted: boolean; begin Result := false; @@ -669,19 +672,32 @@ begin SDL_UnlockSurface(Surface); // assign Bitmap to JPEG and store the latter - Jpeg := TJPEGImage.Create; - Jpeg.Assign(Bitmap); - Bitmap.Free; - Jpeg.CompressionQuality := Quality; try - // compress image (don't forget this line, otherwise it won't be compressed) - Jpeg.Compress(); - Jpeg.SaveToFile(FileName); + // init with nil so Free() will not fail if an exception occurs + Jpeg := nil; + Bitmap := nil; + FileStream := nil; + + try + Jpeg := TJPEGImage.Create; + Jpeg.Assign(Bitmap); + + // compress image (don't forget this line, otherwise it won't be compressed) + Jpeg.CompressionQuality := Quality; + Jpeg.Compress(); + + // Note: FileStream needed for unicode filename support + FileStream := TBinaryFileStream.Create(Filename, fmCreate); + Jpeg.SaveToStream(FileStream); + finally + FileStream.Free; + Bitmap.Free; + Jpeg.Free; + end; except - Log.LogError('Could not save file: "' + FileName + '"', 'WriteJPGImage'); + Log.LogError('Could not save file: "' + FileName.ToNative + '"', 'WriteJPGImage'); Exit; end; - Jpeg.Free; {$ELSE} // based on example.pas in FPC's packages/base/pasjpeg directory @@ -703,9 +719,9 @@ begin // open file for writing try - jpgFile := TFileStream.Create(FileName, fmCreate); + jpgFile := TBinaryFileStream.Create(FileName, fmCreate); except - Log.LogError('Could not open file: "' + FileName + '"', 'WriteJPGImage'); + Log.LogError('Could not open file: "' + FileName.ToNative + '"', 'WriteJPGImage'); Exit; end; @@ -763,27 +779,29 @@ end; (* * Loads an image from the given file *) -function LoadImage(const Filename: string): PSDL_Surface; +function LoadImage(const Filename: IPath): PSDL_Surface; var - FilenameFound: string; + FilenameCaseAdj: IPath; + FileStream: TBinaryFileStream; + SDLStream: PSDL_RWops; begin - Result := nil; + Result := nil; - // FileExistsInsensitive() requires a var-arg - FilenameFound := Filename; - - // try to find the file case insensitive - if (not FileExistsInsensitive(FilenameFound)) then + // try to adjust filename's case and check if it exists + FilenameCaseAdj := Filename.AdjustCase(false); + if (not FilenameCaseAdj.IsFile) then begin - Log.LogError('Image-File does not exist "'+FilenameFound+'"', 'LoadImage'); + Log.LogError('Image-File does not exist "' + FilenameCaseAdj.ToNative + '"', 'LoadImage'); Exit; end; // load from file try - Result := IMG_Load(PChar(FilenameFound)); + SDLStream := SDLStreamSetup(TBinaryFileStream.Create(FilenameCaseAdj, fmOpenRead)); + Result := IMG_Load_RW(SDLStream, 1); + // Note: TBinaryFileStream is freed by SDLStream. SDLStream by IMG_Load_RW(). except - Log.LogError('Could not load from file "'+FilenameFound+'"', 'LoadImage'); + Log.LogError('Could not load from file "' + FilenameCaseAdj.ToNative + '"', 'LoadImage'); Exit; end; end; @@ -794,17 +812,13 @@ end; function PixelFormatEquals(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; + Result := + (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) + ; end; procedure ScaleImage(var ImgSurface: PSDL_Surface; Width, Height: cardinal); @@ -885,7 +899,7 @@ begin end; *) -procedure ColorizeImage(ImgSurface: PSDL_Surface; NewColor: cardinal); +procedure ColorizeImage(ImgSurface: PSDL_Surface; NewColor: longword); // First, the rgb colors are converted to hsv, second hue is replaced by // the NewColor, saturation and value remain unchanged, finally this @@ -893,7 +907,7 @@ procedure ColorizeImage(ImgSurface: PSDL_Surface; NewColor: cardinal); // For the conversion algorithms of colors from rgb to hsv space // and back simply check the wikipedia. // In order to speed up starting time of USDX the division of reals is - // replaced by division of longwords, shifted by 10 bits to keep + // replaced by division of longints, shifted by 10 bits to keep // digits. // The use of longwards leeds to some type size mismatch warnings @@ -904,8 +918,8 @@ procedure ColorizeImage(ImgSurface: PSDL_Surface; NewColor: cardinal); function ColorToHue(const Color: longword): longword; // returns hue within the range [0.0-6.0] but shl 10, ie. times 1024 var - Red, Green, Blue: longword; - Min, Max, Delta: longword; + Red, Green, Blue: longint; + Min, Max, Delta: longint; Hue: double; begin // extract the colors @@ -933,6 +947,8 @@ procedure ColorizeImage(ImgSurface: PSDL_Surface; NewColor: cardinal); // The division by Delta is done separately afterwards. // Necessary because Delphi did not do the type conversion from // longword to double as expected. + // After the change to longint, we may not need it, but left for now + // Something to check if (Max = Red ) then Hue := Green - Blue else if (Max = Green) then Hue := 2.0*Delta + Blue - Red else if (Max = Blue ) then Hue := 4.0*Delta + Red - Green; @@ -940,6 +956,8 @@ procedure ColorizeImage(ImgSurface: PSDL_Surface; NewColor: cardinal); if (Hue < 0.0) then Hue := Hue + 6.0; Result := trunc(Hue*1024); // '*1024' is shl 10 + // if NewColor = $000000 then + // Log.LogError ('Hue: ' + FloatToStr(Hue), 'ColorToHue'); end; end; @@ -952,6 +970,8 @@ var Min, Max, Delta: longword; HueInteger: longword; f, p, q, t: longword; + GreyReal: real; + Grey: byte; begin Pixel := ImgSurface^.Pixels; @@ -965,8 +985,48 @@ begin Log.LogError ('ColorizeImage: The pixel size should be 4, but it is ' + IntToStr(ImgSurface^.format.BytesPerPixel)); + // Check whether the new color is white, grey or black, + // because a greyscale must be created in a different + // way. + + Red := ((NewColor and $ff0000) shr 16); // R + Green := ((NewColor and $ff00) shr 8); // G + Blue := (NewColor and $ff) ; // B + + if (Red = Green) and (Green = Blue) then // greyscale image + begin + // According to these recommendations (ITU-R BT.709-5) + // the conversion parameters for rgb to greyscale are + // 0.299, 0.587, 0.114 + for PixelIndex := 0 to (ImgSurface^.W * ImgSurface^.H)-1 do + begin + PixelColors := PByteArray(Pixel); + {$IFDEF FPC_BIG_ENDIAN} + GreyReal := 0.299*PixelColors[3] + 0.587*PixelColors[2] + 0.114*PixelColors[1]; + // PixelColors[0] is alpha and remains untouched + {$ELSE} + GreyReal := 0.299*PixelColors[0] + 0.587*PixelColors[1] + 0.114*PixelColors[2]; + // PixelColors[3] is alpha and remains untouched + {$ENDIF} + Grey := round(GreyReal); + {$IFDEF FPC_BIG_ENDIAN} + PixelColors[3] := Grey; + PixelColors[2] := Grey; + PixelColors[1] := Grey; + // PixelColors[0] is alpha and remains untouched + {$ELSE} + PixelColors[0] := Grey; + PixelColors[1] := Grey; + PixelColors[2] := Grey; + // PixelColors[3] is alpha and remains untouched + {$ENDIF} + Inc(Pixel, ImgSurface^.format.BytesPerPixel); + end; + exit; // we are done with a greyscale image. + end; + Hue := ColorToHue(NewColor); // Hue is shl 10 - f := Hue and $3ff; // f is the dezimal part of hue + f := Hue and $3ff; // f is the dezimal part of hue HueInteger := Hue shr 10; for PixelIndex := 0 to (ImgSurface^.W * ImgSurface^.H)-1 do @@ -1036,9 +1096,9 @@ begin // shr 10 corrects that Sat and f are shl 10 // the resulting p, q and t are unshifted - p := (Max*(1024-Sat)) shr 10; - q := (Max*(1024-(Sat*f) shr 10)) shr 10; - t := (Max*(1024-(Sat*(1024-f)) shr 10)) shr 10; + p := (Max * (1024 - Sat )) shr 10; + q := (Max * (1024 - (Sat * f ) shr 10)) shr 10; + t := (Max * (1024 - (Sat * (1024 - f)) shr 10)) shr 10; // The above 3 lines give type size mismatch warning, but all variables are longword and the ranges should be ok. diff --git a/cmake/src/base/UIni.pas b/cmake/src/base/UIni.pas index 2bcc7305..a4c85a3b 100644 --- a/cmake/src/base/UIni.pas +++ b/cmake/src/base/UIni.pas @@ -36,8 +36,12 @@ interface uses Classes, IniFiles, + SysUtils, + UCommon, ULog, - SysUtils; + UTextEncoding, + UFilesystem, + UPath; type // TInputDeviceConfig stores the configuration for an input device. @@ -59,9 +63,13 @@ type TInputDeviceConfig = record Name: string; Input: integer; + Latency: integer; //**< latency in ms, or LATENCY_AUTODETECT for default ChannelToPlayerMap: array of integer; end; +const + LATENCY_AUTODETECT = -1; + type //Options @@ -70,11 +78,9 @@ type TBackgroundMusicOption = (bmoOff, bmoOn); TIni = class private - function RemoveFileExt(FullName: string): string; function ExtractKeyIndex(const Key, Prefix, Suffix: string): integer; function GetMaxKeyIndex(Keys: TStringList; const Prefix, Suffix: string): integer; - function GetArrayIndex(const SearchArray: array of string; Value: string; CaseInsensitiv: boolean = false): integer; - function ReadArrayIndex(const SearchArray: array of string; IniFile: TCustomIniFile; + function ReadArrayIndex(const SearchArray: array of UTF8String; IniFile: TCustomIniFile; IniSection: string; IniProperty: string; Default: integer): integer; procedure TranslateOptionValues; @@ -85,14 +91,14 @@ type procedure LoadScreenModes(IniFile: TCustomIniFile); public - Name: array[0..11] of string; + Name: array[0..11] of UTF8String; // Templates for Names Mod - NameTeam: array[0..2] of string; - NameTemplate: array[0..11] of string; + NameTeam: array[0..2] of UTF8String; + NameTemplate: array[0..11] of UTF8String; //Filename of the opened iniFile - Filename: string; + Filename: IPath; // Game Players: integer; @@ -125,6 +131,8 @@ type AudioOutputBufferSizeIndex: integer; VoicePassthrough: integer; + SyncTo: integer; + //Song Preview PreviewVolume: integer; PreviewFading: integer; @@ -132,7 +140,6 @@ type // Lyrics LyricsFont: integer; LyricsEffect: integer; - Solmization: integer; NoteLines: integer; // Themes @@ -165,173 +172,205 @@ type var Ini: TIni; - IResolution: array of string; - ILanguage: array of string; - ITheme: array of string; - ISkin: array of string; + IResolution: TUTF8StringDynArray; + ILanguage: TUTF8StringDynArray; + ITheme: TUTF8StringDynArray; + ISkin: TUTF8StringDynArray; + +{* + * Options + *} const - IPlayers: array[0..4] of string = ('1', '2', '3', '4', '6'); - IPlayersVals: array[0..4] of integer = ( 1 , 2 , 3 , 4 , 6 ); + IPlayers: array[0..4] of UTF8String = ('1', '2', '3', '4', '6'); + IPlayersVals: array[0..4] of integer = ( 1 , 2 , 3 , 4 , 6 ); - IDifficulty: array[0..2] of string = ('Easy', 'Medium', 'Hard'); - ITabs: array[0..1] of string = ('Off', 'On'); + IDifficulty: array[0..2] of UTF8String = ('Easy', 'Medium', 'Hard'); + ITabs: array[0..1] of UTF8String = ('Off', 'On'); - ISorting: array[0..7] of string = ('Edition', 'Genre', 'Language', 'Folder', 'Title', 'Artist', 'Title2', 'Artist2'); - sEdition = 0; - sGenre = 1; - sLanguage = 2; - sFolder = 3; - sTitle = 4; - sArtist = 5; - sTitle2 = 6; - sArtist2 = 7; +const + ISorting: array[0..6] of UTF8String = ('Edition', 'Genre', 'Language', 'Folder', 'Title', 'Artist', 'Artist2'); +type + TSortingType = (sEdition, sGenre, sLanguage, sFolder, sTitle, sArtist, sArtist2); - IDebug: array[0..1] of string = ('Off', 'On'); +const + IDebug: array[0..1] of UTF8String = ('Off', 'On'); - IScreens: array[0..1] of string = ('1', '2'); - IFullScreen: array[0..1] of string = ('Off', 'On'); - IDepth: array[0..1] of string = ('16 bit', '32 bit'); - IVisualizer: array[0..2] of string = ('Off', 'WhenNoVideo','On'); + IScreens: array[0..1] of UTF8String = ('1', '2'); + IFullScreen: array[0..1] of UTF8String = ('Off', 'On'); + IDepth: array[0..1] of UTF8String = ('16 bit', '32 bit'); + IVisualizer: array[0..2] of UTF8String = ('Off', 'WhenNoVideo','On'); - IBackgroundMusic: array[0..1] of string = ('Off', 'On'); + IBackgroundMusic: array[0..1] of UTF8String = ('Off', 'On'); - ITextureSize: array[0..3] of string = ('64', '128', '256', '512'); - ITextureSizeVals: array[0..3] of integer = ( 64, 128, 256, 512); + ITextureSize: array[0..3] of UTF8String = ('64', '128', '256', '512'); + ITextureSizeVals: array[0..3] of integer = ( 64, 128, 256, 512); - ISingWindow: array[0..1] of string = ('Small', 'Big'); + ISingWindow: array[0..1] of UTF8String = ('Small', 'Big'); //SingBar Mod - IOscilloscope: array[0..1] of string = ('Off', 'On'); + IOscilloscope: array[0..1] of UTF8String = ('Off', 'On'); - ISpectrum: array[0..1] of string = ('Off', 'On'); - ISpectrograph: array[0..1] of string = ('Off', 'On'); - IMovieSize: array[0..2] of string = ('Half', 'Full [Vid]', 'Full [BG+Vid]'); + ISpectrum: array[0..1] of UTF8String = ('Off', 'On'); + ISpectrograph: array[0..1] of UTF8String = ('Off', 'On'); + IMovieSize: array[0..2] of UTF8String = ('Half', 'Full [Vid]', 'Full [BG+Vid]'); - IClickAssist: array[0..1] of string = ('Off', 'On'); - IBeatClick: array[0..1] of string = ('Off', 'On'); - ISavePlayback: array[0..1] of string = ('Off', 'On'); + IClickAssist: array[0..1] of UTF8String = ('Off', 'On'); + IBeatClick: array[0..1] of UTF8String = ('Off', 'On'); + ISavePlayback: array[0..1] of UTF8String = ('Off', 'On'); - IThreshold: array[0..3] of string = ('5%', '10%', '15%', '20%'); + IThreshold: array[0..3] of UTF8String = ('5%', '10%', '15%', '20%'); IThresholdVals: array[0..3] of single = (0.05, 0.10, 0.15, 0.20); - IVoicePassthrough: array[0..1] of string = ('Off', 'On'); + IVoicePassthrough: array[0..1] of UTF8String = ('Off', 'On'); + +const + ISyncTo: array[0..2] of UTF8String = ('Music', 'Lyrics', 'Off'); +type + TSyncToType = (stMusic, stLyrics, stOff); - IAudioOutputBufferSize: array[0..9] of string = ('Auto', '256', '512', '1024', '2048', '4096', '8192', '16384', '32768', '65536'); - IAudioOutputBufferSizeVals: array[0..9] of integer = ( 0, 256, 512 , 1024 , 2048 , 4096 , 8192 , 16384 , 32768 , 65536 ); +const + IAudioOutputBufferSize: array[0..9] of UTF8String = ('Auto', '256', '512', '1024', '2048', '4096', '8192', '16384', '32768', '65536'); + IAudioOutputBufferSizeVals: array[0..9] of integer = ( 0, 256, 512 , 1024 , 2048 , 4096 , 8192 , 16384 , 32768 , 65536 ); - IAudioInputBufferSize: array[0..9] of string = ('Auto', '256', '512', '1024', '2048', '4096', '8192', '16384', '32768', '65536'); - IAudioInputBufferSizeVals: array[0..9] of integer = ( 0, 256, 512 , 1024 , 2048 , 4096 , 8192 , 16384 , 32768 , 65536 ); + IAudioInputBufferSize: array[0..9] of UTF8String = ('Auto', '256', '512', '1024', '2048', '4096', '8192', '16384', '32768', '65536'); + IAudioInputBufferSizeVals: array[0..9] of integer = ( 0, 256, 512 , 1024 , 2048 , 4096 , 8192 , 16384 , 32768 , 65536 ); //Song Preview - IPreviewVolume: array[0..10] of string = ('Off', '10%', '20%', '30%', '40%', '50%', '60%', '70%', '80%', '90%', '100%'); - IPreviewVolumeVals: array[0..10] of single = ( 0, 0.10, 0.20, 0.30, 0.40, 0.50, 0.60, 0.70, 0.80, 0.90, 1.00 ); + IPreviewVolume: array[0..10] of UTF8String = ('Off', '10%', '20%', '30%', '40%', '50%', '60%', '70%', '80%', '90%', '100%'); + IPreviewVolumeVals: array[0..10] of single = ( 0, 0.10, 0.20, 0.30, 0.40, 0.50, 0.60, 0.70, 0.80, 0.90, 1.00 ); - IPreviewFading: array[0..5] of string = ('Off', '1 Sec', '2 Secs', '3 Secs', '4 Secs', '5 Secs'); - IPreviewFadingVals: array[0..5] of integer = ( 0, 1, 2, 3, 4, 5 ); + IPreviewFading: array[0..5] of UTF8String = ('Off', '1 Sec', '2 Secs', '3 Secs', '4 Secs', '5 Secs'); + IPreviewFadingVals: array[0..5] of integer = ( 0, 1, 2, 3, 4, 5 ); - ILyricsFont: array[0..2] of string = ('Plain', 'OLine1', 'OLine2'); - ILyricsEffect: array[0..4] of string = ('Simple', 'Zoom', 'Slide', 'Ball', 'Shift'); - ISolmization: array[0..3] of string = ('Off', 'Euro', 'Jap', 'American'); - INoteLines: array[0..1] of string = ('Off', 'On'); + ILyricsFont: array[0..2] of UTF8String = ('Plain', 'OLine1', 'OLine2'); + ILyricsEffect: array[0..4] of UTF8String = ('Simple', 'Zoom', 'Slide', 'Ball', 'Shift'); + INoteLines: array[0..1] of UTF8String = ('Off', 'On'); - IColor: array[0..8] of string = ('Blue', 'Green', 'Pink', 'Red', 'Violet', 'Orange', 'Yellow', 'Brown', 'Black'); + IColor: array[0..8] of UTF8String = ('Blue', 'Green', 'Pink', 'Red', 'Violet', 'Orange', 'Yellow', 'Brown', 'Black'); // Advanced - ILoadAnimation: array[0..1] of string = ('Off', 'On'); - IEffectSing: array[0..1] of string = ('Off', 'On'); - IScreenFade: array[0..1] of string = ('Off', 'On'); - IAskbeforeDel: array[0..1] of string = ('Off', 'On'); - IOnSongClick: array[0..2] of string = ('Sing', 'Select Players', 'Open Menu'); - ILineBonus: array[0..1] of string = ('Off', 'On'); - IPartyPopup: array[0..1] of string = ('Off', 'On'); + ILoadAnimation: array[0..1] of UTF8String = ('Off', 'On'); + IEffectSing: array[0..1] of UTF8String = ('Off', 'On'); + IScreenFade: array[0..1] of UTF8String = ('Off', 'On'); + IAskbeforeDel: array[0..1] of UTF8String = ('Off', 'On'); + IOnSongClick: array[0..2] of UTF8String = ('Sing', 'Select Players', 'Open Menu'); + sStartSing = 0; + sSelectPlayer = 1; + sOpenMenu = 2; + + ILineBonus: array[0..1] of UTF8String = ('Off', 'On'); + IPartyPopup: array[0..1] of UTF8String = ('Off', 'On'); - IJoypad: array[0..1] of string = ('Off', 'On'); - IMouse: array[0..2] of string = ('Off', 'Hardware Cursor', 'Software Cursor'); + IJoypad: array[0..1] of UTF8String = ('Off', 'On'); + IMouse: array[0..2] of UTF8String = ('Off', 'Hardware Cursor', 'Software Cursor'); // Recording options - IChannelPlayer: array[0..6] of string = ('Off', '1', '2', '3', '4', '5', '6'); - IMicBoost: array[0..3] of string = ('Off', '+6dB', '+12dB', '+18dB'); + IChannelPlayer: array[0..6] of UTF8String = ('Off', '1', '2', '3', '4', '5', '6'); + IMicBoost: array[0..3] of UTF8String = ('Off', '+6dB', '+12dB', '+18dB'); + +{* + * Translated options + *} var - IDifficultyTranslated: array[0..2] of string = ('Easy', 'Medium', 'Hard'); - ITabsTranslated: array[0..1] of string = ('Off', 'On'); + ILanguageTranslated: array of UTF8String; - ISortingTranslated: array[0..7] of string = ('Edition', 'Genre', 'Language', 'Folder', 'Title', 'Artist', 'Title2', 'Artist2'); + IDifficultyTranslated: array[0..2] of UTF8String = ('Easy', 'Medium', 'Hard'); + ITabsTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IDebugTranslated: array[0..1] of string = ('Off', 'On'); + ISortingTranslated: array[0..6] of UTF8String = ('Edition', 'Genre', 'Language', 'Folder', 'Title', 'Artist', 'Artist2'); - IFullScreenTranslated: array[0..1] of string = ('Off', 'On'); - IVisualizerTranslated: array[0..2] of string = ('Off', 'WhenNoVideo','On'); + IDebugTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IBackgroundMusicTranslated: array[0..1] of string = ('Off', 'On'); - ISingWindowTranslated: array[0..1] of string = ('Small', 'Big'); + IFullScreenTranslated: array[0..1] of UTF8String = ('Off', 'On'); + IVisualizerTranslated: array[0..2] of UTF8String = ('Off', 'WhenNoVideo','On'); + + IBackgroundMusicTranslated: array[0..1] of UTF8String = ('Off', 'On'); + ISingWindowTranslated: array[0..1] of UTF8String = ('Small', 'Big'); //SingBar Mod - IOscilloscopeTranslated: array[0..1] of string = ('Off', 'On'); + IOscilloscopeTranslated: array[0..1] of UTF8String = ('Off', 'On'); + + ISpectrumTranslated: array[0..1] of UTF8String = ('Off', 'On'); + ISpectrographTranslated: array[0..1] of UTF8String = ('Off', 'On'); + IMovieSizeTranslated: array[0..2] of UTF8String = ('Half', 'Full [Vid]', 'Full [BG+Vid]'); - ISpectrumTranslated: array[0..1] of string = ('Off', 'On'); - ISpectrographTranslated: array[0..1] of string = ('Off', 'On'); - IMovieSizeTranslated: array[0..2] of string = ('Half', 'Full [Vid]', 'Full [BG+Vid]'); + IClickAssistTranslated: array[0..1] of UTF8String = ('Off', 'On'); + IBeatClickTranslated: array[0..1] of UTF8String = ('Off', 'On'); + ISavePlaybackTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IClickAssistTranslated: array[0..1] of string = ('Off', 'On'); - IBeatClickTranslated: array[0..1] of string = ('Off', 'On'); - ISavePlaybackTranslated: array[0..1] of string = ('Off', 'On'); + IVoicePassthroughTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IVoicePassthroughTranslated: array[0..1] of string = ('Off', 'On'); + ISyncToTranslated: array[0..2] of UTF8String = ('Music', 'Lyrics', 'Off'); //Song Preview - IPreviewVolumeTranslated: array[0..10] of string = ('Off', '10%', '20%', '30%', '40%', '50%', '60%', '70%', '80%', '90%', '100%'); + IPreviewVolumeTranslated: array[0..10] of UTF8String = ('Off', '10%', '20%', '30%', '40%', '50%', '60%', '70%', '80%', '90%', '100%'); - IAudioOutputBufferSizeTranslated: array[0..9] of string = ('Auto', '256', '512', '1024', '2048', '4096', '8192', '16384', '32768', '65536'); + IAudioOutputBufferSizeTranslated: array[0..9] of UTF8String = ('Auto', '256', '512', '1024', '2048', '4096', '8192', '16384', '32768', '65536'); - IAudioInputBufferSizeTranslated: array[0..9] of string = ('Auto', '256', '512', '1024', '2048', '4096', '8192', '16384', '32768', '65536'); + IAudioInputBufferSizeTranslated: array[0..9] of UTF8String = ('Auto', '256', '512', '1024', '2048', '4096', '8192', '16384', '32768', '65536'); - IPreviewFadingTranslated: array[0..5] of string = ('Off', '1 Sec', '2 Secs', '3 Secs', '4 Secs', '5 Secs'); + IPreviewFadingTranslated: array[0..5] of UTF8String = ('Off', '1 Sec', '2 Secs', '3 Secs', '4 Secs', '5 Secs'); - ILyricsFontTranslated: array[0..2] of string = ('Plain', 'OLine1', 'OLine2'); - ILyricsEffectTranslated: array[0..4] of string = ('Simple', 'Zoom', 'Slide', 'Ball', 'Shift'); - ISolmizationTranslated: array[0..3] of string = ('Off', 'Euro', 'Jap', 'American'); - INoteLinesTranslated: array[0..1] of string = ('Off', 'On'); + ILyricsFontTranslated: array[0..2] of UTF8String = ('Plain', 'OLine1', 'OLine2'); + ILyricsEffectTranslated: array[0..4] of UTF8String = ('Simple', 'Zoom', 'Slide', 'Ball', 'Shift'); + INoteLinesTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IColorTranslated: array[0..8] of string = ('Blue', 'Green', 'Pink', 'Red', 'Violet', 'Orange', 'Yellow', 'Brown', 'Black'); + IColorTranslated: array[0..8] of UTF8String = ('Blue', 'Green', 'Pink', 'Red', 'Violet', 'Orange', 'Yellow', 'Brown', 'Black'); // Advanced - ILoadAnimationTranslated: array[0..1] of string = ('Off', 'On'); - IEffectSingTranslated: array[0..1] of string = ('Off', 'On'); - IScreenFadeTranslated: array[0..1] of string = ('Off', 'On'); - IAskbeforeDelTranslated: array[0..1] of string = ('Off', 'On'); - IOnSongClickTranslated: array[0..2] of string = ('Sing', 'Select Players', 'Open Menu'); - ILineBonusTranslated: array[0..1] of string = ('Off', 'On'); - IPartyPopupTranslated: array[0..1] of string = ('Off', 'On'); + ILoadAnimationTranslated: array[0..1] of UTF8String = ('Off', 'On'); + IEffectSingTranslated: array[0..1] of UTF8String = ('Off', 'On'); + IScreenFadeTranslated: array[0..1] of UTF8String = ('Off', 'On'); + IAskbeforeDelTranslated: array[0..1] of UTF8String = ('Off', 'On'); + IOnSongClickTranslated: array[0..2] of UTF8String = ('Sing', 'Select Players', 'Open Menu'); + ILineBonusTranslated: array[0..1] of UTF8String = ('Off', 'On'); + IPartyPopupTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IJoypadTranslated: array[0..1] of string = ('Off', 'On'); - IMouseTranslated: array[0..2] of string = ('Off', 'Hardware Cursor', 'Software Cursor'); + IJoypadTranslated: array[0..1] of UTF8String = ('Off', 'On'); + IMouseTranslated: array[0..2] of UTF8String = ('Off', 'Hardware Cursor', 'Software Cursor'); // Recording options - IChannelPlayerTranslated: array[0..6] of string = ('Off', '1', '2', '3', '4', '5', '6'); - IMicBoostTranslated: array[0..3] of string = ('Off', '+6dB', '+12dB', '+18dB'); + IChannelPlayerTranslated: array[0..6] of UTF8String = ('Off', '1', '2', '3', '4', '5', '6'); + IMicBoostTranslated: array[0..3] of UTF8String = ('Off', '+6dB', '+12dB', '+18dB'); implementation uses StrUtils, - UMain, SDL, + UCommandLine, ULanguage, UPlatform, - USkins, + UMain, URecord, - UCommandLine, - UPath; + USkins, + UThemes, + UPathUtils, + UUnicodeUtils; (** * Translate and set the values of options, which need translation. *) procedure TIni.TranslateOptionValues; +var + I: integer; begin - ULanguage.Language.ChangeLanguage(ILanguage[Language]); - + // Load Languagefile + if (Params.Language <> -1) then + ULanguage.Language.ChangeLanguage(ILanguage[Params.Language]) + else + ULanguage.Language.ChangeLanguage(ILanguage[Ini.Language]); + + SetLength(ILanguageTranslated, Length(ILanguage)); + for I := 0 to High(ILanguage) do + begin + ILanguageTranslated[I] := ULanguage.Language.Translate( + 'OPTION_VALUE_' + UpperCase(ILanguage[I]) + ); + end; + IDifficultyTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_EASY'); IDifficultyTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_MEDIUM'); IDifficultyTranslated[2] := ULanguage.Language.Translate('OPTION_VALUE_HARD'); @@ -345,8 +384,7 @@ begin ISortingTranslated[3] := ULanguage.Language.Translate('OPTION_VALUE_FOLDER'); ISortingTranslated[4] := ULanguage.Language.Translate('OPTION_VALUE_TITLE'); ISortingTranslated[5] := ULanguage.Language.Translate('OPTION_VALUE_ARTIST'); - ISortingTranslated[6] := ULanguage.Language.Translate('OPTION_VALUE_TITLE2'); - ISortingTranslated[7] := ULanguage.Language.Translate('OPTION_VALUE_ARTIST2'); + ISortingTranslated[6] := ULanguage.Language.Translate('OPTION_VALUE_ARTIST2'); IDebugTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); IDebugTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); @@ -389,6 +427,10 @@ begin IVoicePassthroughTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); IVoicePassthroughTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); + ISyncToTranslated[Ord(stMusic)] := ULanguage.Language.Translate('OPTION_VALUE_MUSIC'); + ISyncToTranslated[Ord(stLyrics)] := ULanguage.Language.Translate('OPTION_VALUE_LYRICS'); + ISyncToTranslated[Ord(stOff)] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); + ILyricsFontTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_PLAIN'); ILyricsFontTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_OLINE1'); ILyricsFontTranslated[2] := ULanguage.Language.Translate('OPTION_VALUE_OLINE2'); @@ -399,11 +441,6 @@ begin ILyricsEffectTranslated[3] := ULanguage.Language.Translate('OPTION_VALUE_BALL'); ILyricsEffectTranslated[4] := ULanguage.Language.Translate('OPTION_VALUE_SHIFT'); - ISolmizationTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - ISolmizationTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_EURO'); - ISolmizationTranslated[2] := ULanguage.Language.Translate('OPTION_VALUE_JAPAN'); - ISolmizationTranslated[3] := ULanguage.Language.Translate('OPTION_VALUE_AMERICAN'); - INoteLinesTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); INoteLinesTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); @@ -415,7 +452,7 @@ begin IColorTranslated[5] := ULanguage.Language.Translate('OPTION_VALUE_ORANGE'); IColorTranslated[6] := ULanguage.Language.Translate('OPTION_VALUE_YELLOW'); IColorTranslated[7] := ULanguage.Language.Translate('OPTION_VALUE_BROWN'); - IColorTranslated[8] := ULanguage.Language.Translate('OPTION_VALUE_BALCK'); + IColorTranslated[8] := ULanguage.Language.Translate('OPTION_VALUE_BLACK'); // Advanced ILoadAnimationTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); @@ -508,14 +545,6 @@ begin end; (** - * Returns the filename without its fileextension - *) -function TIni.RemoveFileExt(FullName: string): string; -begin - Result := ChangeFileExt(FullName, ''); -end; - -(** * Extracts an index of a key that is surrounded by a Prefix/Suffix pair. * Example: ExtractKeyIndex('MyKey[1]', '[', ']') will return 1. *) @@ -562,34 +591,12 @@ begin end; (** - * Returns the index of Value in SearchArray - * or -1 if Value is not in SearchArray. - *) -function TIni.GetArrayIndex(const SearchArray: array of string; Value: string; - CaseInsensitiv: boolean = false): integer; -var - i: integer; -begin - Result := -1; - - for i := 0 to High(SearchArray) do - begin - if (SearchArray[i] = Value) or - (CaseInsensitiv and (UpperCase(SearchArray[i]) = UpperCase(Value))) then - begin - Result := i; - Break; - end; - end; -end; - -(** * Reads the property IniSeaction:IniProperty from IniFile and * finds its corresponding index in SearchArray. * If SearchArray does not contain the property value, the default value is * returned. *) -function TIni.ReadArrayIndex(const SearchArray: array of string; IniFile: TCustomIniFile; +function TIni.ReadArrayIndex(const SearchArray: array of UTF8String; IniFile: TCustomIniFile; IniSection: string; IniProperty: string; Default: integer): integer; var StrValue: string; @@ -625,7 +632,7 @@ begin if (DeviceIndex >= 0) then begin if not IniFile.ValueExists('Record', Format('DeviceName[%d]', [DeviceIndex])) then - break; + Continue; // resize list SetLength(InputDeviceConfig, Length(InputDeviceConfig)+1); @@ -637,6 +644,7 @@ begin DeviceCfg := @InputDeviceConfig[High(InputDeviceConfig)]; DeviceCfg.Name := IniFile.ReadString('Record', Format('DeviceName[%d]', [DeviceIndex]), ''); DeviceCfg.Input := IniFile.ReadInteger('Record', Format('Input[%d]', [DeviceIndex]), 0); + DeviceCfg.Latency := IniFile.ReadInteger('Record', Format('Latency[%d]', [DeviceIndex]), LATENCY_AUTODETECT); // find the largest channel-number of the current device in the ini-file ChannelCount := GetMaxKeyIndex(RecordKeys, 'Channel', Format('[%d]', [DeviceIndex])); @@ -675,6 +683,8 @@ begin InputDeviceConfig[DeviceIndex].Name); IniFile.WriteInteger('Record', Format('Input[%d]', [DeviceIndex+1]), InputDeviceConfig[DeviceIndex].Input); + IniFile.WriteInteger('Record', Format('Latency[%d]', [DeviceIndex+1]), + InputDeviceConfig[DeviceIndex].Latency); // Channel-to-Player Mapping for ChannelIndex := 0 to High(InputDeviceConfig[DeviceIndex].ChannelToPlayerMap) do @@ -702,9 +712,9 @@ begin // Load song-paths for I := 0 to PathStrings.Count-1 do begin - if (AnsiStartsText('SongDir', PathStrings[I])) then + if (Pos('SONGDIR', UpperCase(PathStrings[I])) = 1) then begin - AddSongPath(IniFile.ReadString('Directories', PathStrings[I], '')); + AddSongPath(Path(IniFile.ReadString('Directories', PathStrings[I], ''))); end; end; @@ -712,38 +722,7 @@ begin end; procedure TIni.LoadThemes(IniFile: TCustomIniFile); -var - SearchResult: TSearchRec; - ThemeIni: TMemIniFile; - ThemeName: string; - I: integer; begin - // Theme - SetLength(ITheme, 0); - Log.LogStatus('Searching for Theme : ' + ThemePath + '*.ini', 'Theme'); - - FindFirst(ThemePath + '*.ini',faAnyFile, SearchResult); - Repeat - Log.LogStatus('Found Theme: ' + SearchResult.Name, 'Theme'); - - //Read Themename from Theme - ThemeIni := TMemIniFile.Create(SearchResult.Name); - ThemeName := UpperCase(ThemeIni.ReadString('Theme','Name', RemoveFileExt(SearchResult.Name))); - ThemeIni.Free; - - //Search for Skins for this Theme - for I := Low(Skin.Skin) to High(Skin.Skin) do - begin - if UpperCase(Skin.Skin[I].Theme) = ThemeName then - begin - SetLength(ITheme, Length(ITheme)+1); - ITheme[High(ITheme)] := RemoveFileExt(SearchResult.Name); - break; - end; - end; - until FindNext(SearchResult) <> 0; - FindClose(SearchResult); - // No Theme Found if (Length(ITheme) = 0) then begin @@ -757,13 +736,22 @@ begin // Skin Skin.onThemeChange; - SkinNo := GetArrayIndex(ISkin, IniFile.ReadString('Themes', 'Skin', ISkin[0])); + SkinNo := GetArrayIndex(ISkin, IniFile.ReadString('Themes', 'Skin', ISkin[UThemes.Theme.Themes[Theme].DefaultSkin])); + + { there may be a not existing skin in the ini file + e.g. due to manual edit or corrupted file. + in this case we load the first Skin } + if SkinNo = -1 then + SkinNo := 0; + + // Color + Color := GetArrayIndex(IColor, IniFile.ReadString('Themes', 'Color', IColor[Skin.GetDefaultColor(SkinNo)])); end; procedure TIni.LoadScreenModes(IniFile: TCustomIniFile); // swap two strings - procedure swap(var s1, s2: string); + procedure swap(var s1, s2: UTF8String); var s3: string; begin @@ -800,17 +788,25 @@ begin else if (Modes = PPSDL_Rect(-1)) then begin // Fallback to some standard resolutions - SetLength(IResolution, 10); + SetLength(IResolution, 18); IResolution[0] := '640x480'; IResolution[1] := '800x600'; IResolution[2] := '1024x768'; - IResolution[3] := '1152x864'; - IResolution[4] := '1280x800'; - IResolution[5] := '1280x960'; - IResolution[6] := '1400x1050'; - IResolution[7] := '1440x900'; - IResolution[8] := '1600x1200'; - IResolution[9] := '1680x1050'; + IResolution[3] := '1152x666';; + IResolution[4] := '1152x864'; + IResolution[5] := '1280x800'; + IResolution[6] := '1280x960'; + IResolution[7] := '1280x1024'; + IResolution[8] := '1366x768'; + IResolution[9] := '1400x1050'; + IResolution[10] := '1440x900'; + IResolution[11] := '1600x900'; + IResolution[12] := '1600x1200'; + IResolution[13] := '1680x1050'; + IResolution[14] := '1920x1080'; + IResolution[15] := '1920x1200'; + IResolution[16] := '2048x1152'; + IResolution[17] := '2560x1600'; Resolution := GetArrayIndex(IResolution, IniFile.ReadString('Graphics', 'Resolution', '800x600')); if Resolution = -1 then @@ -872,19 +868,15 @@ var begin GamePath := Platform.GetGameUserPath; - Log.LogStatus( 'GamePath : ' +GamePath , '' ); + Log.LogStatus( 'GamePath : ' +GamePath.ToNative , '' ); - if (Params.ConfigFile <> '') then - try - FileName := Params.ConfigFile; - except - FileName := GamePath + 'config.ini'; - end + if (Params.ConfigFile.IsSet) then + FileName := Params.ConfigFile else - FileName := GamePath + 'config.ini'; + FileName := GamePath.Append('config.ini'); - Log.LogStatus( 'Using config : ' + FileName , 'Ini'); - IniFile := TMemIniFile.Create( FileName ); + Log.LogStatus('Using config : ' + FileName.ToNative, 'Ini'); + IniFile := TMemIniFile.Create(FileName.ToNative); // Name for I := 0 to 11 do @@ -904,22 +896,24 @@ begin // Language Language := GetArrayIndex(ILanguage, IniFile.ReadString('Game', 'Language', 'English')); - //Language.ChangeLanguage(ILanguage[Language]); // Tabs Tabs := GetArrayIndex(ITabs, IniFile.ReadString('Game', 'Tabs', ITabs[0])); TabsAtStartup := Tabs; //Tabs at Startup fix // Song Sorting - Sorting := GetArrayIndex(ISorting, IniFile.ReadString('Game', 'Sorting', ISorting[0])); + Sorting := GetArrayIndex(ISorting, IniFile.ReadString('Game', 'Sorting', ISorting[Ord(sEdition)])); // Debug Debug := GetArrayIndex(IDebug, IniFile.ReadString('Game', 'Debug', IDebug[0])); LoadScreenModes(IniFile); - // TextureSize - TextureSize := GetArrayIndex(ITextureSize, IniFile.ReadString('Graphics', 'TextureSize', ITextureSize[1])); + // TextureSize (aka CachedCoverSize) + // Note: a default cached cover size of 128 pixels is big enough, + // 256 pixels are already noticeably slow with 180 covers in the song-screen + // displayed at once. In additon the covers.db will be too big. + TextureSize := GetArrayIndex(ITextureSize, IniFile.ReadString('Graphics', 'TextureSize', '128')); // SingWindow SingWindow := GetArrayIndex(ISingWindow, IniFile.ReadString('Graphics', 'SingWindow', 'Big')); @@ -961,19 +955,13 @@ begin LyricsFont := GetArrayIndex(ILyricsFont, IniFile.ReadString('Lyrics', 'LyricsFont', ILyricsFont[0])); // Lyrics Effect - LyricsEffect := GetArrayIndex(ILyricsEffect, IniFile.ReadString('Lyrics', 'LyricsEffect', ILyricsEffect[2])); - - // Solmization - Solmization := GetArrayIndex(ISolmization, IniFile.ReadString('Lyrics', 'Solmization', ISolmization[0])); + LyricsEffect := GetArrayIndex(ILyricsEffect, IniFile.ReadString('Lyrics', 'LyricsEffect', ILyricsEffect[4])); // NoteLines NoteLines := GetArrayIndex(INoteLines, IniFile.ReadString('Lyrics', 'NoteLines', INoteLines[1])); LoadThemes(IniFile); - // Color - Color := GetArrayIndex(IColor, IniFile.ReadString('Themes', 'Color', IColor[0])); - LoadInputDeviceCfg(IniFile); // LoadAnimation @@ -993,7 +981,7 @@ begin {** * Background music *} - BackgroundMusicOption := GetArrayIndex(IBackgroundMusic, IniFile.ReadString('Sound', 'BackgroundMusic', 'Off')); + BackgroundMusicOption := GetArrayIndex(IBackgroundMusic, IniFile.ReadString('Sound', 'BackgroundMusic', 'On')); // EffectSing EffectSing := GetArrayIndex(IEffectSing, IniFile.ReadString('Advanced', 'EffectSing', 'On')); @@ -1010,6 +998,9 @@ begin // PartyPopup PartyPopup := GetArrayIndex(IPartyPopup, IniFile.ReadString('Advanced', 'PartyPopup', 'On')); + // SyncTo + SyncTo := GetArrayIndex(ISyncTo, IniFile.ReadString('Advanced', 'SyncTo', ISyncTo[Ord(stMusic)])); + // Joypad Joypad := GetArrayIndex(IJoypad, IniFile.ReadString('Controller', 'Joypad', IJoypad[0])); @@ -1027,13 +1018,13 @@ procedure TIni.Save; var IniFile: TIniFile; begin - if (FileExists(Filename) and FileIsReadOnly(Filename)) then + if (Filename.IsFile and Filename.IsReadOnly) then begin Log.LogError('Config-file is read-only', 'TIni.Save'); Exit; end; - IniFile := TIniFile.Create(Filename); + IniFile := TIniFile.Create(Filename.ToNative); // Players IniFile.WriteString('Game', 'Players', IPlayers[Players]); @@ -1116,9 +1107,6 @@ begin // Lyrics Effect IniFile.WriteString('Lyrics', 'LyricsEffect', ILyricsEffect[LyricsEffect]); - // Solmization - IniFile.WriteString('Lyrics', 'Solmization', ISolmization[Solmization]); - // NoteLines IniFile.WriteString('Lyrics', 'NoteLines', INoteLines[NoteLines]); @@ -1154,6 +1142,9 @@ begin //Party Popup IniFile.WriteString('Advanced', 'PartyPopup', IPartyPopup[PartyPopup]); + //SyncTo + IniFile.WriteString('Advanced', 'SyncTo', ISyncTo[SyncTo]); + // Joypad IniFile.WriteString('Controller', 'Joypad', IJoypad[Joypad]); @@ -1173,17 +1164,17 @@ var IniFile: TIniFile; I: integer; begin - if not FileIsReadOnly(Filename) then + if not Filename.IsReadOnly() then begin - IniFile := TIniFile.Create(Filename); + IniFile := TIniFile.Create(Filename.ToNative); //Name Templates for Names Mod - for I := 1 to 12 do - IniFile.WriteString('Name', 'P' + IntToStr(I), Name[I-1]); - for I := 1 to 3 do - IniFile.WriteString('NameTeam', 'T' + IntToStr(I), NameTeam[I-1]); - for I := 1 to 12 do - IniFile.WriteString('NameTemplate', 'Name' + IntToStr(I), NameTemplate[I-1]); + for I := 0 to High(Name) do + IniFile.WriteString('Name', 'P' + IntToStr(I+1), Name[I]); + for I := 0 to High(NameTeam) do + IniFile.WriteString('NameTeam', 'T' + IntToStr(I+1), NameTeam[I]); + for I := 0 to High(NameTemplate) do + IniFile.WriteString('NameTemplate', 'Name' + IntToStr(I+1), NameTemplate[I]); IniFile.Free; end; @@ -1193,9 +1184,9 @@ procedure TIni.SaveLevel; var IniFile: TIniFile; begin - if not FileIsReadOnly(Filename) then + if not Filename.IsReadOnly() then begin - IniFile := TIniFile.Create(Filename); + IniFile := TIniFile.Create(Filename.ToNative); // Difficulty IniFile.WriteString('Game', 'Difficulty', IDifficulty[Difficulty]); diff --git a/cmake/src/base/ULanguage.pas b/cmake/src/base/ULanguage.pas index 02cd7712..5f8a2692 100644 --- a/cmake/src/base/ULanguage.pas +++ b/cmake/src/base/ULanguage.pas @@ -33,33 +33,41 @@ interface {$I switches.inc} +uses + UUnicodeUtils; + type TLanguageEntry = record - ID: string; - Text: string; + ID: AnsiString; //**< identifier (ASCII) + Text: UTF8String; //**< translation (UTF-8) end; TLanguageList = record - Name: string; - {FileName: string; } + Name: AnsiString; //**< language name (ASCII) end; + TLanguageEntryArray = array of TLanguageEntry; + TLanguage = class - public - Entry: array of TLanguageEntry; //Entrys of Chosen Language - SEntry: array of TLanguageEntry; //Entrys of Standard Language - CEntry: array of TLanguageEntry; //Constant Entrys e.g. Version - Implode_Glue1, Implode_Glue2: String; - public + private List: array of TLanguageList; - constructor Create; + Entry: TLanguageEntryArray; //**< Entrys of Chosen Language + EntryDefault: TLanguageEntryArray; //**< Entrys of Standard Language + EntryConst: TLanguageEntryArray; //**< Constant Entrys e.g. Version + + Implode_Glue1, Implode_Glue2: UTF8String; + procedure LoadList; - function Translate(Text: String): String; - procedure ChangeLanguage(Language: String); - procedure AddConst(ID, Text: String); - procedure ChangeConst(ID, Text: String); - function Implode(Pieces: Array of String): String; + function FindID(const ID: AnsiString; const EntryList: TLanguageEntryArray): integer; + + public + constructor Create; + function Translate(const Text: RawByteString): UTF8String; + procedure ChangeLanguage(const Language: AnsiString); + procedure AddConst(const ID: AnsiString; const Text: UTF8String); + procedure ChangeConst(const ID: AnsiString; const Text: UTF8String); + function Implode(const Pieces: array of UTF8String): UTF8String; end; var @@ -69,20 +77,18 @@ implementation uses UMain, - // UFiles, UIni, IniFiles, Classes, SysUtils, - {$IFDEF win32} - Windows, - {$ENDIF} ULog, - UPath; + UPath, + UFilesystem, + UPathUtils; -//---------- -//Create - Construct Class then LoadList + Standard Language + Set Standard Implode Glues -//---------- +{** + * LoadList, set default language, set standard implode glues + *} constructor TLanguage.Create; var I, J: Integer; @@ -107,9 +113,9 @@ begin begin ChangeLanguage('English'); - SetLength(SEntry, Length(Entry)); - for J := low(Entry) to high(Entry) do - SEntry[J] := Entry[J]; + SetLength(EntryDefault, Length(Entry)); + for J := 0 to high(Entry) do + EntryDefault[J] := Entry[J]; SetLength(Entry, 0); @@ -123,41 +129,44 @@ begin end; -//---------- -//LoadList - Parse the Language Dir searching Translations -//---------- +{** + * Parse the Language Dir searching Translations + *} procedure TLanguage.LoadList; var - SR: TSearchRec; // for parsing directory + Iter: IFileIterator; + IniInfo: TFileInfo; + LangName: string; begin SetLength(List, 0); SetLength(ILanguage, 0); - if FindFirst(LanguagesPath + '*.ini', 0, SR) = 0 then begin - repeat - SetLength(List, Length(List)+1); - SetLength(ILanguage, Length(ILanguage)+1); - SR.Name := ChangeFileExt(SR.Name, ''); + Iter := FileSystem.FileFind(LanguagesPath.Append('*.ini'), 0); + while(Iter.HasNext) do + begin + IniInfo := Iter.Next; + + LangName := IniInfo.Name.SetExtension('').ToUTF8; - List[High(List)].Name := SR.Name; - ILanguage[High(ILanguage)] := SR.Name; + SetLength(List, Length(List)+1); + List[High(List)].Name := LangName; - until FindNext(SR) <> 0; - SysUtils.FindClose(SR); - end; // if FindFirst + SetLength(ILanguage, Length(ILanguage)+1); + ILanguage[High(ILanguage)] := LangName; + end; end; -//---------- -//ChangeLanguage - Load the specified LanguageFile -//---------- -procedure TLanguage.ChangeLanguage(Language: String); +{** + * Load the specified LanguageFile + *} +procedure TLanguage.ChangeLanguage(const Language: AnsiString); var - IniFile: TIniFile; + IniFile: TUnicodeMemIniFile; E: integer; // entry S: TStringList; begin SetLength(Entry, 0); - IniFile := TIniFile.Create(LanguagesPath + Language + '.ini'); + IniFile := TUnicodeMemIniFile.Create(LanguagesPath.Append(Language + '.ini')); S := TStringList.Create; IniFile.ReadSectionValues('Text', S); @@ -177,80 +186,107 @@ begin IniFile.Free; end; -//---------- -//Translate - Translate the Text -//---------- -Function TLanguage.Translate(Text: String): String; +{** + * Find the index of ID an array of language entries. + * @returns the index on success, -1 otherwise. + *} +function TLanguage.FindID(const ID: AnsiString; const EntryList: TLanguageEntryArray): integer; +var + Index: integer; +begin + for Index := 0 to High(EntryList) do + begin + if ID = EntryList[Index].ID then + begin + Result := Index; + Exit; + end; + end; + Result := -1; +end; + +{** + * Translate the Text. + * If Text is an ID, text will be translated according to the current language + * setting. If Text is not a known ID, it will be returned as is. + * @param Text either an ID or an UTF-8 encoded string + *} +function TLanguage.Translate(const Text: RawByteString): UTF8String; var - E: integer; // entry + E: integer; // entry + ID: AnsiString; + EntryIndex: integer; begin + // fallback result in case Text is not a known ID Result := Text; - Text := Uppercase(Result); + + // normalize ID case + ID := UpperCase(Text); + + // Check if ID exists //Const Mod - for E := 0 to high(CEntry) do - if Text = CEntry[E].ID then - begin - Result := CEntry[E].Text; - exit; - end; - //Const Mod End + EntryIndex := FindID(ID, EntryConst); + if (EntryIndex >= 0) then + begin + Result := EntryConst[EntryIndex].Text; + Exit; + end; - for E := 0 to high(Entry) do - if Text = Entry[E].ID then - begin - Result := Entry[E].Text; - exit; - end; + EntryIndex := FindID(ID, Entry); + if (EntryIndex >= 0) then + begin + Result := Entry[EntryIndex].Text; + Exit; + end; //Standard Language (If a Language File is Incomplete) //Then use Standard Language - for E := low(SEntry) to high(SEntry) do - if Text = SEntry[E].ID then - begin - Result := SEntry[E].Text; - Break; - end; - //Standard Language END + EntryIndex := FindID(ID, EntryDefault); + if (EntryIndex >= 0) then + begin + Result := EntryDefault[EntryIndex].Text; + Exit; + end; end; -//---------- -//AddConst - Add a Constant ID that will be Translated but not Loaded from the LanguageFile -//---------- -procedure TLanguage.AddConst (ID, Text: String); +{** + * Add a Constant ID that will be Translated but not Loaded from the LanguageFile + *} +procedure TLanguage.AddConst(const ID: AnsiString; const Text: UTF8String); begin - SetLength (CEntry, Length(CEntry) + 1); - CEntry[high(CEntry)].ID := ID; - CEntry[high(CEntry)].Text := Text; + SetLength (EntryConst, Length(EntryConst) + 1); + EntryConst[high(EntryConst)].ID := ID; + EntryConst[high(EntryConst)].Text := Text; end; -//---------- -//ChangeConst - Change a Constant Value by ID -//---------- -procedure TLanguage.ChangeConst(ID, Text: String); +{** + * Change a Constant Value by ID + *} +procedure TLanguage.ChangeConst(const ID: AnsiString; const Text: UTF8String); var I: Integer; begin - for I := 0 to high(CEntry) do + for I := 0 to high(EntryConst) do begin - if CEntry[I].ID = ID then + if EntryConst[I].ID = ID then begin - CEntry[I].Text := Text; + EntryConst[I].Text := Text; Break; end; end; end; -//---------- -//Implode - Connect an Array of Strings with ' and ' or ', ' to one String -//---------- -function TLanguage.Implode(Pieces: Array of String): String; +{** + * Connect an array of strings with ' and ' or ', ' to one string + *} +function TLanguage.Implode(const Pieces: array of UTF8String): UTF8String; var I: Integer; begin Result := ''; //Go through Pieces - for I := low(Pieces) to high(Pieces) do + for I := 0 to high(Pieces) do begin //Add Value Result := Result + Pieces[I]; diff --git a/cmake/src/base/ULog.pas b/cmake/src/base/ULog.pas index a872729a..e4ff4862 100644 --- a/cmake/src/base/ULog.pas +++ b/cmake/src/base/ULog.pas @@ -34,7 +34,8 @@ interface {$I switches.inc} uses - Classes; + Classes, + UPath; (* * LOG_LEVEL_[TYPE] defines the "minimum" index for logs of type TYPE. Each @@ -115,7 +116,7 @@ type // voice procedure LogVoice(SoundNr: integer); // buffer - procedure LogBuffer(const buf : Pointer; const bufLength : Integer; const filename : string); + procedure LogBuffer(const buf : Pointer; const bufLength : Integer; const filename : IPath); end; procedure DebugWriteln(const aString: String); @@ -133,7 +134,7 @@ uses UTime, UCommon, UCommandLine, - UPath; + UPathUtils; (* * Write to console if in debug mode (Thread-safe). @@ -198,7 +199,7 @@ begin if not BenchmarkFileOpened then begin BenchmarkFileOpened := true; - AssignFile(BenchmarkFile, LogPath + 'Benchmark.log'); + AssignFile(BenchmarkFile, LogPath.Append('Benchmark.log').ToNative); {$I-} Rewrite(BenchmarkFile); if IOResult = 0 then @@ -270,7 +271,7 @@ procedure TLog.LogToFile(const Text: string); begin if (FileOutputEnabled and not LogFileOpened) then begin - AssignFile(LogFile, LogPath + 'Error.log'); + AssignFile(LogFile, LogPath.Append('Error.log').ToNative); {$I-} Rewrite(LogFile); if IOResult = 0 then @@ -399,20 +400,19 @@ end; procedure TLog.LogVoice(SoundNr: integer); var - FS: TFileStream; - FileName: string; + FS: TBinaryFileStream; + Prefix: string; + FileName: IPath; Num: integer; begin for Num := 1 to 9999 do begin - FileName := IntToStr(Num); - while Length(FileName) < 4 do - FileName := '0' + FileName; - FileName := LogPath + 'Voice' + FileName + '.raw'; - if not FileExists(FileName) then + Prefix := Format('Voice%.4d', [Num]); + FileName := LogPath.Append(Prefix + '.raw'); + if not FileName.Exists() then break end; - FS := TFileStream.Create(FileName, fmCreate); + FS := TBinaryFileStream.Create(FileName, fmCreate); AudioInputProcessor.Sound[SoundNr].LogBuffer.Seek(0, soBeginning); FS.CopyFrom(AudioInputProcessor.Sound[SoundNr].LogBuffer, AudioInputProcessor.Sound[SoundNr].LogBuffer.Size); @@ -420,21 +420,19 @@ begin FS.Free; end; -procedure TLog.LogBuffer(const buf: Pointer; const bufLength: Integer; const filename: string); +procedure TLog.LogBuffer(const buf: Pointer; const bufLength: Integer; const filename: IPath); var - f : TFileStream; + f : TBinaryFileStream; begin - f := nil; - try - f := TFileStream.Create( filename, fmCreate); - f.Write( buf^, bufLength); - f.Free; - except - on e : Exception do begin - Log.LogError('TLog.LogBuffer: Failed to log buffer into file "' + filename + '". ErrMsg: ' + e.Message); + f := TBinaryFileStream.Create( filename, fmCreate); + try + f.Write( buf^, bufLength); + finally f.Free; end; + except on e : Exception do + Log.LogError('TLog.LogBuffer: Failed to log buffer into file "' + filename.ToNative + '". ErrMsg: ' + e.Message); end; end; diff --git a/cmake/src/base/ULyrics.pas b/cmake/src/base/ULyrics.pas index 82982981..3f62db9c 100644 --- a/cmake/src/base/ULyrics.pas +++ b/cmake/src/base/ULyrics.pas @@ -52,14 +52,14 @@ type Width: real; // width Start: cardinal; // start of the word in quarters (beats) Length: cardinal; // length of the word in quarters - Text: string; // text + Text: UTF8String; // text Freestyle: boolean; // is freestyle? end; TLyricWordArray = array of TLyricWord; TLyricLine = class public - Text: string; // text + Text: UTF8String; // text Width: real; // width Height: real; // height Words: TLyricWordArray; // words in this line diff --git a/cmake/src/base/UMain.pas b/cmake/src/base/UMain.pas index 275510fc..0d479420 100644 --- a/cmake/src/base/UMain.pas +++ b/cmake/src/base/UMain.pas @@ -37,13 +37,9 @@ uses SysUtils, SDL; -var - Done: boolean; - Restart: boolean; - procedure Main; procedure MainLoop; -procedure CheckEvents; +function CheckEvents: boolean; type TMainThreadExecProc = procedure(Data: Pointer); @@ -73,22 +69,30 @@ uses UCovers, UDataBase, UDisplay, - UDLLManager, UGraphic, UGraphicClasses, UIni, UJoystick, ULanguage, ULog, - UPath, + UPathUtils, UPlaylist, UMusic, + URecord, UBeatTimer, UPlatform, USkins, USongs, UThemes, UParty, + ULuaCore, + UHookableEvent, + ULuaGl, + ULuaLog, + ULuaTexture, + ULuaTextGL, + ULuaParty, + ULuaScreenSing, UTime; procedure Main; @@ -124,6 +128,10 @@ begin SDL_Init(SDL_INIT_VIDEO or SDL_INIT_TIMER); SDL_EnableUnicode(1); + // create luacore first so other classes can register their events + LuaCore := TLuaCore.Create; + + USTime := TTime.Create; VideoBGTimer := TRelativeTimer.Create; @@ -148,15 +156,6 @@ begin Log.BenchmarkEnd(1); Log.LogBenchmark('Loading Language', 1); -{ - // SDL_ttf (Not used yet, maybe in version 1.5) - Log.BenchmarkStart(1); - Log.LogStatus('Initialize SDL_ttf', 'Initialization'); - TTF_Init(); - Log.BenchmarkEnd(1); - Log.LogBenchmark('Initializing SDL_ttf', 1); -} - // Skin Log.BenchmarkStart(1); Log.LogStatus('Loading Skin List', 'Initialization'); @@ -164,6 +163,12 @@ begin Log.BenchmarkEnd(1); Log.LogBenchmark('Loading Skin List', 1); + Log.BenchmarkStart(1); + Log.LogStatus('Loading Theme List', 'Initialization'); + Theme := TTheme.Create; + Log.BenchmarkEnd(1); + Log.LogBenchmark('Loading Theme List', 1); + // Ini + Paths Log.BenchmarkStart(1); Log.LogStatus('Load Ini', 'Initialization'); @@ -174,12 +179,6 @@ begin Log.LogStatus('Write Ini', 'Initialization'); Ini.Save; - // Load Languagefile - if (Params.Language <> -1) then - Language.ChangeLanguage(ILanguage[Params.Language]) - else - Language.ChangeLanguage(ILanguage[Ini.Language]); - Log.BenchmarkEnd(1); Log.LogBenchmark('Loading Ini', 1); @@ -195,10 +194,10 @@ begin // Theme Log.BenchmarkStart(1); - Log.LogStatus('Load Themes', 'Initialization'); - Theme := TTheme.Create(ThemePath + ITheme[Ini.Theme] + '.ini', Ini.Color); + Log.LogStatus('Load Theme', 'Initialization'); + Theme.LoadTheme(Ini.Theme, Ini.Color); Log.BenchmarkEnd(1); - Log.LogBenchmark('Loading Themes', 1); + Log.LogBenchmark('Loading Theme', 1); // Covers Cache Log.BenchmarkStart(1); @@ -226,20 +225,6 @@ begin Log.BenchmarkEnd(1); Log.LogBenchmark('Loading Songs', 1); - // PluginManager - Log.BenchmarkStart(1); - Log.LogStatus('PluginManager', 'Initialization'); - DLLMan := TDLLMan.Create; // Load PluginList - Log.BenchmarkEnd(1); - Log.LogBenchmark('Loading PluginManager', 1); - - // Party Mode Manager - Log.BenchmarkStart(1); - Log.LogStatus('PartySession Manager', 'Initialization'); - PartySession := TPartySession.Create; //Load PartySession - Log.BenchmarkEnd(1); - Log.LogBenchmark('Loading PartySession Manager', 1); - // Graphics Log.BenchmarkStart(1); Log.LogStatus('Initialize 3D', 'Initialization'); @@ -252,10 +237,10 @@ begin Log.LogStatus('DataBase System', 'Initialization'); DataBase := TDataBaseSystem.Create; - if (Params.ScoreFile = '') then - DataBase.Init (Platform.GetGameUserPath + 'Ultrastar.db') + if (Params.ScoreFile.IsUnset) then + DataBase.Init(Platform.GetGameUserPath.Append('Ultrastar.db')) else - DataBase.Init (Params.ScoreFile); + DataBase.Init(Params.ScoreFile); Log.BenchmarkEnd(1); Log.LogBenchmark('Loading DataBase System', 1); @@ -284,22 +269,43 @@ begin Log.LogBenchmark('Initializing Joystick', 1); end; + // Lua + Log.BenchmarkStart(1); + Party := TPartyGame.Create; + Log.BenchmarkEnd(1); + Log.LogBenchmark('Initializing Party Manager', 1); + + Log.BenchmarkStart(1); + LuaCore.RegisterModule('Log', ULuaLog_Lib_f); + LuaCore.RegisterModule('Gl', ULuaGl_Lib_f); + LuaCore.RegisterModule('TextGl', ULuaTextGl_Lib_f); + LuaCore.RegisterModule('Party', ULuaParty_Lib_f); + LuaCore.RegisterModule('ScreenSing', ULuaScreenSing_Lib_f); + + Log.BenchmarkEnd(1); + Log.LogBenchmark('Initializing LuaCore', 1); + + Log.BenchmarkStart(1); + LuaCore.LoadPlugins; + Log.BenchmarkEnd(1); + Log.LogBenchmark('Loading Lua Plugins', 1); + + LuaCore.DumpPlugins; + Log.BenchmarkEnd(0); Log.LogBenchmark('Loading Time', 0); - Log.LogStatus('Creating Core', 'Initialization'); -{ - Core := TCore.Create( - USDXShortVersionStr, - MakeVersion(USDX_VERSION_MAJOR, - USDX_VERSION_MINOR, - USDX_VERSION_RELEASE, - chr(0)) - ); -} + { prepare software cursor } + Display.SetCursor; + + {** + * Start background music + *} + SoundLib.StartBgMusic; - Log.LogStatus('Running Core', 'Initialization'); - //Core.Run; + // check microphone settings, goto record options if they are corrupt + if (not AudioInputProcessor.ValidateSettings) then + Display.CurrentScreen^.FadeTo( @ScreenOptionsRecord ); //------------------------------ // Start Mainloop @@ -318,62 +324,58 @@ begin // call an uninitialize routine for every initialize step // or at least use the corresponding Free methods + Log.LogStatus('Finalize Media', 'Finalization'); FinalizeMedia(); - //TTF_Quit(); + Log.LogStatus('Uninitialize 3D', 'Finalization'); + Finalize3D(); + + Log.LogStatus('Finalize SDL', 'Finalization'); SDL_Quit(); - if assigned(Log) then - begin - Log.LogStatus('Main Loop', 'Finished'); - Log.Free; - end; + Log.LogStatus('Finalize Log', 'Finalization'); + Log.Free; {$IFNDEF Debug} end; {$ENDIF} end; procedure MainLoop; -var - Delay: integer; const MAX_FPS = 100; +var + Delay: integer; + TicksCurrent: cardinal; + TicksBeforeFrame: cardinal; + Continue: boolean; begin SDL_EnableKeyRepeat(125, 125); CountSkipTime(); // JB - for some reason this seems to be needed when we use the SDL Timer functions. - while not Done do + while Continue do begin + TicksBeforeFrame := SDL_GetTicks; + // joypad if (Ini.Joypad = 1) or (Params.Joypad) then Joy.Update; // keyboard events - CheckEvents; + Continue := CheckEvents; // display - Done := not Display.Draw; + Continue := Display.Draw; SwapBuffers; - // delay - CountMidTime; - - Delay := Floor(1000 / MAX_FPS - 1000 * TimeMid); - Log.LogError ('MainLoop', 'Delay: ' + intToStr(Delay)); + // FPS limiter + TicksCurrent := SDL_GetTicks; + Delay := 1000 div MAX_FPS - (TicksCurrent - TicksBeforeFrame); if Delay >= 1 then SDL_Delay(Delay); // dynamic, maximum is 100 fps - Log.LogError ('MainLoop', 'Delay: ok ' + intToStr(Delay)); CountSkipTime; - // reinitialization of graphics - if Restart then - begin - Reinitialize3D; - Restart := false; - end; - end; end; @@ -392,15 +394,13 @@ begin end; end; -procedure CheckEvents; +function CheckEvents: boolean; var Event: TSDL_event; mouseDown: boolean; mouseBtn: integer; begin - if Assigned(Display.NextScreen) then - Exit; - + Result := true; while (SDL_PollEvent(@Event) <> 0) do begin case Event.type_ of @@ -425,29 +425,39 @@ begin begin mouseDown := true; mouseBtn := Event.button.button; + + if (mouseBtn = SDL_BUTTON_LEFT) or (mouseBtn = SDL_BUTTON_RIGHT) then + Display.OnMouseButton(true); end; SDL_MOUSEBUTTONUP: begin mouseDown := false; mouseBtn := Event.button.button; + + if (mouseBtn = SDL_BUTTON_LEFT) or (mouseBtn = SDL_BUTTON_RIGHT) then + Display.OnMouseButton(false); end; end; - Display.MoveCursor(Event.button.X * 800 / Screen.w, - Event.button.Y * 600 / Screen.h, - mouseDown and ((mouseBtn <> SDL_BUTTON_WHEELDOWN) or (mouseBtn <> SDL_BUTTON_WHEELUP))); - - if (ScreenPopupError <> nil) and (ScreenPopupError.Visible) then - done := not ScreenPopupError.ParseMouse(mouseBtn, mouseDown, Event.button.x, Event.button.y) - else if (ScreenPopupCheck <> nil) and (ScreenPopupCheck.Visible) then - done := not ScreenPopupCheck.ParseMouse(mouseBtn, mouseDown, Event.button.x, Event.button.y) - else - begin - done := not Display.CurrentScreen^.ParseMouse(mouseBtn, mouseDown, Event.button.x, Event.button.y); - - // if screen wants to exit - if done then - DoQuit; + Display.MoveCursor(Event.button.X * 800 * Screens / ScreenW, + Event.button.Y * 600 / ScreenH); + + if not Assigned(Display.NextScreen) then + begin //drop input when changing screens + if (ScreenPopupError <> nil) and (ScreenPopupError.Visible) then + Result := ScreenPopupError.ParseMouse(mouseBtn, mouseDown, Event.button.x, Event.button.y) + else if (ScreenPopupInfo <> nil) and (ScreenPopupInfo.Visible) then + Result := ScreenPopupInfo.ParseMouse(mouseBtn, mouseDown, Event.button.x, Event.button.y) + else if (ScreenPopupCheck <> nil) and (ScreenPopupCheck.Visible) then + Result := ScreenPopupCheck.ParseMouse(mouseBtn, mouseDown, Event.button.x, Event.button.y) + else + begin + Result := Display.CurrentScreen^.ParseMouse(mouseBtn, mouseDown, Event.button.x, Event.button.y); + + // if screen wants to exit + if not Result then + DoQuit; + end; end; end; end; @@ -459,6 +469,12 @@ begin // This would create a new OpenGL render-context and all texture data // would be invalidated. // On Linux the mode MUST be reset, otherwise graphics will be corrupted. + // Update: It seems to work now without creating a new OpenGL context. At least + // with Win7 and SDL 1.2.14. Maybe it generally works now with SDL 1.2.14 and we + // can switch it on for windows. + // Important: Unless SDL_SetVideoMode() is called (it is not on Windows), Screen.w + // and Screen.h are not valid after a resize and still contain the old size. Use + // ScreenW and ScreenH instead. {$IF Defined(Linux) or Defined(FreeBSD)} if boolean( Ini.FullScreen ) then SDL_SetVideoMode(ScreenW, ScreenH, (Ini.Depth+1) * 16, SDL_OPENGL or SDL_FULLSCREEN) @@ -468,52 +484,72 @@ begin end; SDL_KEYDOWN: begin + // translate CTRL-A (ASCII 1) - CTRL-Z (ASCII 26) to correct charcodes. + // keysyms (SDLK_A, ...) could be used instead but they ignore the + // current key mapping (if 'a' is pressed on a French keyboard the + // .unicode field will be 'a' and .sym SDLK_Q). + // IMPORTANT: if CTRL is pressed with a key different than 'A'-'Z' SDL + // will set .unicode to 0. There is no possibility to obtain a + // translated charcode. Use keysyms instead. + //if (Event.key.keysym.unicode in [1 .. 26]) then + // Event.key.keysym.unicode := Ord('A') + Event.key.keysym.unicode - 1; + // remap the "keypad enter" key to the "standard enter" key if (Event.key.keysym.sym = SDLK_KP_ENTER) then Event.key.keysym.sym := SDLK_RETURN; - if (Event.key.keysym.sym = SDLK_F11) or - ((Event.key.keysym.sym = SDLK_RETURN) and - ((Event.key.keysym.modifier and KMOD_ALT) <> 0)) then // toggle full screen - begin - Ini.FullScreen := integer( not boolean( Ini.FullScreen ) ); - - // FIXME: SDL_SetVideoMode creates a new OpenGL RC so we have to - // reload all texture data (-> whitescreen bug). - // Only Linux and FreeBSD are able to handle screen-switching this way. - {$IF Defined(Linux) or Defined(FreeBSD)} - if boolean( Ini.FullScreen ) then + if not Assigned(Display.NextScreen) then + begin //drop input when changing screens + { to-do : F11 was used for fullscreen toggle, too here + but we also use the key in screenname and some other + screens. It is droped although fullscreen toggle doesn't + even work on windows. + should we add (Event.key.keysym.sym = SDLK_F11) here + anyway? } + if ((Event.key.keysym.sym = SDLK_RETURN) and + ((Event.key.keysym.modifier and KMOD_ALT) <> 0)) then // toggle full screen begin - SDL_SetVideoMode(ScreenW, ScreenH, (Ini.Depth+1) * 16, SDL_OPENGL or SDL_FULLSCREEN); + Ini.FullScreen := integer( not boolean( Ini.FullScreen ) ); + + // FIXME: SDL_SetVideoMode creates a new OpenGL RC so we have to + // reload all texture data (-> whitescreen bug). + // Only Linux and FreeBSD are able to handle screen-switching this way. + {$IF Defined(Linux) or Defined(FreeBSD)} + if boolean( Ini.FullScreen ) then + begin + SDL_SetVideoMode(ScreenW, ScreenH, (Ini.Depth+1) * 16, SDL_OPENGL or SDL_FULLSCREEN); + end + else + begin + SDL_SetVideoMode(ScreenW, ScreenH, (Ini.Depth+1) * 16, SDL_OPENGL or SDL_RESIZABLE); + end; + + Display.SetCursor; + + glViewPort(0, 0, ScreenW, ScreenH); + {$IFEND} end + // if print is pressed -> make screenshot and save to screenshot path + else if (Event.key.keysym.sym = SDLK_SYSREQ) or (Event.key.keysym.sym = SDLK_PRINT) then + Display.SaveScreenShot + // if there is a visible popup then let it handle input instead of underlying screen + // shoud be done in a way to be sure the topmost popup has preference (maybe error, then check) + else if (ScreenPopupError <> nil) and (ScreenPopupError.Visible) then + Result := ScreenPopupError.ParseInput(Event.key.keysym.sym, Event.key.keysym.unicode, true) + else if (ScreenPopupInfo <> nil) and (ScreenPopupInfo.Visible) then + Result := ScreenPopupInfo.ParseInput(Event.key.keysym.sym, Event.key.keysym.unicode, true) + else if (ScreenPopupCheck <> nil) and (ScreenPopupCheck.Visible) then + Result := ScreenPopupCheck.ParseInput(Event.key.keysym.sym, Event.key.keysym.unicode, true) else begin - SDL_SetVideoMode(ScreenW, ScreenH, (Ini.Depth+1) * 16, SDL_OPENGL or SDL_RESIZABLE); - end; + // check if screen wants to exit + Result := Display.ParseInput(Event.key.keysym.sym, Event.key.keysym.unicode, true); - Display.SetCursor; - - glViewPort(0, 0, ScreenW, ScreenH); - {$IFEND} - end - // if print is pressed -> make screenshot and save to screenshot path - else if (Event.key.keysym.sym = SDLK_SYSREQ) or (Event.key.keysym.sym = SDLK_PRINT) then - Display.SaveScreenShot - // if there is a visible popup then let it handle input instead of underlying screen - // shoud be done in a way to be sure the topmost popup has preference (maybe error, then check) - else if (ScreenPopupError <> nil) and (ScreenPopupError.Visible) then - Done := not ScreenPopupError.ParseInput(Event.key.keysym.sym, WideChar(Event.key.keysym.unicode), true) - else if (ScreenPopupCheck <> nil) and (ScreenPopupCheck.Visible) then - Done := not ScreenPopupCheck.ParseInput(Event.key.keysym.sym, WideChar(Event.key.keysym.unicode), true) - else - begin - // check if screen wants to exit - Done := not Display.CurrentScreen^.ParseInput(Event.key.keysym.sym, WideChar(Event.key.keysym.unicode), true); - - // if screen wants to exit - if Done then - DoQuit; + // if screen wants to exit + if not Result then + DoQuit; + end; end; end; SDL_JOYAXISMOTION: diff --git a/cmake/src/base/UMusic.pas b/cmake/src/base/UMusic.pas index 19c54bee..7f2b3e30 100644 --- a/cmake/src/base/UMusic.pas +++ b/cmake/src/base/UMusic.pas @@ -34,10 +34,11 @@ interface {$I switches.inc} uses - UTime, SysUtils, Classes, - UBeatTimer; + UTime, + UBeatTimer, + UPath; type TNoteType = (ntFreestyle, ntNormal, ntGolden); @@ -62,7 +63,7 @@ type Start: integer; // beat the fragment starts at Length: integer; // length in beats Tone: integer; // full range tone - Text: string; // text assigned to this fragment (a syllable, word, etc.) + Text: UTF8String; // text assigned to this fragment (a syllable, word, etc.) NoteType: TNoteType; // note-type: golden-note/freestyle etc. end; @@ -73,7 +74,7 @@ type PLine = ^TLine; TLine = record Start: integer; // the start beat of this line (<> start beat of the first note of this line) - Lyric: string; + Lyric: UTF8String; //LyricWidth: real; // @deprecated: width of the line in pixels. // Do not use this as the width is not correct. // Use TLyricsEngine.GetUpperLine().Width instead. @@ -187,10 +188,6 @@ type end; type - TSyncSource = class - function GetClock(): real; virtual; abstract; - end; - TAudioProcessingStream = class; TOnCloseHandler = procedure(Stream: TAudioProcessingStream); @@ -249,8 +246,8 @@ type TAudioPlaybackStream = class(TAudioProcessingStream) protected + AvgSyncDiff: double; //** average difference between stream and sync clock SyncSource: TSyncSource; - AvgSyncDiff: double; SourceStream: TAudioSourceStream; function GetLatency(): double; virtual; abstract; @@ -259,7 +256,7 @@ type procedure SetVolume(Volume: single); virtual; abstract; function Synchronize(BufferSize: integer; FormatInfo: TAudioFormatInfo): integer; procedure FillBufferWithFrame(Buffer: PByteArray; BufferSize: integer; Frame: PByteArray; FrameSize: integer); - public + public (** * Opens a SourceStream for playback. * Note that the caller (not the TAudioPlaybackStream) is responsible to @@ -315,7 +312,7 @@ type // soundcard output-devices information TAudioOutputDevice = class public - Name: string; // soundcard name + Name: UTF8String; // soundcard name end; TAudioOutputDeviceList = array of TAudioOutputDevice; @@ -323,28 +320,33 @@ type IGenericPlayback = Interface ['{63A5EBC3-3F4D-4F23-8DFB-B5165FCE33DD}'] function GetName: String; + end; - function Open(const Filename: string): boolean; // true if succeed - procedure Close; - + IVideo = interface + ['{58DFC674-9168-41EA-B59D-A61307242B80}'] procedure Play; procedure Pause; procedure Stop; + procedure SetLoop(Enable: boolean); + function GetLoop(): boolean; + procedure SetPosition(Time: real); function GetPosition: real; + procedure GetFrame(Time: Extended); + procedure DrawGL(Screen: integer); + + property Loop: boolean read GetLoop write SetLoop; property Position: real read GetPosition write SetPosition; end; IVideoPlayback = Interface( IGenericPlayback ) ['{3574C40C-28AE-4201-B3D1-3D1F0759B131}'] - function Init(): boolean; - function Finalize: boolean; - - procedure GetFrame(Time: Extended); // WANT TO RENAME THESE TO BE MORE GENERIC - procedure DrawGL(Screen: integer); // WANT TO RENAME THESE TO BE MORE GENERIC + function Init(): boolean; + function Finalize: boolean; + function Open(const FileName : IPath): IVideo; end; IVideoVisualization = Interface( IVideoPlayback ) @@ -369,6 +371,18 @@ type function Finished: boolean; function Length: real; + function Open(const Filename: IPath): boolean; // true if succeed + procedure Close; + + procedure Play; + procedure Pause; + procedure Stop; + + procedure SetPosition(Time: real); + function GetPosition: real; + + property Position: real read GetPosition write SetPosition; + // Sounds // TODO: // add a TMediaDummyPlaybackStream implementation that will @@ -376,7 +390,7 @@ type // nil-pointers is not neccessary anymore. // PlaySound/StopSound will be removed then, OpenSound will be renamed to // CreateSound. - function OpenSound(const Filename: String): TAudioPlaybackStream; + function OpenSound(const Filename: IPath): TAudioPlaybackStream; procedure PlaySound(Stream: TAudioPlaybackStream); procedure StopSound(Stream: TAudioPlaybackStream); @@ -391,7 +405,7 @@ type IGenericDecoder = Interface ['{557B0E9A-604D-47E4-B826-13769F3E10B7}'] - function GetName(): String; + function GetName(): string; function InitializeDecoder(): boolean; function FinalizeDecoder(): boolean; //function IsSupported(const Filename: string): boolean; @@ -400,13 +414,13 @@ type (* IVideoDecoder = Interface( IGenericDecoder ) ['{2F184B2B-FE69-44D5-9031-0A2462391DCA}'] - function Open(const Filename: string): TVideoDecodeStream; + function Open(const Filename: IPath): TVideoDecodeStream; end; *) IAudioDecoder = Interface( IGenericDecoder ) ['{AB47B1B6-2AA9-4410-BF8C-EC79561B5478}'] - function Open(const Filename: string): TAudioDecodeStream; + function Open(const Filename: IPath): TAudioDecodeStream; end; IAudioInput = Interface @@ -456,7 +470,7 @@ const SOUNDID_CLICK = 5; LAST_SOUNDID = SOUNDID_CLICK; - BaseSoundFilenames: array[0..LAST_SOUNDID] of string = ( + BaseSoundFilenames: array[0..LAST_SOUNDID] of IPath = ( '%SOUNDPATH%/Common start.mp3', // Start '%SOUNDPATH%/Common back.mp3', // Back '%SOUNDPATH%/menu swoosh.mp3', // Swoosh @@ -497,7 +511,7 @@ type procedure StartBgMusic(); procedure PauseBgMusic(); // TODO - //function AddSound(Filename: string): integer; + //function AddSound(Filename: IPath): integer; //procedure RemoveSound(ID: integer); //function GetSound(ID: integer): TAudioPlaybackStream; //property Sound[ID: integer]: TAudioPlaybackStream read GetSound; default; @@ -533,7 +547,7 @@ uses UCommandLine, URecord, ULog, - UPath; + UPathUtils; var DefaultVideoPlayback : IVideoPlayback; @@ -654,7 +668,7 @@ begin FilterInterfaceList(IAudioDecoder, MediaManager, InterfaceList); for i := 0 to InterfaceList.Count-1 do begin - CurrentAudioDecoder := IAudioDecoder(InterfaceList[i]); + CurrentAudioDecoder := InterfaceList[i] as IAudioDecoder; if (not CurrentAudioDecoder.InitializeDecoder()) then begin Log.LogError('Initialize failed, Removing - '+ CurrentAudioDecoder.GetName); @@ -671,7 +685,7 @@ begin FilterInterfaceList(IAudioPlayback, MediaManager, InterfaceList); for i := 0 to InterfaceList.Count-1 do begin - CurrentAudioPlayback := IAudioPlayback(InterfaceList[i]); + CurrentAudioPlayback := InterfaceList[i] as IAudioPlayback; if (CurrentAudioPlayback.InitializePlayback()) then begin DefaultAudioPlayback := CurrentAudioPlayback; @@ -686,7 +700,7 @@ begin FilterInterfaceList(IAudioInput, MediaManager, InterfaceList); for i := 0 to InterfaceList.Count-1 do begin - CurrentAudioInput := IAudioInput(InterfaceList[i]); + CurrentAudioInput := InterfaceList[i] as IAudioInput; if (CurrentAudioInput.InitializeRecord()) then begin DefaultAudioInput := CurrentAudioInput; @@ -719,7 +733,7 @@ begin FilterInterfaceList(IVideoPlayback, MediaManager, InterfaceList); for i := 0 to InterfaceList.Count-1 do begin - VideoInterface := IVideoPlayback(InterfaceList[i]); + VideoInterface := InterfaceList[i] as IVideoPlayback; if (VideoInterface.Init()) then begin DefaultVideoPlayback := VideoInterface; @@ -734,7 +748,7 @@ begin FilterInterfaceList(IVideoVisualization, MediaManager, InterfaceList); for i := 0 to InterfaceList.Count-1 do begin - VisualInterface := IVideoVisualization(InterfaceList[i]); + VisualInterface := InterfaceList[i] as IVideoVisualization; if (VisualInterface.Init()) then begin DefaultVisualization := VisualInterface; @@ -748,7 +762,7 @@ begin // now that we have all interfaces, we can dump them // TODO: move this to another place - if FindCmdLineSwitch( cMediaInterfaces ) then + if FindCmdLineSwitch(cMediaInterfaces) then begin DumpMediaInterfaces(); halt; @@ -772,27 +786,27 @@ begin // finalize audio playback interfaces (should be done before the decoders) FilterInterfaceList(IAudioPlayback, MediaManager, InterfaceList); for i := 0 to InterfaceList.Count-1 do - IAudioPlayback(InterfaceList[i]).FinalizePlayback(); + (InterfaceList[i] as IAudioPlayback).FinalizePlayback(); // finalize audio input interfaces FilterInterfaceList(IAudioInput, MediaManager, InterfaceList); for i := 0 to InterfaceList.Count-1 do - IAudioInput(InterfaceList[i]).FinalizeRecord(); + (InterfaceList[i] as IAudioInput).FinalizeRecord(); // finalize audio decoder interfaces FilterInterfaceList(IAudioDecoder, MediaManager, InterfaceList); for i := 0 to InterfaceList.Count-1 do - IAudioDecoder(InterfaceList[i]).FinalizeDecoder(); + (InterfaceList[i] as IAudioDecoder).FinalizeDecoder(); // finalize video interfaces FilterInterfaceList(IVideoPlayback, MediaManager, InterfaceList); for i := 0 to InterfaceList.Count-1 do - IVideoPlayback(InterfaceList[i]).Finalize(); + (InterfaceList[i] as IVideoPlayback).Finalize(); // finalize audio decoder interfaces FilterInterfaceList(IVideoVisualization, MediaManager, InterfaceList); for i := 0 to InterfaceList.Count-1 do - IVideoVisualization(InterfaceList[i]).Finalize(); + (InterfaceList[i] as IVideoVisualization).Finalize(); InterfaceList.Free; @@ -813,12 +827,6 @@ begin if (AudioInput <> nil) then AudioInput.CaptureStop; - if (VideoPlayback <> nil) then - VideoPlayback.Close; - - if (Visualization <> nil) then - Visualization.Close; - UnloadMediaModules(); end; @@ -855,14 +863,14 @@ procedure TSoundLibrary.LoadSounds(); begin UnloadSounds(); - Start := AudioPlayback.OpenSound(SoundPath + 'Common start.mp3'); - Back := AudioPlayback.OpenSound(SoundPath + 'Common back.mp3'); - Swoosh := AudioPlayback.OpenSound(SoundPath + 'menu swoosh.mp3'); - Change := AudioPlayback.OpenSound(SoundPath + 'select music change music 50.mp3'); - Option := AudioPlayback.OpenSound(SoundPath + 'option change col.mp3'); - Click := AudioPlayback.OpenSound(SoundPath + 'rimshot022b.mp3'); + Start := AudioPlayback.OpenSound(SoundPath.Append('Common start.mp3')); + Back := AudioPlayback.OpenSound(SoundPath.Append('Common back.mp3')); + Swoosh := AudioPlayback.OpenSound(SoundPath.Append('menu swoosh.mp3')); + Change := AudioPlayback.OpenSound(SoundPath.Append('select music change music 50.mp3')); + Option := AudioPlayback.OpenSound(SoundPath.Append('option change col.mp3')); + Click := AudioPlayback.OpenSound(SoundPath.Append('rimshot022b.mp3')); - BGMusic := AudioPlayback.OpenSound(SoundPath + 'Bebeto_-_Loop010.mp3'); + BGMusic := AudioPlayback.OpenSound(SoundPath.Append('Bebeto_-_Loop010.mp3')); if (BGMusic <> nil) then BGMusic.Loop := True; @@ -983,6 +991,8 @@ begin AvgSyncDiff := -1; end; +{.$DEFINE LOG_SYNC} + (* * Results an adjusted size of the input buffer size to keep the stream in sync * with the SyncSource. If no SyncSource was assigned to this stream, the @@ -999,11 +1009,15 @@ end; function TAudioPlaybackStream.Synchronize(BufferSize: integer; FormatInfo: TAudioFormatInfo): integer; var TimeDiff: double; - TimeCorrectionFactor: double; + FrameDiff: double; + FrameSkip: integer; + ReqFrames: integer; + MasterClock: real; + CurPosition: real; const - AVG_HISTORY_FACTOR = 0.9; - SYNC_THRESHOLD = 0.045; - MAX_SYNC_DIFF_TIME = 0.002; + AVG_HISTORY_FACTOR = 0.7; + SYNC_REPOS_THRESHOLD = 5.000; + SYNC_SOFT_THRESHOLD = 0.010; begin Result := BufferSize; @@ -1013,9 +1027,12 @@ begin if (BufferSize <= 0) then Exit; + CurPosition := Position; + MasterClock := SyncSource.GetClock(); + // difference between sync-source and stream position // (negative if the music-stream's position is ahead of the master clock) - TimeDiff := SyncSource.GetClock() - (Position - GetLatency()); + TimeDiff := MasterClock - CurPosition; // calculate average time difference (some sort of weighted mean). // The bigger AVG_HISTORY_FACTOR is, the smoother is the average diff. @@ -1030,35 +1047,46 @@ begin AvgSyncDiff := TimeDiff * (1-AVG_HISTORY_FACTOR) + AvgSyncDiff * AVG_HISTORY_FACTOR; - // check if sync needed - if (Abs(AvgSyncDiff) >= SYNC_THRESHOLD) then + {$IFDEF LOG_SYNC} + //Log.LogError(Format('c:%.3f | p:%.3f | d:%.3f | a:%.3f', + // [MasterClock, CurPosition, TimeDiff, AvgSyncDiff]), 'Synch'); + {$ENDIF} + + // check if we are out of sync + if (Abs(AvgSyncDiff) >= SYNC_REPOS_THRESHOLD) then begin - // TODO: use SetPosition if diff is too large (>5s) - if (TimeDiff < 1) then - TimeCorrectionFactor := Sign(TimeDiff)*TimeDiff*TimeDiff - else - TimeCorrectionFactor := TimeDiff; - - // calculate adapted buffer size - // reduce size of data to fetch if music is ahead, increase otherwise - Result := BufferSize + Round(TimeCorrectionFactor * FormatInfo.SampleRate) * FormatInfo.FrameSize; + {$IFDEF LOG_SYNC} + Log.LogError(Format('ReposSynch: %.3f > %.3f', + [Abs(AvgSyncDiff), SYNC_REPOS_THRESHOLD]), 'Synch'); + {$ENDIF} + + // diff far is too large -> reposition stream + // (resulting position might still be out of sync) + SetPosition(CurPosition + AvgSyncDiff); + + // reset sync info + AvgSyncDiff := -1; + end + else if (Abs(AvgSyncDiff) >= SYNC_SOFT_THRESHOLD) then + begin + {$IFDEF LOG_SYNC} + Log.LogError(Format('SoftSynch: %.3f > %.3f', + [Abs(AvgSyncDiff), SYNC_SOFT_THRESHOLD]), 'Synch'); + {$ENDIF} + + // hard sync: directly jump to the current position + FrameSkip := Round(AvgSyncDiff * FormatInfo.SampleRate); + Result := BufferSize + FrameSkip * FormatInfo.FrameSize; if (Result < 0) then Result := 0; - // reset average + // reset sync info AvgSyncDiff := -1; end; - - (* - DebugWriteln('Diff: ' + floattostrf(TimeDiff, ffFixed, 15, 3) + - '| SyS: ' + floattostrf(SyncSource.GetClock(), ffFixed, 15, 3) + - '| Pos: ' + floattostrf(Position, ffFixed, 15, 3) + - '| Avg: ' + floattostrf(AvgSyncDiff, ffFixed, 15, 3)); - *) end; (* - * Fills a buffer with copies of the given frame or with 0 if frame. + * Fills a buffer with copies of the given Frame or with 0 if Frame is nil. *) procedure TAudioPlaybackStream.FillBufferWithFrame(Buffer: PByteArray; BufferSize: integer; Frame: PByteArray; FrameSize: integer); var diff --git a/cmake/src/base/UNote.pas b/cmake/src/base/UNote.pas index 6da4cf07..6eb99df9 100644 --- a/cmake/src/base/UNote.pas +++ b/cmake/src/base/UNote.pas @@ -19,8 +19,8 @@ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, * Boston, MA 02110-1301, USA. * - * $URL: https://ultrastardx.svn.sourceforge.net/svnroot/ultrastardx/trunk/src/base/UNote.pas $ - * $Id: UNote.pas 1626 2009-03-07 19:53:00Z k-m_schindler $ + * $URL$ + * $Id$ *} unit UNote; @@ -61,7 +61,7 @@ type PPLayer = ^TPlayer; TPlayer = record - Name: string; + Name: UTF8String; // Index in Teaminfo record TeamID: byte; @@ -123,13 +123,12 @@ uses UCatCovers, UDataBase, UPlaylist, - UDLLManager, UParty, UConfig, UCommon, UGraphic, UGraphicClasses, - UPath, + UPathUtils, UPlatform, UThemes; diff --git a/cmake/src/base/UParty.pas b/cmake/src/base/UParty.pas index e29b977c..2f89afd6 100644 --- a/cmake/src/base/UParty.pas +++ b/cmake/src/base/UParty.pas @@ -34,350 +34,979 @@ interface {$I switches.inc} uses - ModiSDK; + ULua; type - TRoundInfo = record - Plugin: word; - Winner: byte; + { array holds ids of modes or Party_Round_Random + its length defines the number of rounds + it is used as argument for TPartyGame.StartParty } + ARounds = array of integer; + + { element of APartyTeamRanking returned by TPartyGame.GetTeamRanking + and parameter for TPartyGame.SetWinner } + TParty_TeamRanking = record + Team: Integer; //< id of team + Rank: Integer; //< 1 to Length(Teams) e.g. 1 is for placed first end; + AParty_TeamRanking = array of TParty_TeamRanking; //< returned by TPartyGame.GetTeamRanking - TeamOrderEntry = record - TeamNum: byte; - Score: byte; + TParty_RoundList = record + Index: integer; + Name: UTF8String; end; + AParty_ModeList = array of TParty_RoundList; + + { record used by TPartyGame to store round specific data } + TParty_Round = record + Mode: Integer; + AlreadyPlayed: Boolean; //< true if round was already played + Ranking: AParty_TeamRanking; + RankingSet: Boolean; //< true if Self.Ranking is already set + end; + + TParty_ModeInfo = record + Name: String; // name of this mode + Parent: Integer; // Id of owning plugin + + CanNonParty: Boolean; //< is playable when not in party mode + CanParty: Boolean; //< is playable in party mode + + // one bit in the following settings stands for + // a player or team count + // PlayerCount = 2 or 4 indicates that the mode is playable with 2 and 3 players per team + // TeamCount = 1 or 2 or 4 or 8 or 16 or 32 indicates that the mode is playable with 1 to 6 teams + PlayerCount: Integer; //< playable with one, two, three etc. players per team + TeamCount: Integer; //< playable with one, two, three etc. different teams + + + Functions: record // lua functions that will be called at specific events + BeforeSongSelect: String; // default actions are executed if functions = nil + AfterSongSelect: String; + + BeforeSing: String; + OnSing: String; + AfterSing: String; + end; + end; + + { used by TPartyGame to store player specific data } + TParty_PlayerInfo = record + Name: String; //< Playername + TimesPlayed: Integer; //< How often this Player has Sung + end; + + { used by TPartyGame to store team specific data } + TParty_TeamInfo = record + Name: String; //< name of the Team + Score: Word; //< current score + JokersLeft: Integer; //< jokers this team has left - TeamOrderArray = array[0..5] of byte; + NextPlayer: Integer; //Id of the player that plays the next (the current) song - TPartyPlugin = record - ID: byte; - TimesPlayed: byte; + Players: array of TParty_PlayerInfo; end; - TPartySession = class + TPartyGame = class private - function GetRandomPlayer(Team: byte): byte; - function GetRandomPlugin(Plugins: array of TPartyPlugin): byte; - function IsWinner(Player, Winner: byte): boolean; + bPartyGame: boolean; //< are we playing party or standard mode + CurRound: Integer; //< indicates which of the elements of Rounds is played next (at the moment) + + bPartyStarted: Boolean; + + TimesPlayed: array of Integer; //< times every mode was played in current party game (for random mode calculation) + procedure GenScores; + function GetRandomMode: integer; + function GetRandomPlayer(Team: integer): integer; + + { returns true if a mode is playable with current playerconfig } + function ModePlayable(I: integer): boolean; + + function CallLua(Parent: Integer; Func: String):Boolean; + + procedure SetRankingByScore; public - Teams: TTeamInfo; - Rounds: array of TRoundInfo; - CurRound: byte; + //Teams: TTeamInfo; + Rounds: array of TParty_Round; //< holds info which modes are played in this party game (if started) + Teams: array of TParty_TeamInfo; //< holds info of teams playing in current round (private for easy manipulation of lua functions) + + Modes: array of TParty_ModeInfo; //< holds info of registred party modes + + property CurrentRound: Integer read CurRound; constructor Create; - procedure StartNewParty(NumRounds: byte); - procedure StartRound; - procedure EndRound; - function GetTeamOrder: TeamOrderArray; - function GetWinnerString(Round: byte): string; + { set the attributes of Info to default values } + procedure DefaultModeInfo(var Info: TParty_ModeInfo); + + { registers a new mode, returns true on success + (mode name does not already exist) } + function RegisterMode(Info: TParty_ModeInfo): Boolean; + + { returns true if modes are available for + players and teams that are currently set + up. if there are no teams set up it returns + if there are any party modes available } + function ModesAvailable: Boolean; + + { returns an array with the name of all available modes (that + are playable with current player configuration } + function GetAvailableModes: AParty_ModeList; + + { clears all party specific data previously stored } + procedure Clear; + + { adds a team to the team array, returning its id + can only be called when game is not already started } + function AddTeam(Name: String): Integer; + + { adds a player to the player array, returning its id + can only be called when game is not already started } + function AddPlayer(Team: Integer; Name: String): Integer; + + { starts a new PartyGame, returns true on success + before a call of this function teams and players + has to be added by AddTeam and AddPlayer } + + function StartGame(Rounds: ARounds): Boolean; + + { sets the winner(s) of current round + returns true on success } + function SetRanking(Ranking: AParty_TeamRanking): Boolean; + + { increases round counter by 1 and clears all round specific information; + returns the number of the current round or -1 if last round has already + been played } + function NextRound: integer; + + { indicates that current round has already been played } + procedure RoundPlayed; + + { true if in a Party Game (not in standard mode) } + property PartyGame: Boolean read BPartyGame; + + + { returns true if last round was already played } + function GameFinished: Boolean; + + { call plugins defined function and/or default procedure + only default procedure is called when no function is defined by plugin + if plugins function returns true then default is called after plugins + function was executed} + procedure CallBeforeSongSelect; + procedure CallAfterSongSelect; + procedure CallBeforeSing; + procedure CallOnSing; + procedure CallAfterSing; + + { returns an array[1..6] of TParty_TeamRanking. + the index stands for the placing, + team is the team number (in the team array) + rank is correct rank if some teams have the + same score. + } + function GetTeamRanking: AParty_TeamRanking; + + { returns a string like "Team 1 (and Team 2) win" } + function GetWinnerString(Round: integer): UTF8String; + + destructor Destroy; end; +const + { minimal amount of teams for party mode } + Party_Teams_Min = 2; + + { maximal amount of teams for party mode } + Party_Teams_Max = 3; + + { minimal amount of players for party mode } + Party_Players_Min = 1; + + { maximal amount of players for party mode } + Party_Players_Max = 4; + + { amount of jokers each team gets at the beginning of the game } + Party_Count_Jokers = 5; + + { to indicate that element (mode) should set randomly in ARounds array } + Party_Round_Random = -1; + + { values for TParty_TeamRanking.Rank } + PR_First = 1; + PR_Second = 2; + PR_Third = 3; + + StandardModus = 0; //Modus Id that will be played in non-party mode + var - PartySession: TPartySession; + Party: TPartyGame; implementation uses - UDLLManager, UGraphic, - UNote, ULanguage, - ULog; + ULog, + ULuaCore, + UDisplay, + USong, + UNote, + SysUtils; -constructor TPartySession.Create; +//------------- +// Just the constructor +//------------- +constructor TPartyGame.Create; begin inherited; + + Clear; end; -//---------- -// Returns a number of a random plugin -//---------- -function TPartySession.GetRandomPlugin(Plugins: array of TPartyPlugin): byte; +destructor TPartyGame.Destroy; +begin + inherited; +end; + +{ clears all party specific data previously stored } +procedure TPartyGame.Clear; + var + I: Integer; +begin + bPartyGame := false; // no party game + CurRound := low(integer); + + bPartyStarted := false; //game not startet + + SetLength(Teams, 0); //remove team info + SetLength(Rounds, 0); //remove round info + + // clear times played + for I := 0 to High(TimesPlayed) do + TimesPlayed[I] := 0; +end; + +{ private: some intelligent randomnes for plugins } +function TPartyGame.GetRandomMode: integer; +var + LowestTP: integer; + NumPwithLTP: integer; + I: integer; + R: integer; +begin + Result := 0; //If there are no matching modes, play first modus + LowestTP := high(Integer); + NumPwithLTP := 0; + + // search for the plugins less played yet + for I := 0 to high(Modes) do + begin + if (ModePlayable(I)) then + begin + if (TimesPlayed[I] < lowestTP) then + begin + lowestTP := TimesPlayed[I]; + NumPwithLTP := 1; + end + else if (TimesPlayed[I] = lowestTP) then + begin + Inc(NumPwithLTP); + end; + end; + end; + + // create random number + R := Random(NumPwithLTP); + + // select the random mode from the modes with less timesplayed + for I := 0 to high(Modes) do + begin + if (TimesPlayed[I] = lowestTP) and (ModePlayable(I)) then + begin + //Plugin found + if (R = 0) then + begin + Result := I; + Inc(TimesPlayed[I]); + Break; + end; + + Dec(R); + end; + end; +end; + +{ private: GetRandomPlayer - returns a random player + that does not play to often ;) } +function TPartyGame.GetRandomPlayer(Team: integer): integer; var - LowestTP: byte; - NumPwithLTP: word; - I: integer; - R: word; + I, R: integer; + lowestTP: Integer; + NumPwithLTP: Integer; begin - LowestTP := high(byte); + LowestTP := high(Integer); NumPwithLTP := 0; + Result := 0; - //Search for Plugins not often played yet - for I := 0 to high(Plugins) do + // search for players that have less played yet + for I := 0 to High(Teams[Team].Players) do begin - if (Plugins[I].TimesPlayed < lowestTP) then + if (Teams[Team].Players[I].TimesPlayed < lowestTP) then begin - lowestTP := Plugins[I].TimesPlayed; + lowestTP := Teams[Team].Players[I].TimesPlayed; NumPwithLTP := 1; end - else if (Plugins[I].TimesPlayed = lowestTP) then + else if (Teams[Team].Players[I].TimesPlayed = lowestTP) then begin Inc(NumPwithLTP); end; end; - //Create random no + // create random number R := Random(NumPwithLTP); - //Search for random plugin - for I := 0 to high(Plugins) do + // search for selected random player + for I := 0 to High(Teams[Team].Players) do begin - if Plugins[I].TimesPlayed = LowestTP then + if Teams[Team].Players[I].TimesPlayed = lowestTP then begin - //Plugin found if (R = 0) then - begin - Result := Plugins[I].ID; - Inc(Plugins[I].TimesPlayed); + begin // found selected player + Result := I; Break; end; + Dec(R); end; end; end; //---------- -//StartNewParty - Reset and prepares for new party +//GenScores - inc scores for cur. round //---------- -procedure TPartySession.StartNewParty(NumRounds: byte); +procedure TPartyGame.GenScores; var - Plugins: array of TPartyPlugin; - TeamMode: boolean; - Len: integer; - I, J: integer; + I: Integer; +begin + if (Length(Teams) = 2) then + begin // score generation for 2 teams, winner gets 1 point + for I := 0 to High(Rounds[CurRound].Ranking) do + if (Rounds[CurRound].Ranking[I].Rank = PR_First) then + Inc(Teams[Rounds[CurRound].Ranking[I].Team].Score); + end + else if (Length(Teams) = 3) then + begin // score generation for 3 teams, + // winner gets 3 points 2nd gets 1 point + for I := 0 to High(Rounds[CurRound].Ranking) do + if (Rounds[CurRound].Ranking[I].Rank = PR_First) then + Inc(Teams[Rounds[CurRound].Ranking[I].Team].Score, 3) + else if (Rounds[CurRound].Ranking[I].Rank = PR_Second) then + Inc(Teams[Rounds[CurRound].Ranking[I].Team].Score); + end +end; + +{ set the attributes of Info to default values } +procedure TPartyGame.DefaultModeInfo(var Info: TParty_ModeInfo); +begin + Info.Name := 'undefined'; + Info.Parent := -1; //< not loaded by plugin (e.g. Duell) + Info.CanNonParty := false; + Info.CanParty := false; + Info.PlayerCount := High(Integer); //< no restrictions either on player count + Info.TeamCount := High(Integer); //< nor on team count + Info.Functions.BeforeSongSelect := ''; //< use default functions + Info.Functions.AfterSongSelect := ''; + Info.Functions.BeforeSing := ''; + Info.Functions.OnSing := ''; + Info.Functions.AfterSing := ''; +end; + +{ registers a new mode, returns true on success + (mode name does not already exist) } +function TPartyGame.RegisterMode(Info: TParty_ModeInfo): Boolean; + var + Len: integer; + LowerName: String; + I: integer; +begin + Result := false; + + if (Info.Name <> 'undefined') then + begin + // search for a plugin w/ same name + LowerName := lowercase(Info.Name); // case sensitive search + for I := 0 to high(Modes) do + if (LowerName = lowercase(Modes[I].Name)) then + exit; //< no success (name already exist) + + // add new mode to array and append and clear a new TimesPlayed element + Len := Length(Modes); + SetLength(Modes, Len + 1); + SetLength(TimesPlayed, Len + 1); + + Modes[Len] := Info; + TimesPlayed[Len] := 0; + + Result := True; + end; +end; + +{ returns true if a mode is playable with current playerconfig } +function TPartyGame.ModePlayable(I: integer): boolean; + var + J: integer; begin - //Set current round to 1 - CurRound := 255; + if (Length(Teams) = 0) then + Result := true + else + begin + if (Modes[I].TeamCount and (1 shl (Length(Teams) - 1)) <> 0) then + begin + Result := true; - PlayersPlay := Teams.NumTeams; + for J := 0 to High(Teams) do + Result := Result and (Modes[I].PlayerCount and (1 shl (Length(Teams[J].Players) - 1)) <> 0); + end + else + Result := false; + end; +end; - //Get team-mode and set joker, also set TimesPlayed - TeamMode := true; - for I := 0 to Teams.NumTeams - 1 do +{ returns true if modes are available for + players and teams that are currently set + up. if there are no teams set up it returns + if there are any party modes available } +function TPartyGame.ModesAvailable: Boolean; + var + I: integer; + CountTeams: integer; +begin + CountTeams := Length(Teams); + if CountTeams = 0 then + begin + Result := (Length(Modes) > 0); + end + else begin - if Teams.Teaminfo[I].NumPlayers < 2 then + Result := false; + for I := 0 to High(Modes) do begin - TeamMode := false; + Result := ModePlayable(I); + + if Result then + Exit; end; - //Set player attributes - for J := 0 to Teams.TeamInfo[I].NumPlayers-1 do + end; +end; + +{ returns an array with the name of all available modes (that + are playable with current player configuration } +function TPartyGame.GetAvailableModes: AParty_ModeList; + var + I: integer; + Len: integer; +begin + Len := 0; + SetLength(Result, Len + 1); + Result[Len].Index := Party_Round_Random; + Result[Len].Name := Language.Translate('MODE_RANDOM_NAME'); + + for I := 0 to High(Modes) do + if (ModePlayable(I)) then begin - Teams.TeamInfo[I].Playerinfo[J].TimesPlayed := 0; + Inc(Len); + SetLength(Result, Len + 1); + Result[Len].Index := I; + Result[Len].Name := Language.Translate('MODE_' + Uppercase(Modes[I].Name) + '_NAME'); end; - Teams.Teaminfo[I].Joker := Round(NumRounds * 0.7); - Teams.Teaminfo[I].Score := 0; +end; + +{ adds a team to the team array, returning its id + can only be called when game is not already started } +function TPartyGame.AddTeam(Name: String): Integer; +begin + Result := -1; + if (not bPartyStarted) and (Length(Name) > 0) and (Length(Teams) < Party_Teams_Max) then + begin + Result := Length(Teams); + SetLength(Teams, Result + 1); + + Teams[Result].Name := Name; + Teams[Result].Score := 0; + Teams[Result].JokersLeft := Party_Count_Jokers; + Teams[Result].NextPlayer := -1; end; +end; - //Fill plugin array - SetLength(Plugins, 0); - for I := 0 to high(DLLMan.Plugins) do +{ adds a player to the player array, returning its id + can only be called when game is not already started } +function TPartyGame.AddPlayer(Team: Integer; Name: String): Integer; +begin + Result := -1; + + if (not bPartyStarted) and (Team >= 0) and (Team <= High(Teams)) and (Length(Teams[Team].Players) < Party_Players_Max) and (Length(Name) > 0) then begin - if TeamMode or (not DLLMan.Plugins[I].TeamModeOnly) then - begin - //Add only those plugins playable with current PlayerConfiguration - Len := Length(Plugins); - SetLength(Plugins, Len + 1); - Plugins[Len].ID := I; - Plugins[Len].TimesPlayed := 0; - end; + // append element to players array + Result := Length(Teams[Team].Players); + SetLength(Teams[Team].Players, Result + 1); + + // fill w/ data + Teams[Team].Players[Result].Name := Name; + Teams[Team].Players[Result].TimesPlayed := 0; end; +end; + +{ starts a new PartyGame, returns true on success + before a call of this function teams and players + has to be added by AddTeam and AddPlayer } +function TPartyGame.StartGame(Rounds: ARounds): Boolean; + var + I: integer; +begin + Result := false; - //Set rounds - if (Length(Plugins) >= 1) then + if (not bPartyStarted) and (Length(Rounds) > 0) and (Length(Teams) >= Party_Teams_Min) then begin - SetLength (Rounds, NumRounds); - for I := 0 to NumRounds - 1 do + // check teams for minimal player count + for I := 0 to High(Teams) do + if (Length(Teams[I].Players) < Party_Players_Min) then + exit; + + // create rounds array + SetLength(Self.Rounds, Length(Rounds)); + + for I := 0 to High(Rounds) do begin - PartySession.Rounds[I].Plugin := GetRandomPlugin(Plugins); - PartySession.Rounds[I].Winner := 255; + // copy round or select a random round + if (Rounds[I] <> Party_Round_Random) and (Rounds[I] >= 0) and (Rounds[I] <= High(Modes)) then + Self.Rounds[I].Mode := Rounds[I] + else + Self.Rounds[I].Mode := GetRandomMode; + + Self.Rounds[I].AlreadyPlayed := false; + Self.Rounds[I].RankingSet := false; + + SetLength(Self.Rounds[I].Ranking, 0); end; + + // get the party started!11 + bPartyStarted := true; + bPartyGame := true; + CurRound := low(integer); //< set not to -1 to indicate that party game is not finished + + // first round + NextRound; + + Result := True; + end; +end; + +{ sets the winner(s) of current round + returns true on success } +function TPartyGame.SetRanking(Ranking: AParty_TeamRanking): Boolean; + var + I, J: Integer; + TeamExists: Integer; + Len: Integer; + Temp: TParty_TeamRanking; +begin + if (bPartyStarted) and (CurRound >= 0) and (CurRound <= High(Rounds)) then + begin + Rounds[CurRound].Ranking := Ranking; + Result := true; + + // look for teams that don't exist + TeamExists := 0; + for I := 0 to High(Rounds[CurRound].Ranking) do + TeamExists := TeamExists or (1 shl (Rounds[CurRound].Ranking[I].Team-1)); + + // create teams that don't exist + Len := Length(Rounds[CurRound].Ranking); + for I := 0 to High(Teams) do + if (TeamExists and (1 shl I) = 0) then + begin + Inc(Len); + SetLength(Rounds[CurRound].Ranking, Len); + Rounds[CurRound].Ranking[Len-1].Team := I + 1; + Rounds[CurRound].Ranking[Len-1].Rank := Length(Teams); + end; + + // we may remove rankings from invalid teams here to + // but at the moment this is not necessary, because the + // functions this function is called from don't create + // invalid rankings + + // bubble sort rankings by team + J := High(Rounds[CurRound].Ranking); + repeat + for I := 0 to J - 1 do + if (Rounds[CurRound].Ranking[I].Team > Rounds[CurRound].Ranking[I+1].Team) then + begin + Temp := Rounds[CurRound].Ranking[I]; + Rounds[CurRound].Ranking[I] := Rounds[CurRound].Ranking[I+1]; + Rounds[CurRound].Ranking[I+1] := Temp; + end; + Dec(J); + until J <= 0; + + //set rounds RankingSet to true + Rounds[CurRound].RankingSet := true; end else - SetLength (Rounds, 0); + Result := false; end; -{** - * Returns a random player to play next round - *} -function TPartySession.GetRandomPlayer(Team: byte): byte; -var - I, R: integer; - LowestTP: byte; - NumPwithLTP: byte; +{ sets ranking of current round by score saved in players array } +procedure TPartyGame.SetRankingByScore; + var + I, J: Integer; + Rank: Integer; + Ranking: AParty_TeamRanking; + Scores: array of Integer; + TmpRanking: TParty_TeamRanking; + TmpScore: Integer; begin - LowestTP := high(byte); - NumPwithLTP := 0; - Result := 0; - - //Search for players that have not often played yet - for I := 0 to Teams.Teaminfo[Team].NumPlayers - 1 do + if (Length(Player) = Length(Teams)) then begin - if (Teams.Teaminfo[Team].Playerinfo[I].TimesPlayed < lowestTP) then + SetLength(Ranking, Length(Teams)); + SetLength(Scores, Length(Teams)); + + // fill ranking array + for I := 0 to High(Ranking) do begin - lowestTP := Teams.Teaminfo[Team].Playerinfo[I].TimesPlayed; - NumPwithLTP := 1; - end - else if (Teams.Teaminfo[Team].Playerinfo[I].TimesPlayed = lowestTP) then + Ranking[I].Team := I; + Ranking[I].Rank := 0; + Scores[I] := Player[I].ScoreTotalInt; + end; + + // bubble sort by score + J := High(Ranking); + repeat + for I := 0 to J - 1 do + if (Scores[I] < Scores[I+1]) then + begin + TmpRanking := Ranking[I]; + Ranking[I] := Ranking[I+1]; + Ranking[I+1] := TmpRanking; + + TmpScore := Scores[I]; + Scores[I] := Scores[I+1]; + Scores[I+1] := TmpScore; + end; + Dec(J); + until J <= 0; + + // set rank field + Rank := 1; //first rank has id 1 + for I := 0 to High(Ranking) do begin - Inc(NumPwithLTP); + Ranking[I].Rank := Rank; + + if (I < High(Ranking)) and (Scores[I] <> Scores[I+1]) then + Inc(Rank); // next rank if next team has different score end; + end + else + SetLength(Ranking, 0); + + SetRanking(Ranking); +end; + +{ increases round counter by 1 and clears all round specific information; + returns the number of the current round or -1 if last round has already + been played } +function TPartyGame.NextRound: integer; + var I: Integer; +begin + // some lines concerning the previous round + if (CurRound >= 0) then + begin + Rounds[CurRound].AlreadyPlayed := true; + + GenScores; end; - //Create random number - R := Random(NumPwithLTP); + // increase round counter + Inc(CurRound); + if (CurRound < -1) then // we start first round + CurRound := 0; + + if (CurRound > High(Rounds)) then + CurRound := -1; //< last round played + + Result := CurRound; - //Search for random player - for I := 0 to Teams.Teaminfo[Team].NumPlayers - 1 do + // some lines concerning the next round + if (CurRound >= 0) then begin - if Teams.Teaminfo[Team].Playerinfo[I].TimesPlayed = lowestTP then + // select player + for I := 0 to High(Teams) do + Teams[I].NextPlayer := GetRandomPlayer(I); + end; +end; + +{ indicates that current round has already been played } +procedure TPartyGame.RoundPlayed; +begin + if (bPartyStarted) and (CurRound >= 0) and (CurRound <= High(Rounds)) then + begin + // set rounds ranking by score if it was not set by plugin + if (not Rounds[CurRound].RankingSet) then + SetRankingByScore; + + Rounds[CurRound].AlreadyPlayed := True; + end; +end; + +{ returns true if last round was already played } +function TPartyGame.GameFinished: Boolean; +begin + Result := (bPartyStarted and (CurRound = -1)); +end; + +{ private: calls the specified function Func from lua plugin Parent + if both exist. + return true if default function should be called + (function or plugin does not exist, or function returns + true) } +function TPartyGame.CallLua(Parent: Integer; Func: String):Boolean; + var + P: TLuaPlugin; +begin + // call default function by default + Result := true; + + // check for core plugin and empty function name + if (Parent >= 0) and (Length(Func) > 0) then + begin + // get plugin that registred the mode + P := LuaCore.GetPluginById(Parent); + + if (P <> nil) then begin - //Player found - if (R = 0) then - begin - Result := I; - Break; - end; - - Dec(R); + if (P.CallFunctionByName(Func, 0, 1)) then + // check result + Result := (lua_toboolean(P.LuaState, 1)); end; end; end; -{** - * Prepares ScreenSingModi for next round and loads plugin - *} -procedure TPartySession.StartRound; -var - I: integer; +{ call plugins defined function and/or default procedure + only default procedure is called when no function is defined by plugin + if plugins function returns true then default is called after plugins + function was executed} +procedure TPartyGame.CallBeforeSongSelect; + var + ExecuteDefault: boolean; begin - if ((CurRound < high(Rounds)) or (CurRound = high(CurRound))) then + if not bPartyStarted then + ExecuteDefault := true + else if (CurRound >= 0) then begin - //Increase Current Round - Inc(CurRound); - - Rounds[CurRound].Winner := 255; - DllMan.LoadPlugin(Rounds[CurRound].Plugin); + // we set screen song to party mode + // plugin should not have to do this if it + // don't want default procedure to be executed + ScreenSong.Mode := smPartyMode; - //Select Players - for I := 0 to Teams.NumTeams - 1 do - Teams.Teaminfo[I].CurPlayer := GetRandomPlayer(I); + with Modes[Rounds[CurRound].Mode] do + ExecuteDefault := (CallLua(Parent, Functions.BeforeSongSelect)); + end + else + ExecuteDefault := true; - //Set ScreenSingModie Variables - ScreenSingModi.TeamInfo := Teams; + // execute default function: + if ExecuteDefault then + begin + // display song select screen + Display.FadeTo(@ScreenSong); end; end; -//---------- -//EndRound - Get Winner from ScreenSingModi and Save Data to RoundArray -//---------- -procedure TPartySession.EndRound; -var - I: Integer; +procedure TPartyGame.CallAfterSongSelect; + var + ExecuteDefault: boolean; begin - //Copy Winner - Rounds[CurRound].Winner := ScreenSingModi.Winner; - //Set Scores - GenScores; + if not bPartyStarted then + ExecuteDefault := true + else if (CurRound >= 0) then + begin + with Modes[Rounds[CurRound].Mode] do + ExecuteDefault := (CallLua(Parent, Functions.AfterSongSelect)); + end + else + ExecuteDefault := true; + + // execute default function: + if ExecuteDefault then + begin + // display sing screen + ScreenSong.StartSong; + end; +end; - //Increase TimesPlayed 4 all Players - For I := 0 to Teams.NumTeams-1 do - Inc(Teams.Teaminfo[I].Playerinfo[Teams.Teaminfo[I].CurPlayer].TimesPlayed); +procedure TPartyGame.CallBeforeSing; + var + ExecuteDefault: boolean; +begin + if not bPartyStarted then + ExecuteDefault := true + else if (CurRound >= 0) then + begin + with Modes[Rounds[CurRound].Mode] do + ExecuteDefault := (CallLua(Parent, Functions.BeforeSing)); + end + else + ExecuteDefault := true; + // execute default function: + if ExecuteDefault then + begin + //nothing atm + { to-do : compartmentalize TSingScreen.OnShow into + functions for init of a specific part of + sing screen. + these functions should be called here before + sing screen is shown, or it should be called + by plugin if it wants to define a custom + singscreen start up. } + + //set correct playersplay + if (bPartyGame) then + PlayersPlay := Length(Teams); + end; end; -//---------- -//IsWinner - returns true if the player's bit is set in the winner byte -//---------- -function TPartySession.IsWinner(Player, Winner: byte): boolean; -var - Mask: byte; +procedure TPartyGame.CallOnSing; + var + ExecuteDefault: boolean; begin - Mask := 1 shl Player; - Result := (Winner and Mask) <> 0; + if not bPartyStarted then + ExecuteDefault := true + else if (CurRound >= 0) then + begin + with Modes[Rounds[CurRound].Mode] do + ExecuteDefault := (CallLua(Parent, Functions.OnSing));; + end + else + ExecuteDefault := true; + + // execute default function: + if ExecuteDefault then + begin + //nothing atm + end; end; -//---------- -//GenScores - increase scores for current round -//---------- -procedure TPartySession.GenScores; -var - I: byte; +procedure TPartyGame.CallAfterSing; + var + ExecuteDefault: boolean; begin - for I := 0 to Teams.NumTeams - 1 do + if not bPartyStarted then + ExecuteDefault := true + else if (CurRound >= 0) then + begin + with Modes[Rounds[CurRound].Mode] do + ExecuteDefault := (CallLua(Parent, Functions.AfterSing)); + end + else + ExecuteDefault := true; + + // execute default function: + if ExecuteDefault then begin - if isWinner(I, Rounds[CurRound].Winner) then - Inc(Teams.Teaminfo[I].Score); + if (bPartyGame) then + // display party score screen + Display.FadeTo(@ScreenPartyScore) + else //display standard score screen + Display.FadeTo(@ScreenScore); end; end; -//---------- -//GetTeamOrder - returns the placement of each Team [First Position of Array is Teamnum of first placed Team, ...] -//---------- -function TPartySession.GetTeamOrder: TeamOrderArray; -var - I, J: integer; - ATeams: array [0..5] of TeamOrderEntry; - TempTeam: TeamOrderEntry; +{ returns an array[1..6] of integer. the index stands for the placing, + value is the team number (in the team array) } +function TPartyGame.GetTeamRanking: AParty_TeamRanking; + var + I, J: Integer; + Temp: TParty_TeamRanking; + Rank: Integer; begin - // TODO: PartyMode: Write this in another way, so that teams with the same score get the same place - //Fill Team array - for I := 0 to Teams.NumTeams - 1 do + SetLength(Result, Length(Teams)); + + // fill ranking array + for I := 0 to High(Result) do begin - ATeams[I].Teamnum := I; - ATeams[I].Score := Teams.Teaminfo[I].Score; + Result[I].Team := I; + Result[I].Rank := 0; end; - //Sort teams - for J := 0 to Teams.NumTeams - 1 do - for I := 1 to Teams.NumTeams - 1 do - if ATeams[I].Score > ATeams[I-1].Score then + // bubble sort by score + J := High(Result); + repeat + for I := 0 to J - 1 do + if (Teams[Result[I].Team].Score < Teams[Result[I+1].Team].Score) then begin - TempTeam := ATeams[I-1]; - ATeams[I-1] := ATeams[I]; - ATeams[I] := TempTeam; + Temp := Result[I]; + Result[I] := Result[I+1]; + Result[I+1] := Temp; end; + Dec(J); + until J <= 0; + + // set rank field + Rank := 1; //first rank has id 1 + for I := 0 to High(Result) do + begin + Result[I].Rank := Rank; - //Copy to Result - for I := 0 to Teams.NumTeams-1 do - Result[I] := ATeams[I].TeamNum; + if (I < High(Result)) and (Teams[Result[I].Team].Score <> Teams[Result[I+1].Team].Score) then + Inc(Rank); // next rank if next team has different score + end; end; -//---------- -//GetWinnerString - Get string with WinnerTeam Name, when there is more than one Winner than Connect with and or , -//---------- -function TPartySession.GetWinnerString(Round: byte): string; +{ returns a string like "Team 1 (and Team 2) win" + if Round is in range from 0 to high(Rounds) then + result is name of winners of specified round. + if Round is -1 the result is name of winners of + the whole party game} +function TPartyGame.GetWinnerString(Round: integer): UTF8String; var - Winners: array of string; - I: integer; + Winners: array of UTF8String; + I: integer; + Ranking: AParty_TeamRanking; begin - Result := Language.Translate('PARTY_NOBODY'); + Result := ''; + Ranking := nil; - if (Round > High(Rounds)) then - exit; - - if (Rounds[Round].Winner = 0) then + if (Round >= 0) and (Round <= High(Rounds)) then begin - exit; - end; + if (not Rounds[Round].AlreadyPlayed) then + Result := Language.Translate('PARTY_NOTPLAYEDYET') + else + Ranking := Rounds[Round].Ranking; + end + else if (Round = -1) then + Ranking := GetTeamRanking; - if (Rounds[Round].Winner = 255) then - begin - Result := Language.Translate('PARTY_NOTPLAYEDYET'); - exit; - end; - SetLength(Winners, 0); - for I := 0 to Teams.NumTeams - 1 do + if (Ranking <> nil) then begin - if isWinner(I, Rounds[Round].Winner) then + SetLength(Winners, 0); + for I := 0 to High(Ranking) do begin - SetLength(Winners, Length(Winners) + 1); - Winners[high(Winners)] := Teams.TeamInfo[I].Name; + if (Ranking[I].Rank = PR_First) and (Ranking[I].Team >= 0) and (Ranking[I].Team <= High(Teams)) then + begin + SetLength(Winners, Length(Winners) + 1); + Winners[high(Winners)] := UTF8String(Teams[Ranking[I].Team].Name); + end; end; + + if (Length(Winners) > 0) then + Result := Language.Implode(Winners); end; - Result := Language.Implode(Winners); + + if (Length(Result) = 0) then + Result := Language.Translate('PARTY_NOBODY'); end; end. diff --git a/cmake/src/base/UPath.pas b/cmake/src/base/UPath.pas index 2316ac02..7c00e7b1 100644 --- a/cmake/src/base/UPath.pas +++ b/cmake/src/base/UPath.pas @@ -1,188 +1,1427 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL: https://ultrastardx.svn.sourceforge.net/svnroot/ultrastardx/trunk/src/base/UPath.pas $ - * $Id: UPath.pas 1624 2009-03-06 23:45:10Z k-m_schindler $ - *} - -unit UPath; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - Classes; - -var - // Absolute Paths - GamePath: string; - SoundPath: string; - SongPaths: TStringList; - LogPath: string; - ThemePath: string; - SkinsPath: string; - ScreenshotsPath: string; - CoverPaths: TStringList; - LanguagesPath: string; - PluginPath: string; - VisualsPath: string; - FontPath: string; - ResourcesPath: string; - PlayListPath: string; - -function FindPath(out PathResult: string; const RequestedPath: string; NeedsWritePermission: boolean): boolean; -procedure InitializePaths; -procedure AddSongPath(const Path: string); - -implementation - -uses - StrUtils, - UPlatform, - UCommandLine, - ULog; - -procedure AddSpecialPath(var PathList: TStringList; const Path: string); -var - Index: integer; - PathAbs, OldPathAbs: string; -begin - if (PathList = nil) then - PathList := TStringList.Create; - - if (Path = '') or not ForceDirectories(Path) then - Exit; - - PathAbs := IncludeTrailingPathDelimiter(ExpandFileName(Path)); - - // check if path or a part of the path was already added - for Index := 0 to PathList.Count-1 do - begin - OldPathAbs := IncludeTrailingPathDelimiter(ExpandFileName(PathList[Index])); - // check if the new directory is a sub-directory of a previously added one. - // This is also true, if both paths point to the same directories. - if (AnsiStartsText(OldPathAbs, PathAbs)) then - begin - // ignore the new path - Exit; - end; - - // check if a previously added directory is a sub-directory of the new one. - if (AnsiStartsText(PathAbs, OldPathAbs)) then - begin - // replace the old with the new one. - PathList[Index] := PathAbs; - Exit; - end; - end; - - PathList.Add(PathAbs); -end; - -procedure AddSongPath(const Path: string); -begin - AddSpecialPath(SongPaths, Path); -end; - -procedure AddCoverPath(const Path: string); -begin - AddSpecialPath(CoverPaths, Path); -end; - -(** - * Initialize a path variable - * After setting paths, make sure that paths exist - *) -function FindPath(out PathResult: string; - const RequestedPath: string; - NeedsWritePermission: boolean) - : boolean; -begin - Result := false; - - if (RequestedPath = '') then - Exit; - - // Make sure the directory exists - if (not ForceDirectories(RequestedPath)) then - begin - PathResult := ''; - Exit; - end; - - PathResult := IncludeTrailingPathDelimiter(RequestedPath); - - if (NeedsWritePermission) and - (FileIsReadOnly(RequestedPath)) then - begin - Exit; - end; - - Result := true; -end; - -(** - * Function sets all absolute paths e.g. song path and makes sure the directorys exist - *) -procedure InitializePaths; -begin - // Log directory (must be writable) - if (not FindPath(LogPath, Platform.GetLogPath, true)) then - begin - Log.FileOutputEnabled := false; - Log.LogWarn('Log directory "'+ Platform.GetLogPath +'" not available', 'InitializePaths'); - end; - - FindPath(SoundPath, Platform.GetGameSharedPath + 'sounds', false); - FindPath(ThemePath, Platform.GetGameSharedPath + 'themes', false); - FindPath(SkinsPath, Platform.GetGameSharedPath + 'themes', false); - FindPath(LanguagesPath, Platform.GetGameSharedPath + 'languages', false); - FindPath(PluginPath, Platform.GetGameSharedPath + 'plugins', false); - FindPath(VisualsPath, Platform.GetGameSharedPath + 'visuals', false); - FindPath(FontPath, Platform.GetGameSharedPath + 'fonts', false); - FindPath(ResourcesPath, Platform.GetGameSharedPath + 'resources', false); - - // Playlists are not shared as we need one directory to write too - FindPath(PlaylistPath, Platform.GetGameUserPath + 'playlists', true); - - // Screenshot directory (must be writable) - if (not FindPath(ScreenshotsPath, Platform.GetGameUserPath + 'screenshots', true)) then - begin - Log.LogWarn('Screenshot directory "'+ Platform.GetGameUserPath +'" not available', 'InitializePaths'); - end; - - // Add song paths - AddSongPath(Params.SongPath); - AddSongPath(Platform.GetGameSharedPath + 'songs'); - AddSongPath(Platform.GetGameUserPath + 'songs'); - - // Add category cover paths - AddCoverPath(Platform.GetGameSharedPath + 'covers'); - AddCoverPath(Platform.GetGameUserPath + 'covers'); -end; - -end. +{* UltraStar Deluxe - Karaoke Game
+ *
+ * UltraStar Deluxe is the legal property of its developers, whose names
+ * are too numerous to list here. Please refer to the COPYRIGHT
+ * file distributed with this source distribution.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301, USA.
+ *
+ * $URL$
+ * $Id$
+ *}
+
+unit UPath;
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+{$ENDIF}
+
+{$I switches.inc}
+
+interface
+
+uses
+ SysUtils,
+ Classes,
+ IniFiles,
+ {$IFDEF MSWINDOWS}
+ TntClasses,
+ {$ENDIF}
+ UConfig,
+ UUnicodeUtils;
+
+type
+ IPath = interface;
+
+ {$IFDEF FPC}
+ TFileHandle = THandle;
+ {$ELSE}
+ TFileHandle = Longint;
+ {$ENDIF}
+
+ {**
+ * TUnicodeMemoryStream
+ *}
+ TUnicodeMemoryStream = class(TMemoryStream)
+ public
+ procedure LoadFromFile(const FileName: IPath);
+ procedure SaveToFile(const FileName: IPath);
+ end;
+
+ {**
+ * Unicode capable IniFile implementation.
+ * TMemIniFile and TIniFile are not able to handle INI-files with
+ * an UTF-8 BOM. This implementation checks if an UTF-8 BOM exists
+ * and removes it from the internal string-list.
+ * UTF8Encoded is set accordingly.
+ *}
+ TUnicodeMemIniFile = class(TMemIniFile)
+ private
+ FFilename: IPath;
+ FUTF8Encoded: boolean;
+ public
+ constructor Create(const FileName: IPath; UTF8Encoded: boolean = false); reintroduce;
+ procedure UpdateFile; override;
+ property UTF8Encoded: boolean READ FUTF8Encoded WRITE FUTF8Encoded;
+ end;
+
+ {**
+ * TBinaryFileStream (inherited from THandleStream)
+ *}
+ {$IFDEF MSWINDOWS}
+ TBinaryFileStream = class(TTntFileStream)
+ {$ELSE}
+ TBinaryFileStream = class(TFileStream)
+ {$ENDIF}
+ public
+ {**
+ * @seealso TFileStream.Create for valid Mode parameters
+ *}
+ constructor Create(const FileName: IPath; Mode: word);
+ end;
+
+ {**
+ * TTextFileStream
+ *}
+ TTextFileStream = class(TStream)
+ protected
+ fLineBreak: RawByteString;
+ fFilename: IPath;
+ fMode: word;
+
+ function ReadLine(var Success: boolean): RawByteString; overload; virtual; abstract;
+ public
+ constructor Create(Filename: IPath; Mode: word);
+
+ function ReadString(): RawByteString; virtual; abstract;
+ function ReadLine(var Line: UTF8String): boolean; overload;
+ function ReadLine(var Line: AnsiString): boolean; overload;
+
+ procedure WriteString(const Str: RawByteString); virtual;
+ procedure WriteLine(const Line: RawByteString); virtual;
+
+ property LineBreak: RawByteString read fLineBreak write fLineBreak;
+ property Filename: IPath read fFilename;
+ end;
+
+ {**
+ * TMemTextStream
+ *}
+ TMemTextFileStream = class(TTextFileStream)
+ private
+ fStream: TMemoryStream;
+ protected
+ function GetSize: int64; override;
+
+ {**
+ * Copies fStream.Memory from StartPos to EndPos-1 to the result string;
+ *}
+ function CopyMemString(StartPos: int64; EndPos: int64): RawByteString;
+ public
+ constructor Create(Filename: IPath; Mode: word);
+ destructor Destroy(); override;
+
+ function Read(var Buffer; Count: longint): longint; override;
+ function Write(const Buffer; Count: longint): longint; override;
+ function Seek(Offset: longint; Origin: word): longint; override;
+ function Seek(const Offset: int64; Origin: TSeekOrigin): int64; override;
+
+ function ReadLine(var Success: boolean): RawByteString; override;
+ function ReadString(): RawByteString; override;
+ end;
+
+ {**
+ TUnicodeIniStream = class()
+ end;
+ *}
+
+ {**
+ * pdKeep: Keep path as is, neither remove or append a delimiter
+ * pdAppend: Append a delimiter if path does not have a trailing one
+ * pdRemove: Remove a trailing delimiter from the path
+ *}
+ TPathDelimOption = (pdKeep, pdAppend, pdRemove);
+
+ IPathDynArray = array of IPath;
+
+ {**
+ * An IPath represents a filename, a directory or a filesystem path in general.
+ * It hides some of the operating system's specifics like path delimiters
+ * and encodings and provides an easy to use interface to handle them.
+ * Internally all paths are stored with the same path delimiter (PathDelim)
+ * and encoding (UTF-8). The transformation is already done AT THE CREATION of
+ * the IPath and hence calls to e.g. IPath.Equal() will not distinguish between
+ * Unix and Windows style paths.
+ *
+ * Create new paths with one of the Path() functions.
+ * If you need a string representation use IPath.ToNative/ToUTF8/ToWide.
+ * Note that due to the path-delimiter and encoding transformation the string
+ * might have changed. Path('one\test/path').ToUTF8() might return 'one/test/path'.
+ *
+ * It is recommended to use an IPath as long as possible without a string
+ * conversion (IPath.To...()). The whole Delphi (< 2009) and FPC RTL is ANSI
+ * only on Windows. If you would use for example FileExists(MyPath.ToNative)
+ * it would not find a file which contains characters that are not in the
+ * current locale. Same applies to AssignFile(), TFileStream.Create() and
+ * everything else in the RTL that expects a filename.
+ * As a rule of thumb: NEVER use any of the Delphi/FPC RTL filename functions
+ * if the filename parameter is not of a UTF8String or WideString type.
+ *
+ * If you need to open a file use TBinaryStream or TFileStream instead. Many
+ * of the RTL classes offer a LoadFromStream() method so ANSI Open() methods
+ * can be workaround.
+ *
+ * If there is only a ANSI and no IPath/UTF-8/WideString version and you cannot
+ * even pass a stream instead of a filename be aware that even if you know that
+ * a filename is ASCII only, subdirectories in an absolute path might contain
+ * some non-ASCII characters (for example the user's name) and hence might
+ * fail (if the characters are not in the current locale).
+ * It is rare but it happens.
+ *
+ * IMPORTANT:
+ * This interface needs the cwstring unit on Unix (Max OS X / Linux) systems.
+ * Cwstring functions (WideUpperCase, ...) cannot be used by external threads
+ * as FPC uses Thread-Local-Storage for the implementation. As a result do not
+ * call IPath stuff by external threads (e.g. in C callbacks or by SDL-threads).
+ *}
+ IPath = interface
+ ['{686BF103-CE43-4598-B85D-A2C3AF950897}']
+ {**
+ * Returns the path as an UTF8 encoded string.
+ * If UseNativeDelim is set to true, the native path delimiter ('\' on win32)
+ * is used. If it is set to false the (more) portable '/' delimiter will used.
+ *}
+ function ToUTF8(UseNativeDelim: boolean = true): UTF8String;
+
+ {**
+ * Returns the path as an UTF-16 encoded string.
+ * If UseNativeDelim is set to true, the native path delimiter ('\' on win32)
+ * is used. If it is set to false the delimiter will be '/'.
+ *}
+ function ToWide(UseNativeDelim: boolean = true): WideString;
+
+ {**
+ * Returns the path with the system's native encoding and path delimiter.
+ * Win32: ANSI (use the UTF-16 version IPath.ToWide() whenever possible)
+ * Mac: UTF8
+ * Unix: UTF8 or ANSI according to LC_CTYPE
+ *}
+ function ToNative(): RawByteString;
+
+ {**
+ * Note: File must be closed with FileClose(Handle) after usage
+ * @seealso SysUtils.FileOpen()
+ *}
+ function Open(Mode: longword): TFileHandle;
+
+ {** @seealso SysUtils.ExtractFileDrive() *}
+ function GetDrive(): IPath;
+
+ {** @seealso SysUtils.ExtractFilePath() *}
+ function GetPath(): IPath;
+
+ {** @seealso SysUtils.ExtractFileDir() *}
+ function GetDir(): IPath;
+
+ {** @seealso SysUtils.ExtractFileName() *}
+ function GetName(): IPath;
+
+ {** @seealso SysUtils.ExtractFileExtension() *}
+ function GetExtension(): IPath;
+
+ {**
+ * Returns a copy of the path with the extension changed to Extension.
+ * The file itself is not changed, use Rename() for this task.
+ * @seealso SysUtils.ChangeFileExt()
+ *}
+ function SetExtension(const Extension: IPath): IPath; overload;
+ function SetExtension(const Extension: RawByteString): IPath; overload;
+ function SetExtension(const Extension: WideString): IPath; overload;
+
+ {**
+ * Returns the representation of the path relative to Basename.
+ * Note that the basename must be terminated with a path delimiter
+ * otherwise the last path component will be ignored.
+ * @seealso SysUtils.ExtractRelativePath()
+ *}
+ function GetRelativePath(const BaseName: IPath): IPath;
+
+ {** @seealso SysUtils.ExpandFileName() *}
+ function GetAbsolutePath(): IPath;
+
+ {**
+ * Returns the concatenation of this path with Child. If this path does not
+ * end with a path delimiter one is inserted in front of the Child path.
+ * Example: Path('parent').Append(Path('child')) -> Path('parent/child')
+ *}
+ function Append(const Child: IPath; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
+ function Append(const Child: RawByteString; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
+ function Append(const Child: WideString; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
+
+ {**
+ * Splits the path into its components. Path delimiters are not removed from
+ * components.
+ * Example: C:\test\my\dir -> ['C:\', 'test\', 'my\', 'dir']
+ *}
+ function SplitDirs(): IPathDynArray;
+
+ {**
+ * Returns the parent directory or PATH_NONE if none exists.
+ *}
+ function GetParent(): IPath;
+
+ {**
+ * Checks if this path is a subdir of or file inside Parent.
+ * If Direct is true this path must be a direct child.
+ * Example: C:\test\file is a direct child of C:\test and a child of C:\
+ *}
+ function IsChildOf(const Parent: IPath; Direct: boolean): boolean;
+
+ {**
+ * Adjusts the case of the path on case senstitive filesystems.
+ * If the path does not exist or the filesystem is case insensitive
+ * the original path will be returned. Otherwise a corrected copy.
+ *}
+ function AdjustCase(AdjustAllLevels: boolean): IPath;
+
+ {** @seealso SysUtils.IncludeTrailingPathDelimiter() *}
+ function AppendPathDelim(): IPath;
+
+ {** @seealso SysUtils.ExcludeTrailingPathDelimiter() *}
+ function RemovePathDelim(): IPath;
+
+ function Exists(): boolean;
+ function IsFile(): boolean;
+ function IsDirectory(): boolean;
+ function IsAbsolute(): boolean;
+ function GetFileAge(): integer; overload;
+ function GetFileAge(out FileDateTime: TDateTime): boolean; overload;
+ function GetAttr(): cardinal;
+ function SetAttr(Attr: Integer): boolean;
+ function IsReadOnly(): boolean;
+ function SetReadOnly(ReadOnly: boolean): boolean;
+
+ {**
+ * Checks if this path points to nothing, that means the path consists of
+ * the empty string '' and hence equals PATH_NONE.
+ * This is a shortcut for IPath.Equals('') or IPath.Equals(PATH_NONE).
+ * If IsUnset() returns true this path and PATH_NONE are equal but they must
+ * not be identical as the references might point to different objects.
+ *
+ * Example:
+ * Path('').Equals(PATH_EMPTY) -> true
+ * Path('') = PATH_EMPTY -> false
+ *}
+ function IsUnset(): boolean;
+ function IsSet(): boolean;
+
+ {**
+ * Compares this path with Other and returns true if both paths are
+ * equal. Both paths are expanded and trailing slashes excluded before
+ * comparison. If IgnoreCase is true, the case will be ignored on
+ * case-sensitive filesystems.
+ *}
+ function Equals(const Other: IPath; IgnoreCase: boolean = false): boolean; overload;
+ function Equals(const Other: RawByteString; IgnoreCase: boolean = false): boolean; overload;
+ function Equals(const Other: WideString; IgnoreCase: boolean = false): boolean; overload;
+
+ {**
+ * Searches for a file in DirList. The Result is nil if the file was
+ * not found. Use IFileSystem.FileFind() instead if you want to use
+ * wildcards.
+ * @seealso SysUtils.FileSearch()
+ *}
+ function FileSearch(const DirList: IPath): IPath;
+
+ {**
+ * File must be closed with FileClose(Handle) after usage
+ *}
+ function CreateFile(): TFileHandle;
+ function DeleteFile(): boolean;
+ function CreateDirectory(Force: boolean = false): boolean;
+ function DeleteEmptyDir(): boolean;
+ function Rename(const NewName: IPath): boolean;
+ function CopyFile(const Target: IPath; FailIfExists: boolean): boolean;
+
+ // TODO: Dirwatch stuff
+ // AddFileChangeListener(Listener: TFileChangeListener);
+
+ {**
+ * Internal string representation. For debugging only.
+ *}
+ function GetIntern: UTF8String;
+ property Intern: UTF8String READ GetIntern;
+ end;
+
+{**
+ * Creates a new path with the given pathname. PathName can be either in UTF8
+ * or the local encoding.
+ * Notes:
+ * - On Apple only UTF8 is supported
+ * - Same applies to Unix with LC_CTYPE set to UTF8 encoding (default on newer systems)
+ *}
+function Path(const PathName: RawByteString; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
+function Path(PathName: PChar; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
+
+{**
+ * Creates a new path with the given UTF-16 pathname.
+ *}
+function Path(const PathName: WideString; DelimOption: TPathDelimOption = pdKeep): IPath; overload;
+
+{**
+ * Returns a singleton for Path('').
+ *}
+function PATH_NONE(): IPath;
+
+implementation
+
+uses
+ RTLConsts,
+ UTextEncoding,
+ UFilesystem;
+
+{*
+ * Due to a compiler bug in FPC <= 2.2.4 reference counting does not work
+ * properly with interfaces (see http://bugs.freepascal.org/view.php?id=14019).
+ *
+ * There are two (probably more) scenarios causes a program to crash:
+ *
+ * 1. Assume we execute Path('fail').GetParent().ToUTF8(). The compiler will
+ * internally create a temporary variable to hold the result of Path('fail').
+ * This temporary var is then passed as Self to GetParent(). Unfortunately FPC
+ * does already decrement the ref-count of the temporary var at the end of the
+ * call to Path('fail') and the ref-count drops to zero and the temp object
+ * is destroyed as FPC erroneously assumes that the temp is not used anymore.
+ * As a result the Self variable in GetParent() will be invalid, the same
+ * applies to TPathImpl.fName which reference count dropped to zero when the
+ * temp was destroyed. Hence GetParent() will likely crash.
+ * If it does not, ToUTF8() will either return some random string
+ * (e.g. '' or stupid stuff like 'fhwkjehdk') or crash.
+ * Either way the result of ToUTF8() is messed up.
+ * This scenario applies whenever a function (or method) is called that returns
+ * an interfaced object (e.g. an IPath) and the result is used without storing
+ * a reference to it in a (temporary) variable first.
+ *
+ * Tmp := Path('fail'); Tmp2 := Tmp.GetParent(); Tmp2.ToUTF8();
+ *
+ * will not crash but is very impractical and error-prone. Note that Tmp2 cannot
+ * be replaced with Tmp (see scenario 2).
+ *
+ * 2. Another situation this bug will ruin our lives is when a variable to an
+ * interfaced object is used at the left and right side of an assignment as in:
+ * MyPath := MyPath.GetParent()
+ *
+ * Although the bug is already fixed in the FPC development version 2.3.1
+ * it will take quite some time till the next FPC release (> 2.2.4) in which
+ * this issue is fixed.
+ *
+ * To workaround this bug we use some very simple and stupid kind of garbage
+ * collection. New IPaths are stored in an IInterfaceList (call it GarbaegeList)
+ * to artificially increase the ref-count of the newly created object.
+ * This keeps the object alive when FPC's temporary variable comes to the end
+ * of its lifetime and the object's ref-count is decremented
+ * (and is now 1 instead of 0).
+ * Later on, the object is either garbage or referenced by another variable.
+ *
+ * Look at
+ * MyPath := Path('SomeDir/SubDir').GetParent()
+ *
+ * (1) The result of Path('SomeDir/SubDir') is garbage as it is not used anymore.
+ * (2) The result of GetParent() is referenced by MyPath
+ * Object (1) has a reference count of 1 (as it is only referenced by the
+ * GarbageList). Object (2) is referenced twice (MyPath + GarbageList).
+ * When the reference to (2) is finally stored in MyPath we can safely remove
+ * (1) and (2) from the GarbageList so (1) will be freed and the ref-count of
+ * (2) will be decremented to 1.
+ *
+ * As we do not know when it is safe to remove an object from the GarbageList
+ * we assume that there are max. GarbageMaxCount IPath elements created until
+ * the execution of the expression is performed and a reference to the resulting
+ * object is assigned to a variable so all temps can be safely deleted.
+ *
+ * Worst-case scenarios are recursive calls or calls with large call stacks with
+ * functions that return an IPath. Also keep in mind that multiple threads might
+ * be executing such functions at the same time.
+ * A reasonable count might be a max. of 20.000 elements. With an average length
+ * of 40 UTF8 chars (maybe 60 byte with class info, pointer etc.) per IPath
+ * this will consume ~1.2MB.
+ *}
+{$IFDEF FPC}
+{$IF FPC_VERSION_INT <= 002002004} // <= 2.2.4
+ {$DEFINE HAVE_REFCNTBUG}
+{$IFEND}
+{$ENDIF}
+
+{$IFDEF HAVE_REFCNTBUG}
+const
+ // when GarbageList.Count reaches GarbageMaxCount the oldest references in
+ // GarbageList will be deleted until GarbageList.Count equals GarbageAfterCleanCount.
+ GarbageMaxCount = 20000;
+ GarbageAfterCleanCount = GarbageMaxCount-1000;
+
+var
+ GarbageList: IInterfaceList;
+{$ENDIF}
+
+type
+ TPathImpl = class(TInterfacedObject, IPath)
+ private
+ fName: UTF8String; //<** internal filename string, always UTF8 with PathDelim
+
+ {**
+ * Unifies the filename. Path-delimiters are replaced by '/'.
+ *}
+ procedure Unify(DelimOption: TPathDelimOption);
+
+ {**
+ * Returns a copy of fName with path delimiters changed to '/'.
+ *}
+ function GetPortableString(): UTF8String;
+
+ procedure AssertRefCount; {$IFDEF HasInline}inline;{$ENDIF}
+
+ public
+ constructor Create(const Name: UTF8String; DelimOption: TPathDelimOption);
+ destructor Destroy(); override;
+
+ function ToUTF8(UseNativeDelim: boolean): UTF8String;
+ function ToWide(UseNativeDelim: boolean): WideString;
+ function ToNative(): RawByteString;
+
+ function Open(Mode: longword): TFileHandle;
+
+ function GetDrive(): IPath;
+ function GetPath(): IPath;
+ function GetDir(): IPath;
+ function GetName(): IPath;
+ function GetExtension(): IPath;
+
+ function SetExtension(const Extension: IPath): IPath; overload;
+ function SetExtension(const Extension: RawByteString): IPath; overload;
+ function SetExtension(const Extension: WideString): IPath; overload;
+
+ function GetRelativePath(const BaseName: IPath): IPath;
+ function GetAbsolutePath(): IPath;
+ function GetParent(): IPath;
+ function SplitDirs(): IPathDynArray;
+
+ function Append(const Child: IPath; DelimOption: TPathDelimOption): IPath; overload;
+ function Append(const Child: RawByteString; DelimOption: TPathDelimOption): IPath; overload;
+ function Append(const Child: WideString; DelimOption: TPathDelimOption): IPath; overload;
+
+ function Equals(const Other: IPath; IgnoreCase: boolean): boolean; overload;
+ function Equals(const Other: RawByteString; IgnoreCase: boolean): boolean; overload;
+ function Equals(const Other: WideString; IgnoreCase: boolean): boolean; overload;
+
+ function IsChildOf(const Parent: IPath; Direct: boolean): boolean;
+
+ function AdjustCase(AdjustAllLevels: boolean): IPath;
+
+ function AppendPathDelim(): IPath;
+ function RemovePathDelim(): IPath;
+
+ function GetFileAge(): integer; overload;
+ function GetFileAge(out FileDateTime: TDateTime): boolean; overload;
+ function Exists(): boolean;
+ function IsFile(): boolean;
+ function IsDirectory(): boolean;
+ function IsAbsolute(): boolean;
+ function GetAttr(): cardinal;
+ function SetAttr(Attr: Integer): boolean;
+ function IsReadOnly(): boolean;
+ function SetReadOnly(ReadOnly: boolean): boolean;
+
+ function IsUnset(): boolean;
+ function IsSet(): boolean;
+
+ function FileSearch(const DirList: IPath): IPath;
+
+ function CreateFile(): TFileHandle;
+ function DeleteFile(): boolean;
+ function CreateDirectory(Force: boolean): boolean;
+ function DeleteEmptyDir(): boolean;
+ function Rename(const NewName: IPath): boolean;
+ function CopyFile(const Target: IPath; FailIfExists: boolean): boolean;
+
+ function GetIntern(): UTF8String;
+ end;
+
+function Path(const PathName: RawByteString; DelimOption: TPathDelimOption): IPath;
+begin
+ if (IsUTF8String(PathName)) then
+ Result := TPathImpl.Create(PathName, DelimOption)
+ else if (IsNativeUTF8()) then
+ Result := PATH_NONE
+ else
+ Result := TPathImpl.Create(AnsiToUtf8(PathName), DelimOption);
+end;
+
+function Path(PathName: PChar; DelimOption: TPathDelimOption): IPath;
+begin
+ Result := Path(RawByteString(PathName));
+end;
+
+function Path(const PathName: WideString; DelimOption: TPathDelimOption): IPath;
+begin
+ Result := TPathImpl.Create(UTF8Encode(PathName), DelimOption);
+end;
+
+
+
+procedure TPathImpl.AssertRefCount;
+begin
+ {$IFDEF HAVE_REFCNTBUG}
+ if (FRefCount <= 0) then
+ raise Exception.Create('RefCount error: ' + IntToStr(FRefCount));
+ {$ENDIF}
+end;
+
+constructor TPathImpl.Create(const Name: UTF8String; DelimOption: TPathDelimOption);
+begin
+ inherited Create();
+ fName := Name;
+ Unify(DelimOption);
+ {$IFDEF HAVE_REFCNTBUG}
+ GarbageList.Lock;
+ if (GarbageList.Count >= GarbageMaxCount) then
+ begin
+ while (GarbageList.Count > GarbageAfterCleanCount) do
+ GarbageList.Delete(0);
+ end;
+ GarbageList.Add(Self);
+ GarbageList.Unlock;
+ {$ENDIF}
+end;
+
+destructor TPathImpl.Destroy();
+begin
+ inherited;
+end;
+
+procedure TPathImpl.Unify(DelimOption: TPathDelimOption);
+var
+ I: integer;
+begin
+ // convert all path delimiters to native ones
+ for I := 1 to Length(fName) do
+ begin
+ if (fName[I] in ['\', '/']) and (fName[I] <> PathDelim) then
+ fName[I] := PathDelim;
+ end;
+
+ // Include/ExcludeTrailingPathDelimiter need PathDelim as path delimiter
+ case DelimOption of
+ pdAppend: fName := IncludeTrailingPathDelimiter(fName);
+ pdRemove: fName := ExcludeTrailingPathDelimiter(fName);
+ end;
+end;
+
+function TPathImpl.GetPortableString(): UTF8String;
+var
+ I: integer;
+begin
+ Result := fName;
+ if (PathDelim = '/') then
+ Exit;
+
+ for I := 1 to Length(Result) do
+ begin
+ if (Result[I] = PathDelim) then
+ Result[I] := '/';
+ end;
+end;
+
+function TPathImpl.ToUTF8(UseNativeDelim: boolean): UTF8String;
+begin
+ AssertRefCount;
+
+ if (UseNativeDelim) then
+ Result := fName
+ else
+ Result := GetPortableString();
+end;
+
+function TPathImpl.ToWide(UseNativeDelim: boolean): WideString;
+begin
+ if (UseNativeDelim) then
+ Result := UTF8Decode(fName)
+ else
+ Result := UTF8Decode(GetPortableString());
+end;
+
+function TPathImpl.ToNative(): RawByteString;
+begin
+ if (IsNativeUTF8()) then
+ Result := fName
+ else
+ Result := Utf8ToAnsi(fName);
+end;
+
+function TPathImpl.GetDrive(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExtractFileDrive(Self);
+end;
+
+function TPathImpl.GetPath(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExtractFilePath(Self);
+end;
+
+function TPathImpl.GetDir(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExtractFileDir(Self);
+end;
+
+function TPathImpl.GetName(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExtractFileName(Self);
+end;
+
+function TPathImpl.GetExtension(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExtractFileExt(Self);
+end;
+
+function TPathImpl.SetExtension(const Extension: IPath): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ChangeFileExt(Self, Extension);
+end;
+
+function TPathImpl.SetExtension(const Extension: RawByteString): IPath;
+begin
+ Result := SetExtension(Path(Extension));
+end;
+
+function TPathImpl.SetExtension(const Extension: WideString): IPath;
+begin
+ Result := SetExtension(Path(Extension));
+end;
+
+function TPathImpl.GetRelativePath(const BaseName: IPath): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExtractRelativePath(BaseName, Self);
+end;
+
+function TPathImpl.GetAbsolutePath(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExpandFileName(Self);
+end;
+
+function TPathImpl.GetParent(): IPath;
+var
+ CurPath, ParentPath: IPath;
+begin
+ AssertRefCount;
+
+ Result := PATH_NONE;
+
+ CurPath := Self.RemovePathDelim();
+ // check if current path has a parent (no further '/')
+ if (Pos(PathDelim, CurPath.ToUTF8()) = 0) then
+ Exit;
+
+ // set new path and check if it has changed to avoid endless loops
+ // e.g. with invalid paths like '/C:' (GetPath() uses ':' as delimiter too)
+ // on delphi/win32
+ ParentPath := CurPath.GetPath();
+ if (ParentPath.ToUTF8 = CurPath.ToUTF8) then
+ Exit;
+
+ Result := ParentPath;
+end;
+
+function TPathImpl.SplitDirs(): IPathDynArray;
+var
+ CurPath: IPath;
+ Components: array of IPath;
+ CurPathStr: UTF8String;
+ DelimPos: integer;
+ I: integer;
+begin
+ SetLength(Result, 0);
+
+ if (Length(Self.ToUTF8(true)) = 0) then
+ Exit;
+
+ CurPath := Self;
+ SetLength(Components, 0);
+ repeat
+ SetLength(Components, Length(Components)+1);
+
+ CurPathStr := CurPath.ToUTF8();
+ DelimPos := LastDelimiter(PathDelim, SysUtils.ExcludeTrailingPathDelimiter(CurPathStr));
+ Components[High(Components)] := Path(Copy(CurPathStr, DelimPos+1, Length(CurPathStr)));
+
+ CurPath := CurPath.GetParent();
+ until (CurPath = PATH_NONE);
+
+ // reverse list
+ SetLength(Result, Length(Components));
+ for I := 0 to High(Components) do
+ Result[I] := Components[High(Components)-I];
+end;
+
+function TPathImpl.Append(const Child: IPath; DelimOption: TPathDelimOption): IPath;
+var
+ TmpResult: IPath;
+begin
+ AssertRefCount;
+
+ if (fName = '') then
+ TmpResult := Child
+ else
+ TmpResult := Path(Self.AppendPathDelim().ToUTF8() + Child.ToUTF8());
+
+ case DelimOption of
+ pdKeep: Result := TmpResult;
+ pdAppend: Result := TmpResult.AppendPathDelim;
+ pdRemove: Result := TmpResult.RemovePathDelim;
+ end;
+end;
+
+function TPathImpl.Append(const Child: RawByteString; DelimOption: TPathDelimOption): IPath;
+begin
+ AssertRefCount;
+ Result := Append(Path(Child), DelimOption);
+end;
+
+function TPathImpl.Append(const Child: WideString; DelimOption: TPathDelimOption): IPath;
+begin
+ AssertRefCount;
+ Result := Append(Path(Child), DelimOption);
+end;
+
+function TPathImpl.Equals(const Other: IPath; IgnoreCase: boolean): boolean;
+var
+ SelfPath, OtherPath: UTF8String;
+begin
+ SelfPath := Self.GetAbsolutePath().RemovePathDelim().ToUTF8();
+ OtherPath := Other.GetAbsolutePath().RemovePathDelim().ToUTF8();
+ if (FileSystem.IsCaseSensitive() and not IgnoreCase) then
+ Result := (CompareStr(SelfPath, OtherPath) = 0)
+ else
+ Result := (CompareText(SelfPath, OtherPath) = 0);
+end;
+
+function TPathImpl.Equals(const Other: RawByteString; IgnoreCase: boolean): boolean;
+begin
+ Result := Equals(Path(Other), IgnoreCase);
+end;
+
+function TPathImpl.Equals(const Other: WideString; IgnoreCase: boolean): boolean;
+begin
+ Result := Equals(Path(Other), IgnoreCase);
+end;
+
+function TPathImpl.IsChildOf(const Parent: IPath; Direct: boolean): boolean;
+var
+ SelfPath, ParentPath: UTF8String;
+begin
+ Result := false;
+
+ if (Direct) then
+ begin
+ SelfPath := Self.GetParent().GetAbsolutePath().AppendPathDelim().ToUTF8();
+ ParentPath := Parent.GetAbsolutePath().AppendPathDelim().ToUTF8();
+
+ // simply check if this paths parent path (SelfPath) equals ParentPath
+ Result := (SelfPath = ParentPath);
+ end
+ else
+ begin
+ SelfPath := Self.GetAbsolutePath().AppendPathDelim().ToUTF8();
+ ParentPath := Parent.GetAbsolutePath().AppendPathDelim().ToUTF8();
+
+ if (Length(SelfPath) <= Length(ParentPath)) then
+ Exit;
+
+ // check if ParentPath is a substring of SelfPath
+ if (FileSystem.IsCaseSensitive()) then
+ Result := (StrLComp(PAnsiChar(SelfPath), PAnsiChar(ParentPath), Length(ParentPath)) = 0)
+ else
+ Result := (StrLIComp(PAnsiChar(SelfPath), PAnsiChar(ParentPath), Length(ParentPath)) = 0)
+ end;
+end;
+
+function AdjustCaseRecursive(CurPath: IPath; AdjustAllLevels: boolean): IPath;
+var
+ OldParent, AdjustedParent: IPath;
+ LocalName: IPath;
+ PathFound: IPath;
+ PathWithAdjParent: IPath;
+ SearchInfo: TFileInfo;
+ FileIter: IFileIterator;
+ Pattern: IPath;
+begin
+ // if case-sensitive path exists there is no need to adjust case
+ if (CurPath.Exists()) then
+ begin
+ Result := CurPath;
+ Exit;
+ end;
+
+ LocalName := CurPath.RemovePathDelim().GetName();
+
+ // try to adjust parent
+ OldParent := CurPath.GetParent();
+ if (OldParent <> PATH_NONE) then
+ begin
+ if (not AdjustAllLevels) then
+ begin
+ AdjustedParent := OldParent;
+ end
+ else
+ begin
+ AdjustedParent := AdjustCaseRecursive(OldParent, AdjustAllLevels);
+ if (AdjustedParent = nil) then
+ begin
+ // parent path was not found case-insensitive
+ Result := nil;
+ Exit;
+ end;
+
+ // check if the path with adjusted parent can be found now
+ PathWithAdjParent := AdjustedParent.Append(LocalName);
+ if (PathWithAdjParent.Exists()) then
+ begin
+ Result := PathWithAdjParent;
+ Exit;
+ end;
+ end;
+ Pattern := AdjustedParent.Append(Path('*'));
+ end
+ else // path has no parent
+ begin
+ // the top path can either be absolute or relative
+ if (CurPath.IsAbsolute) then
+ begin
+ // the only absolute directory at Unix without a parent is root ('/')
+ // and hence does not need to be adjusted
+ Result := CurPath;
+ Exit;
+ end;
+ // this is a relative path, search in the current working dir
+ AdjustedParent := nil;
+ Pattern := Path('*');
+ end;
+
+ // compare name with all files in the current directory case-insensitive
+ FileIter := FileSystem.FileFind(Pattern, faAnyFile);
+ while (FileIter.HasNext()) do
+ begin
+ SearchInfo := FileIter.Next();
+ PathFound := SearchInfo.Name;
+ if (CompareText(LocalName.ToUTF8, PathFound.ToUTF8) = 0) then
+ begin
+ if (AdjustedParent <> nil) then
+ Result := AdjustedParent.Append(PathFound)
+ else
+ Result := PathFound;
+ Exit;
+ end;
+ end;
+
+ // no matching file found
+ Result := nil;
+end;
+
+function TPathImpl.AdjustCase(AdjustAllLevels: boolean): IPath;
+begin
+ AssertRefCount;
+
+ Result := Self;
+
+ if (FileSystem.IsCaseSensitive) then
+ begin
+ Result := AdjustCaseRecursive(Self, AdjustAllLevels);
+ if (Result = nil) then
+ Result := Self;
+ end;
+end;
+
+function TPathImpl.AppendPathDelim(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.IncludeTrailingPathDelimiter(Self);
+end;
+
+function TPathImpl.RemovePathDelim(): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.ExcludeTrailingPathDelimiter(Self);
+end;
+
+function TPathImpl.CreateFile(): TFileHandle;
+begin
+ Result := FileSystem.FileCreate(Self);
+end;
+
+function TPathImpl.CreateDirectory(Force: boolean): boolean;
+begin
+ if (Force) then
+ Result := FileSystem.ForceDirectories(Self)
+ else
+ Result := FileSystem.DirectoryCreate(Self);
+end;
+
+function TPathImpl.Open(Mode: longword): TFileHandle;
+begin
+ Result := FileSystem.FileOpen(Self, Mode);
+end;
+
+function TPathImpl.GetFileAge(): integer;
+begin
+ Result := FileSystem.FileAge(Self);
+end;
+
+function TPathImpl.GetFileAge(out FileDateTime: TDateTime): boolean;
+begin
+ Result := FileSystem.FileAge(Self, FileDateTime);
+end;
+
+function TPathImpl.Exists(): boolean;
+begin
+ // note the different specifications of FileExists() on Win32 <> Unix
+ {$IFDEF MSWINDOWS}
+ Result := IsFile() or IsDirectory();
+ {$ELSE}
+ Result := FileSystem.FileExists(Self);
+ {$ENDIF}
+end;
+
+function TPathImpl.IsFile(): boolean;
+begin
+ // note the different specifications of FileExists() on Win32 <> Unix
+ {$IFDEF MSWINDOWS}
+ Result := FileSystem.FileExists(Self);
+ {$ELSE}
+ Result := Exists() and not IsDirectory();
+ {$ENDIF}
+end;
+
+function TPathImpl.IsDirectory(): boolean;
+begin
+ Result := FileSystem.DirectoryExists(Self);
+end;
+
+function TPathImpl.IsAbsolute(): boolean;
+begin
+ AssertRefCount;
+ Result := FileSystem.FileIsReadOnly(Self);
+end;
+
+function TPathImpl.GetAttr(): cardinal;
+begin
+ Result := FileSystem.FileGetAttr(Self);
+end;
+
+function TPathImpl.SetAttr(Attr: Integer): boolean;
+begin
+ Result := FileSystem.FileSetAttr(Self, Attr);
+end;
+
+function TPathImpl.IsReadOnly(): boolean;
+begin
+ Result := FileSystem.FileIsReadOnly(Self);
+end;
+
+function TPathImpl.SetReadOnly(ReadOnly: boolean): boolean;
+begin
+ Result := FileSystem.FileSetReadOnly(Self, ReadOnly);
+end;
+
+function TPathImpl.IsUnset(): boolean;
+begin
+ Result := (fName = '');
+end;
+
+function TPathImpl.IsSet(): boolean;
+begin
+ Result := (fName <> '');
+end;
+
+function TPathImpl.FileSearch(const DirList: IPath): IPath;
+begin
+ AssertRefCount;
+ Result := FileSystem.FileSearch(Self, DirList);
+end;
+
+function TPathImpl.Rename(const NewName: IPath): boolean;
+begin
+ Result := FileSystem.RenameFile(Self, NewName);
+end;
+
+function TPathImpl.DeleteFile(): boolean;
+begin
+ Result := FileSystem.DeleteFile(Self);
+end;
+
+function TPathImpl.DeleteEmptyDir(): boolean;
+begin
+ Result := FileSystem.RemoveDir(Self);
+end;
+
+function TPathImpl.CopyFile(const Target: IPath; FailIfExists: boolean): boolean;
+begin
+ Result := FileSystem.CopyFile(Self, Target, FailIfExists);
+end;
+
+function TPathImpl.GetIntern(): UTF8String;
+begin
+ Result := fName;
+end;
+
+
+{ TBinaryFileStream }
+
+constructor TBinaryFileStream.Create(const FileName: IPath; Mode: word);
+begin
+{$IFDEF MSWINDOWS}
+ inherited Create(FileName.ToWide(), Mode);
+{$ELSE}
+ inherited Create(FileName.ToNative(), Mode);
+{$ENDIF}
+end;
+
+{ TTextStream }
+
+constructor TTextFileStream.Create(Filename: IPath; Mode: word);
+begin
+ inherited Create();
+ fMode := Mode;
+ fFilename := Filename;
+ fLineBreak := sLineBreak;
+end;
+
+function TTextFileStream.ReadLine(var Line: UTF8String): boolean;
+begin
+ Line := ReadLine(Result);
+end;
+
+function TTextFileStream.ReadLine(var Line: AnsiString): boolean;
+begin
+ Line := ReadLine(Result);
+end;
+
+procedure TTextFileStream.WriteString(const Str: RawByteString);
+begin
+ WriteBuffer(Str[1], Length(Str));
+end;
+
+procedure TTextFileStream.WriteLine(const Line: RawByteString);
+begin
+ WriteBuffer(Line[1], Length(Line));
+ WriteBuffer(fLineBreak[1], Length(fLineBreak));
+end;
+
+{ TMemTextStream }
+
+constructor TMemTextFileStream.Create(Filename: IPath; Mode: word);
+var
+ FileStream: TBinaryFileStream;
+begin
+ inherited Create(Filename, Mode);
+
+ fStream := TMemoryStream.Create();
+
+ // load data to memory in read mode
+ if ((Mode and 3) in [fmOpenRead, fmOpenReadWrite]) then
+ begin
+ FileStream := TBinaryFileStream.Create(Filename, fmOpenRead);
+ try
+ fStream.LoadFromStream(FileStream);
+ finally
+ FileStream.Free;
+ end;
+ end
+ // check if file exists for write-mode
+ else if ((Mode and 3) = fmOpenWrite) and (not Filename.IsFile) then
+ begin
+ raise EFOpenError.CreateResFmt(@SFOpenError,
+ [FileName.GetAbsolutePath.ToNative]);
+ end;
+end;
+
+destructor TMemTextFileStream.Destroy();
+var
+ FileStream: TBinaryFileStream;
+ SaveMode: word;
+begin
+ // save changes in write mode (= not read-only mode)
+ if ((fMode and 3) <> fmOpenRead) then
+ begin
+ if (fMode = fmCreate) then
+ SaveMode := fmCreate
+ else
+ SaveMode := fmOpenWrite;
+ FileStream := TBinaryFileStream.Create(fFilename, SaveMode);
+ try
+ fStream.SaveToStream(FileStream);
+ finally
+ FileStream.Free;
+ end;
+ end;
+
+ fStream.Free;
+ inherited;
+end;
+
+function TMemTextFileStream.GetSize: int64;
+begin
+ Result := fStream.Size;
+end;
+
+function TMemTextFileStream.Read(var Buffer; Count: longint): longint;
+begin
+ Result := fStream.Read(Buffer, Count);
+end;
+
+function TMemTextFileStream.Write(const Buffer; Count: longint): longint;
+begin
+ Result := fStream.Write(Buffer, Count);
+end;
+
+function TMemTextFileStream.Seek(Offset: longint; Origin: word): longint;
+begin
+ Result := fStream.Seek(Offset, Origin);
+end;
+
+function TMemTextFileStream.Seek(const Offset: int64; Origin: TSeekOrigin): int64;
+begin
+ Result := fStream.Seek(Offset, Origin);
+end;
+
+function TMemTextFileStream.CopyMemString(StartPos: int64; EndPos: int64): RawByteString;
+var
+ LineLength: cardinal;
+ Temp: RawByteString;
+begin
+ LineLength := EndPos - StartPos;
+ if (LineLength > 0) then
+ begin
+ // set string length to line-length (+ zero-terminator)
+ SetLength(Temp, LineLength);
+ StrLCopy(PAnsiChar(Temp),
+ @PAnsiChar(fStream.Memory)[StartPos],
+ LineLength);
+ Result := Temp;
+ end
+ else
+ begin
+ Result := '';
+ end;
+end;
+
+function TMemTextFileStream.ReadString(): RawByteString;
+var
+ TextPtr: PAnsiChar;
+ CurPos, StartPos, FileSize: int64;
+begin
+ TextPtr := PAnsiChar(fStream.Memory);
+ CurPos := Position;
+ FileSize := Size;
+ StartPos := -1;
+
+ while (CurPos < FileSize) do
+ begin
+ // check for whitespace (tab, lf, cr, space)
+ if (TextPtr[CurPos] in [#9, #10, #13, ' ']) then
+ begin
+ // check if we are at the end of a string
+ if (StartPos > -1) then
+ Break;
+ end
+ else if (StartPos = -1) then // start of string found
+ begin
+ StartPos := CurPos;
+ end;
+ Inc(CurPos);
+ end;
+
+ if (StartPos = -1) then
+ Result := ''
+ else
+ begin
+ Result := CopyMemString(StartPos, CurPos);
+ fStream.Position := CurPos;
+ end;
+end;
+
+{*
+ * Implementation of ReadLine(). We need separate versions for UTF8String
+ * and AnsiString as "var" parameter types have to fit exactly.
+ * To avoid a var-parameter here, the internal version the Line parameter is
+ * used as return value.
+ *}
+function TMemTextFileStream.ReadLine(var Success: boolean): RawByteString;
+var
+ TextPtr: PAnsiChar;
+ CurPos, FileSize: int64;
+begin
+ TextPtr := PAnsiChar(fStream.Memory);
+ CurPos := fStream.Position;
+ FileSize := Size;
+
+ // check for EOF
+ if (CurPos >= FileSize) then
+ begin
+ Result := '';
+ Success := false;
+ Exit;
+ end;
+
+ Success := true;
+
+ while (CurPos < FileSize) do
+ begin
+ if (TextPtr[CurPos] in [#10, #13]) then
+ begin
+ // copy text line
+ Result := CopyMemString(fStream.Position, CurPos);
+
+ // handle windows style #13#10 (\r\n) newlines
+ if (TextPtr[CurPos] = #13) and
+ (CurPos+1 < FileSize) and
+ (TextPtr[CurPos+1] = #10) then
+ begin
+ Inc(CurPos);
+ end;
+
+ // update stream pos
+ fStream.Position := CurPos+1;
+
+ Exit;
+ end;
+ Inc(CurPos);
+ end;
+
+ Result := CopyMemString(fStream.Position, CurPos);
+ fStream.Position := FileSize;
+end;
+
+{ TUnicodeMemoryStream }
+
+procedure TUnicodeMemoryStream.LoadFromFile(const FileName: IPath);
+var
+ Stream: TStream;
+begin
+ Stream := TBinaryFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
+ try
+ LoadFromStream(Stream);
+ finally
+ Stream.Free;
+ end;
+end;
+
+procedure TUnicodeMemoryStream.SaveToFile(const FileName: IPath);
+var
+ Stream: TStream;
+begin
+ Stream := TBinaryFileStream.Create(FileName, fmCreate);
+ try
+ SaveToStream(Stream);
+ finally
+ Stream.Free;
+ end;
+end;
+
+{ TUnicodeMemIniFile }
+
+constructor TUnicodeMemIniFile.Create(const FileName: IPath; UTF8Encoded: boolean);
+var
+ List: TStringList;
+ Stream: TBinaryFileStream;
+ BOMBuf: array[0..2] of AnsiChar;
+begin
+ inherited Create('');
+ FFilename := FileName;
+ FUTF8Encoded := UTF8Encoded;
+
+ if FileName.Exists() then
+ begin
+ List := nil;
+ Stream := nil;
+ try
+ List := TStringList.Create;
+ Stream := TBinaryFileStream.Create(FileName, fmOpenRead);
+ if (Stream.Read(BOMBuf[0], SizeOf(BOMBuf)) = 3) and
+ (CompareMem(PChar(UTF8_BOM), @BomBuf, Length(UTF8_BOM))) then
+ begin
+ // truncate BOM
+ FUTF8Encoded := true;
+ end
+ else
+ begin
+ // rewind file
+ Stream.Seek(0, soBeginning);
+ end;
+ List.LoadFromStream(Stream);
+ SetStrings(List);
+ finally
+ Stream.Free;
+ List.Free;
+ end;
+ end;
+end;
+
+procedure TUnicodeMemIniFile.UpdateFile;
+var
+ List: TStringList;
+ Stream: TBinaryFileStream;
+begin
+ List := nil;
+ Stream := nil;
+ try
+ List := TStringList.Create;
+ GetStrings(List);
+ Stream := TBinaryFileStream.Create(FFileName, fmCreate);
+ if UTF8Encoded then
+ Stream.Write(UTF8_BOM, Length(UTF8_BOM));
+ List.SaveToStream(Stream);
+ finally
+ List.Free;
+ Stream.Free;
+ end;
+end;
+
+
+var
+ PATH_NONE_Singelton: IPath;
+
+function PATH_NONE(): IPath;
+begin
+ Result := PATH_NONE_Singelton;
+end;
+
+initialization
+ {$IFDEF HAVE_REFCNTBUG}
+ GarbageList := TInterfaceList.Create();
+ GarbageList.Capacity := GarbageMaxCount;
+ {$ENDIF}
+ PATH_NONE_Singelton := Path('');
+
+finalization
+ PATH_NONE_Singelton := nil;
+
+end.
diff --git a/cmake/src/base/UPathUtils.pas b/cmake/src/base/UPathUtils.pas new file mode 100644 index 00000000..c2bcdd4b --- /dev/null +++ b/cmake/src/base/UPathUtils.pas @@ -0,0 +1,196 @@ +{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +unit UPathUtils; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + SysUtils, + Classes, + UPath; + +var + // Absolute Paths + GamePath: IPath; + SoundPath: IPath; + SongPaths: IInterfaceList; + LogPath: IPath; + ThemePath: IPath; + SkinsPath: IPath; + ScreenshotsPath: IPath; + CoverPaths: IInterfaceList; + LanguagesPath: IPath; + PluginPath: IPath; + VisualsPath: IPath; + FontPath: IPath; + ResourcesPath: IPath; + PlaylistPath: IPath; + +function FindPath(out PathResult: IPath; const RequestedPath: IPath; NeedsWritePermission: boolean): boolean; +procedure InitializePaths; +procedure AddSongPath(const Path: IPath); + +implementation + +uses + StrUtils, + UPlatform, + UCommandLine, + ULog; + +procedure AddSpecialPath(var PathList: IInterfaceList; const Path: IPath); +var + Index: integer; + PathAbs, PathTmp: IPath; + OldPath, OldPathAbs, OldPathTmp: IPath; +begin + if (PathList = nil) then + PathList := TInterfaceList.Create; + + if Path.Equals(PATH_NONE) or not Path.CreateDirectory(true) then + Exit; + + PathTmp := Path.GetAbsolutePath(); + PathAbs := PathTmp.AppendPathDelim(); + + // check if path or a part of the path was already added + for Index := 0 to PathList.Count-1 do + begin + OldPath := PathList[Index] as IPath; + OldPathTmp := OldPath.GetAbsolutePath(); + OldPathAbs := OldPathTmp.AppendPathDelim(); + + // check if the new directory is a sub-directory of a previously added one. + // This is also true, if both paths point to the same directories. + if (OldPathAbs.IsChildOf(PathAbs, false) or OldPathAbs.Equals(PathAbs)) then + begin + // ignore the new path + Exit; + end; + + // check if a previously added directory is a sub-directory of the new one. + if (PathAbs.IsChildOf(OldPathAbs, false)) then + begin + // replace the old with the new one. + PathList[Index] := PathAbs; + Exit; + end; + end; + + PathList.Add(PathAbs); +end; + +procedure AddSongPath(const Path: IPath); +begin + AddSpecialPath(SongPaths, Path); +end; + +procedure AddCoverPath(const Path: IPath); +begin + AddSpecialPath(CoverPaths, Path); +end; + +(** + * Initialize a path variable + * After setting paths, make sure that paths exist + *) +function FindPath( + out PathResult: IPath; + const RequestedPath: IPath; + NeedsWritePermission: boolean): boolean; +begin + Result := false; + + if (RequestedPath.Equals(PATH_NONE)) then + Exit; + + // Make sure the directory exists + if (not RequestedPath.CreateDirectory(true)) then + begin + PathResult := PATH_NONE; + Exit; + end; + + PathResult := RequestedPath.AppendPathDelim(); + + if (NeedsWritePermission) and RequestedPath.IsReadOnly() then + Exit; + + Result := true; +end; + +(** + * Function sets all absolute paths e.g. song path and makes sure the directorys exist + *) +procedure InitializePaths; +var + SharedPath, UserPath: IPath; +begin + // Log directory (must be writable) + if (not FindPath(LogPath, Platform.GetLogPath, true)) then + begin + Log.FileOutputEnabled := false; + Log.LogWarn('Log directory "'+ Platform.GetLogPath.ToNative +'" not available', 'InitializePaths'); + end; + + SharedPath := Platform.GetGameSharedPath; + UserPath := Platform.GetGameUserPath; + + FindPath(SoundPath, SharedPath.Append('sounds'), false); + FindPath(ThemePath, SharedPath.Append('themes'), false); + FindPath(SkinsPath, SharedPath.Append('themes'), false); + FindPath(LanguagesPath, SharedPath.Append('languages'), false); + FindPath(PluginPath, SharedPath.Append('plugins'), false); + FindPath(VisualsPath, SharedPath.Append('visuals'), false); + FindPath(FontPath, SharedPath.Append('fonts'), false); + FindPath(ResourcesPath, SharedPath.Append('resources'), false); + + // Playlists are not shared as we need one directory to write too + FindPath(PlaylistPath, UserPath.Append('playlists'), true); + + // Screenshot directory (must be writable) + if (not FindPath(ScreenshotsPath, UserPath.Append('screenshots'), true)) then + begin + Log.LogWarn('Screenshot directory "'+ UserPath.ToNative +'" not available', 'InitializePaths'); + end; + + // Add song paths + AddSongPath(Params.SongPath); + AddSongPath(SharedPath.Append('songs')); + AddSongPath(UserPath.Append('songs')); + + // Add category cover paths + AddCoverPath(SharedPath.Append('covers')); + AddCoverPath(UserPath.Append('covers')); +end; + +end. diff --git a/cmake/src/base/UPlatform.pas b/cmake/src/base/UPlatform.pas index 6f13481c..11c67fa7 100644 --- a/cmake/src/base/UPlatform.pas +++ b/cmake/src/base/UPlatform.pas @@ -39,28 +39,20 @@ interface {$I switches.inc} uses - Classes; + Classes, + UPath; type - TDirectoryEntry = record - Name: WideString; - IsDirectory: boolean; - IsFile: boolean; - end; - - TDirectoryEntryArray = array of TDirectoryEntry; - TPlatform = class - function GetExecutionDir(): string; + function GetExecutionDir(): IPath; procedure Init; virtual; - function DirectoryFindFiles(Dir, Filter: WideString; ReturnAllSubDirs: boolean): TDirectoryEntryArray; virtual; abstract; + function TerminateIfAlreadyRunning(var WndTitle: string): boolean; virtual; - function FindSongFile(Dir, Mask: WideString): WideString; virtual; procedure Halt; virtual; - function GetLogPath: WideString; virtual; abstract; - function GetGameSharedPath: WideString; virtual; abstract; - function GetGameUserPath: WideString; virtual; abstract; - function CopyFile(const Source, Target: WideString; FailIfExists: boolean): boolean; virtual; + + function GetLogPath: IPath; virtual; abstract; + function GetGameSharedPath: IPath; virtual; abstract; + function GetGameUserPath: IPath; virtual; abstract; end; function Platform(): TPlatform; @@ -76,7 +68,9 @@ uses {$ELSEIF Defined(UNIX)} UPlatformLinux, {$IFEND} - ULog; + ULog, + UUnicodeUtils, + UFilesystem; // I modified it to use the Platform_singleton in this location (in the implementation) @@ -109,9 +103,13 @@ end; {** * Returns the directory of the executable *} -function TPlatform.GetExecutionDir(): string; +function TPlatform.GetExecutionDir(): IPath; +var + ExecName, ExecDir: IPath; begin - Result := ExpandFileName(ExtractFilePath(ParamStr(0))); + ExecName := Path(ParamStr(0)); + ExecDir := ExecName.GetPath; + Result := ExecDir.GetAbsolutePath(); end; (** @@ -122,65 +120,6 @@ begin Result := false; end; -(** - * Default FindSongFile() implementation - *) -function TPlatform.FindSongFile(Dir, Mask: WideString): WideString; -var - SR: TSearchRec; // for parsing song directory -begin - Result := ''; - if SysUtils.FindFirst(Dir + Mask, faDirectory, SR) = 0 then - begin - Result := SR.Name; - end; - SysUtils.FindClose(SR); -end; - -function TPlatform.CopyFile(const Source, Target: WideString; FailIfExists: boolean): boolean; -const - COPY_BUFFER_SIZE = 4096; // a good tradeoff between speed and memory consumption -var - SourceFile, TargetFile: TFileStream; - FileCopyBuffer: array [0..COPY_BUFFER_SIZE-1] of byte; // temporary copy-buffer. - NumberOfBytes: integer; // number of bytes read from SourceFile -begin - Result := false; - SourceFile := nil; - TargetFile := nil; - - // if overwrite is disabled return if the target file already exists - if (FailIfExists and FileExists(Target)) then - Exit; - - try - try - // open source and target file (might throw an exception on error) - SourceFile := TFileStream.Create(Source, fmOpenRead); - TargetFile := TFileStream.Create(Target, fmCreate or fmOpenWrite); - - while true do - begin - // read a block from the source file and check for errors or EOF - NumberOfBytes := SourceFile.Read(FileCopyBuffer, SizeOf(FileCopyBuffer)); - if (NumberOfBytes <= 0) then - Break; - // write block to target file and check if everything was written - if (TargetFile.Write(FileCopyBuffer, NumberOfBytes) <> NumberOfBytes) then - Exit; - end; - except - Exit; - end; - finally - SourceFile.Free; - TargetFile.Free; - end; - - Result := true; -end; - - initialization {$IF Defined(MSWINDOWS)} Platform_singleton := TPlatformWindows.Create; diff --git a/cmake/src/base/UPlatformLinux.pas b/cmake/src/base/UPlatformLinux.pas index 30499a97..693facaa 100644 --- a/cmake/src/base/UPlatformLinux.pas +++ b/cmake/src/base/UPlatformLinux.pas @@ -36,7 +36,8 @@ interface uses Classes, UPlatform, - UConfig; + UConfig, + UPath; type TPlatformLinux = class(TPlatform) @@ -44,15 +45,13 @@ type UseLocalDirs: boolean; procedure DetectLocalExecution(); - function GetHomeDir(): string; + function GetHomeDir(): IPath; public procedure Init; override; - - function DirectoryFindFiles(Dir, Filter: WideString; ReturnAllSubDirs: Boolean): TDirectoryEntryArray; override; - - function GetLogPath : WideString; override; - function GetGameSharedPath : WideString; override; - function GetGameUserPath : WideString; override; + + function GetLogPath : IPath; override; + function GetGameSharedPath : IPath; override; + function GetGameUserPath : IPath; override; end; implementation @@ -60,9 +59,7 @@ implementation uses UCommandLine, BaseUnix, - {$IF FPC_VERSION_INT >= 2002002} pwd, - {$IFEND} SysUtils, ULog; @@ -88,114 +85,65 @@ end; *} procedure TPlatformLinux.DetectLocalExecution(); var - LocalDir: string; + LocalDir, LanguageDir: IPath; begin - LocalDir := GetExecutionDir(); - // we just check if the 'languages' folder exists in the // directory of the executable. If so -> local execution. - UseLocalDirs := (DirectoryExists(LocalDir + 'languages')); -end; - -function TPlatformLinux.DirectoryFindFiles(Dir, Filter: WideString; ReturnAllSubDirs: Boolean): TDirectoryEntryArray; -var - i: Integer; - TheDir : pDir; - ADirent : pDirent; - Entry : Longint; - lAttrib : integer; -begin - i := 0; - Filter := LowerCase(Filter); - - TheDir := FpOpenDir( Dir ); - if Assigned(TheDir) then - begin - repeat - ADirent := FpReadDir(TheDir^); - - if Assigned(ADirent) and (ADirent^.d_name <> '.') and (ADirent^.d_name <> '..') then - begin - lAttrib := FileGetAttr(Dir + ADirent^.d_name); - if ReturnAllSubDirs and ((lAttrib and faDirectory) <> 0) then - begin - SetLength( Result, i + 1); - Result[i].Name := ADirent^.d_name; - Result[i].IsDirectory := true; - Result[i].IsFile := false; - i := i + 1; - end - else if (Length(Filter) = 0) or (Pos( Filter, LowerCase(ADirent^.d_name)) > 0) then - begin - SetLength( Result, i + 1); - Result[i].Name := ADirent^.d_name; - Result[i].IsDirectory := false; - Result[i].IsFile := true; - i := i + 1; - end; - end; - until (ADirent = nil); - - FpCloseDir(TheDir^); - end; + LocalDir := GetExecutionDir(); + LanguageDir := LocalDir.Append('languages'); + UseLocalDirs := LanguageDir.IsDirectory; end; -function TPlatformLinux.GetLogPath: WideString; +function TPlatformLinux.GetLogPath: IPath; begin if UseLocalDirs then Result := GetExecutionDir() else - Result := GetGameUserPath() + 'logs/'; + Result := GetGameUserPath().Append('logs', pdAppend); // create non-existing directories - ForceDirectories(Result); + Result.CreateDirectory(true); end; -function TPlatformLinux.GetGameSharedPath: WideString; +function TPlatformLinux.GetGameSharedPath: IPath; begin if UseLocalDirs then Result := GetExecutionDir() else - Result := IncludeTrailingPathDelimiter(INSTALL_DATADIR); + Result := Path(INSTALL_DATADIR, pdAppend); end; -function TPlatformLinux.GetGameUserPath: WideString; +function TPlatformLinux.GetGameUserPath: IPath; begin if UseLocalDirs then Result := GetExecutionDir() else - Result := GetHomeDir() + '.ultrastardx/'; + Result := GetHomeDir().Append('.ultrastardx', pdAppend); end; {** * Returns the user's home directory terminated by a path delimiter *} -function TPlatformLinux.GetHomeDir(): string; -{$IF FPC_VERSION_INT >= 2002002} +function TPlatformLinux.GetHomeDir(): IPath; var PasswdEntry: PPasswd; -{$IFEND} begin - Result := ''; + Result := PATH_NONE; - {$IF FPC_VERSION_INT >= 2002002} // try to retrieve the info from passwd PasswdEntry := FpGetpwuid(FpGetuid()); if (PasswdEntry <> nil) then - Result := PasswdEntry.pw_dir; - {$IFEND} + Result := Path(PasswdEntry.pw_dir); // fallback if passwd does not contain the path - if (Result = '') then - Result := GetEnvironmentVariable('HOME'); + if (Result.IsUnset) then + Result := Path(GetEnvironmentVariable('HOME')); // add trailing path delimiter (normally '/') - if (Result <> '') then - Result := IncludeTrailingPathDelimiter(Result); + if (Result.IsSet) then + Result := Result.AppendPathDelim(); - {$IF FPC_VERSION_INT >= 2002002} // GetUserDir() is another function that returns a user path. // It uses env-var HOME or a fallback to a temp-dir. //Result := GetUserDir(); - {$IFEND} end; end. diff --git a/cmake/src/base/UPlatformMacOSX.pas b/cmake/src/base/UPlatformMacOSX.pas index 96e4bc63..d55e8bea 100644 --- a/cmake/src/base/UPlatformMacOSX.pas +++ b/cmake/src/base/UPlatformMacOSX.pas @@ -36,7 +36,9 @@ interface uses Classes, ULog, - UPlatform; + UPlatform, + UFilesystem, + UPath; type {** @@ -93,19 +95,21 @@ type * GetBundlePath returns the path to the application bundle * UltraStarDeluxe.app. *} - function GetBundlePath: WideString; + function GetBundlePath: IPath; {** * GetApplicationSupportPath returns the path to * $HOME/Library/Application Support/UltraStarDeluxe. *} - function GetApplicationSupportPath: WideString; + function GetApplicationSupportPath: IPath; {** * see the description of @link(Init). *} procedure CreateUserFolders(); + function GetHomeDir(): IPath; + public {** * Init simply calls @link(CreateUserFolders), which in turn scans the @@ -116,37 +120,30 @@ type procedure Init; override; {** - * DirectoryFindFiles returns all entries of a folder with names and - * booleans about their type, i.e. file or directory. - *} - function DirectoryFindFiles(Dir, Filter: WideString; ReturnAllSubDirs: boolean): TDirectoryEntryArray; override; - - {** * GetLogPath returns the path for log messages. Currently it is set to - * $HOME/Library/Application Support/UltraStarDeluxe/Log. + * $HOME/Library/Application Support/UltraStarDeluxe/log. *} - function GetLogPath : WideString; override; + function GetLogPath: IPath; override; {** * GetGameSharedPath returns the path for shared resources. Currently it * is set to /Library/Application Support/UltraStarDeluxe. * However it is not used. *} - function GetGameSharedPath : WideString; override; + function GetGameSharedPath: IPath; override; {** * GetGameUserPath returns the path for user resources. Currently it is * set to $HOME/Library/Application Support/UltraStarDeluxe. * This is where a user can add songs, themes, .... *} - function GetGameUserPath : WideString; override; + function GetGameUserPath: IPath; override; end; implementation uses - SysUtils, - BaseUnix; + SysUtils; procedure TPlatformMacOSX.Init; begin @@ -154,178 +151,131 @@ begin end; procedure TPlatformMacOSX.CreateUserFolders(); -const - // used to construct the @link(UserPathName) - PathName: string = '/Library/Application Support/UltraStarDeluxe'; var - RelativePath: string; + RelativePath: IPath; // BaseDir contains the path to the folder, where a search is performed. // It is set to the entries in @link(DirectoryList) one after the other. - BaseDir: string; + BaseDir: IPath; // OldBaseDir contains the path to the folder, where the search started. // It is used to return to it, when the search is completed in all folders. - OldBaseDir: string; - // This record contains the result of a file search with FindFirst or FindNext - SearchInfo: TSearchRec; + OldBaseDir: IPath; + Iter: IFileIterator; + FileInfo: TFileInfo; + CurPath: IPath; // These two lists contain all folder and file names found // within the folder @link(BaseDir). - DirectoryList, FileList: TStringList; + DirectoryList, FileList: IInterfaceList; // DirectoryIsFinished contains the index of the folder in @link(DirectoryList), // which is the last one completely searched. Later folders are still to be // searched for additional files and folders. DirectoryIsFinished: longint; - Counter: longint; + I: longint; // These three are for creating directories, due to possible symlinks CreatedDirectory: boolean; FileAttrs: integer; - DirectoryPath: string; - - UserPathName: string; + DirectoryPath: IPath; + UserPath: IPath; + SrcFile, TgtFile: IPath; begin // Get the current folder and save it in OldBaseDir for returning to it, when // finished. - GetDir(0, OldBaseDir); + OldBaseDir := FileSystem.GetCurrentDir(); - // UltraStarDeluxe.app/Contents contains all the default files and - // folders. - BaseDir := OldBaseDir + '/UltraStarDeluxe.app/Contents'; - ChDir(BaseDir); + // UltraStarDeluxe.app/Contents contains all the default files and folders. + BaseDir := OldBaseDir.Append('UltraStarDeluxe.app/Contents'); + FileSystem.SetCurrentDir(BaseDir); - // Right now, only $HOME/Library/Application Support/UltraStarDeluxe - // is used. - UserPathName := GetEnvironmentVariable('HOME') + PathName; + // Right now, only $HOME/Library/Application Support/UltraStarDeluxe is used. + UserPath := GetGameUserPath(); DirectoryIsFinished := 0; - DirectoryList := TStringList.Create(); - FileList := TStringList.Create(); - DirectoryList.Add('.'); + // replace with IInterfaceList + DirectoryList := TInterfaceList.Create(); + FileList := TInterfaceList.Create(); + DirectoryList.Add(Path('.')); // create the folder and file lists repeat - - RelativePath := DirectoryList[DirectoryIsFinished]; - ChDir(BaseDir + '/' + RelativePath); - if (FindFirst('*', faAnyFile, SearchInfo) = 0) then + RelativePath := (DirectoryList[DirectoryIsFinished] as IPath); + FileSystem.SetCurrentDir(BaseDir.Append(RelativePath)); + Iter := FileSystem.FileFind(Path('*'), faAnyFile); + while (Iter.HasNext) do begin - repeat - if DirectoryExists(SearchInfo.Name) then - begin - if (SearchInfo.Name <> '.') and (SearchInfo.Name <> '..') then - DirectoryList.Add(RelativePath + '/' + SearchInfo.Name); - end - else - Filelist.Add(RelativePath + '/' + SearchInfo.Name); - until (FindNext(SearchInfo) <> 0); + FileInfo := Iter.Next; + CurPath := FileInfo.Name; + if CurPath.IsDirectory() then + begin + if (not CurPath.Equals('.')) and + (not CurPath.Equals('..')) and + (not CurPath.Equals('MacOS')) then + DirectoryList.Add(RelativePath.Append(CurPath)); + end + else + Filelist.Add(RelativePath.Append(CurPath)); end; - FindClose(SearchInfo); Inc(DirectoryIsFinished); until (DirectoryIsFinished = DirectoryList.Count); // create missing folders - ForceDirectories(UserPathName); // should not be necessary since (UserPathName+'/.') is created. - for Counter := 0 to DirectoryList.Count-1 do + UserPath.CreateDirectory(true); // should not be necessary since (UserPathName+'/.') is created. + for I := 0 to DirectoryList.Count-1 do begin - DirectoryPath := UserPathName + '/' + DirectoryList[Counter]; - CreatedDirectory := ForceDirectories(DirectoryPath); - FileAttrs := FileGetAttr(DirectoryPath); - // Don't know how to analyse the target of the link. + CurPath := DirectoryList[I] as IPath; + DirectoryPath := UserPath.Append(CurPath); + CreatedDirectory := DirectoryPath.CreateDirectory(); + FileAttrs := DirectoryPath.GetAttr(); + // Maybe analyse the target of the link with FpReadlink(). // Let's assume the symlink is pointing to an existing directory. if (not CreatedDirectory) and (FileAttrs and faSymLink > 0) then - Log.LogError('Failed to create the folder "'+ UserPathName + '/' + DirectoryList[Counter] +'"', + Log.LogError('Failed to create the folder "'+ DirectoryPath.ToNative +'"', 'TPlatformMacOSX.CreateUserFolders'); end; - DirectoryList.Free(); // copy missing files - for Counter := 0 to Filelist.Count-1 do + for I := 0 to Filelist.Count-1 do begin - CopyFile(BaseDir + '/' + Filelist[Counter], - UserPathName + '/' + Filelist[Counter], true); + CurPath := Filelist[I] as IPath; + SrcFile := BaseDir.Append(CurPath); + TgtFile := UserPath.Append(CurPath); + SrcFile.CopyFile(TgtFile, true); end; - FileList.Free(); // go back to the initial folder - ChDir(OldBaseDir); + FileSystem.SetCurrentDir(OldBaseDir); end; -function TPlatformMacOSX.GetBundlePath: WideString; -var - i, pos : integer; +function TPlatformMacOSX.GetBundlePath: IPath; begin // Mac applications are packaged in folders. // Cutting the last two folders yields the application folder. - - Result := GetExecutionDir(); - for i := 1 to 2 do - begin - pos := Length(Result); - repeat - Delete(Result, pos, 1); - pos := Length(Result); - until (pos = 0) or (Result[pos] = '/'); - end; + Result := GetExecutionDir().GetParent().GetParent(); end; -function TPlatformMacOSX.GetApplicationSupportPath: WideString; +function TPlatformMacOSX.GetApplicationSupportPath: IPath; const - PathName : string = '/Library/Application Support/UltraStarDeluxe'; + PathName: string = 'Library/Application Support/UltraStarDeluxe'; begin - Result := GetEnvironmentVariable('HOME') + PathName + '/'; + Result := GetHomeDir().Append(PathName, pdAppend); end; -function TPlatformMacOSX.GetLogPath: WideString; +function TPlatformMacOSX.GetHomeDir(): IPath; begin - Result := GetApplicationSupportPath + 'Logs'; + Result := Path(GetEnvironmentVariable('HOME')); end; -function TPlatformMacOSX.GetGameSharedPath: WideString; +function TPlatformMacOSX.GetLogPath: IPath; begin - Result := GetApplicationSupportPath; + Result := GetApplicationSupportPath.Append('logs'); end; -function TPlatformMacOSX.GetGameUserPath: WideString; +function TPlatformMacOSX.GetGameSharedPath: IPath; begin Result := GetApplicationSupportPath; end; -function TPlatformMacOSX.DirectoryFindFiles(Dir, Filter: WideString; ReturnAllSubDirs: boolean): TDirectoryEntryArray; -var - i : integer; - TheDir : pdir; - ADirent : pDirent; - lAttrib : integer; +function TPlatformMacOSX.GetGameUserPath: IPath; begin - i := 0; - Filter := LowerCase(Filter); - - TheDir := FPOpenDir(Dir); - if Assigned(TheDir) then - repeat - ADirent := FPReadDir(TheDir); - - if Assigned(ADirent) and (ADirent^.d_name <> '.') and (ADirent^.d_name <> '..') then - begin - lAttrib := FileGetAttr(Dir + ADirent^.d_name); - if ReturnAllSubDirs and ((lAttrib and faDirectory) <> 0) then - begin - SetLength(Result, i + 1); - Result[i].Name := ADirent^.d_name; - Result[i].IsDirectory := true; - Result[i].IsFile := false; - i := i + 1; - end - else if (Length(Filter) = 0) or (Pos( Filter, LowerCase(ADirent^.d_name)) > 0) then - begin - SetLength(Result, i + 1); - Result[i].Name := ADirent^.d_name; - Result[i].IsDirectory := false; - Result[i].IsFile := true; - i := i + 1; - end; - end; - until ADirent = nil; - - FPCloseDir(TheDir); + Result := GetApplicationSupportPath; end; end. diff --git a/cmake/src/base/UPlatformWindows.pas b/cmake/src/base/UPlatformWindows.pas index e198958a..91d3cce6 100644 --- a/cmake/src/base/UPlatformWindows.pas +++ b/cmake/src/base/UPlatformWindows.pas @@ -38,21 +38,23 @@ interface uses Classes, - UPlatform; + UPlatform, + UPath; type TPlatformWindows = class(TPlatform) private - function GetSpecialPath(CSIDL: integer): WideString; + UseLocalDirs: boolean; + + function GetSpecialPath(CSIDL: integer): IPath; + procedure DetectLocalExecution(); public - function DirectoryFindFiles(Dir, Filter: WideString; ReturnAllSubDirs: Boolean): TDirectoryEntryArray; override; + procedure Init; override; function TerminateIfAlreadyRunning(var WndTitle: String): Boolean; override; - function GetLogPath: WideString; override; - function GetGameSharedPath: WideString; override; - function GetGameUserPath: WideString; override; - - function CopyFile(const Source, Target: WideString; FailIfExists: boolean): boolean; override; + function GetLogPath: IPath; override; + function GetGameSharedPath: IPath; override; + function GetGameUserPath: IPath; override; end; implementation @@ -63,93 +65,10 @@ uses Windows, UConfig; -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; forward; -function FindNextW(var F: TSearchRecW): Integer; forward; -procedure FindCloseW(var F: TSearchRecW); forward; -function FindMatchingFileW(var F: TSearchRecW): Integer; forward; -function DirectoryExistsW(const Directory: widestring): Boolean; forward; - -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; -{$IFDEF Delphi} - F.FindHandle := FindFirstFileW(PWideChar(Path), F.FindData); -{$ELSE} - F.FindHandle := FindFirstFileW(PWideChar(Path), @F.FindData); -{$ENDIF} - 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 -{$IFDEF Delphi} - if FindNextFileW(F.FindHandle, F.FindData) then -{$ELSE} - if FindNextFileW(F.FindHandle, @F.FindData) then -{$ENDIF} - 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 -{$IFDEF Delphi} - if not FindNextFileW(FindHandle, FindData) then -{$ELSE} - if not FindNextFileW(FindHandle, @FindData) then -{$ENDIF} - 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; +procedure TPlatformWindows.Init; begin - Code := GetFileAttributesW(PWideChar(Directory)); - Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); + inherited Init(); + DetectLocalExecution(); end; //------------------------------ @@ -180,41 +99,6 @@ begin end; end; -function TPlatformWindows.DirectoryFindFiles(Dir, Filter: WideString; ReturnAllSubDirs: Boolean): TDirectoryEntryArray; -var - i : Integer; - SR : TSearchRecW; - Attrib : Integer; -begin - i := 0; - Filter := LowerCase(Filter); - - if FindFirstW(Dir + '*', faAnyFile or faDirectory, SR) = 0 then - repeat - if (SR.Name <> '.') and (SR.Name <> '..') then - begin - Attrib := FileGetAttr(Dir + SR.name); - if ReturnAllSubDirs and ((Attrib and faDirectory) <> 0) then - begin - SetLength( Result, i + 1); - Result[i].Name := SR.name; - Result[i].IsDirectory := true; - Result[i].IsFile := false; - i := i + 1; - end - else if (Length(Filter) = 0) or (Pos( Filter, LowerCase(SR.Name)) > 0) then - begin - SetLength( Result, i + 1); - Result[i].Name := SR.Name; - Result[i].IsDirectory := false; - Result[i].IsFile := true; - i := i + 1; - end; - end; - until FindNextW(SR) <> 0; - FindCloseW(SR); -end; - (** * Returns the path of a special folder. * @@ -225,37 +109,101 @@ end; * CSIDL_PERSONAL (e.g. C:\Documents and Settings\username\My Documents) * CSIDL_MYMUSIC (e.g. C:\Documents and Settings\username\My Documents\My Music) *) -function TPlatformWindows.GetSpecialPath(CSIDL: integer): WideString; +function TPlatformWindows.GetSpecialPath(CSIDL: integer): IPath; var Buffer: array [0..MAX_PATH-1] of WideChar; begin -{$IF Defined(Delphi) or (FPC_VERSION_INT >= 2002002)} // >= 2.2.2 if (SHGetSpecialFolderPathW(0, @Buffer, CSIDL, false)) then - Result := Buffer + Result := Path(Buffer) else -{$IFEND} - Result := ''; + Result := PATH_NONE; end; -function TPlatformWindows.GetLogPath: WideString; +{** + * Detects whether the was executed locally or globally. + * - Local mode: + * - Condition: + * - config.ini is writable or creatable in the directory of the executable. + * - Examples: + * - The USDX zip-archive has been unpacked to a directory with write. + * permissions + * - XP: USDX was installed to %ProgramFiles% and the user is an admin. + * - USDX is started from an external HD- or flash-drive + * - Behavior: + * Config files like config.ini or score db reside in the directory of the + * executable. This is useful to enable windows users to have a portable + * installation e.g. on an external hdd. + * This is also the default behaviour of usdx prior to version 1.1 + * - Global mode: + * - Condition: + * - config.ini is not writable. + * - Examples: + * - Vista/7: USDX was installed to %ProgramFiles%. + * - XP: USDX was installed to %ProgramFiles% and the user is not an admin. + * - USDX is started from CD + * - Behavior: + * - The config files are in a separate folder (e.g. %APPDATA%\ultrastardx) + * + * On windows, resources (themes, language-files) + * reside in the directory of the executable in any case + * + * Sets UseLocalDirs to true if the game is executed locally, false otherwise. + *} +procedure TPlatformWindows.DetectLocalExecution(); +var + LocalDir, ConfigIni: IPath; + Handle: TFileHandle; begin - Result := GetExecutionDir(); + LocalDir := GetExecutionDir(); + ConfigIni := LocalDir.Append('config.ini'); + + // check if config.ini is writable or creatable, if so use local dirs + UseLocalDirs := false; + if (ConfigIni.Exists()) then + begin + // do not use a read-only config file + if (not ConfigIni.IsReadOnly()) then + begin + // Just open the file in read-write mode to be sure that we have access + // rights for it. + // Note: Do not use IsReadOnly() as it does not check file privileges, so + // a non-read-only file might not be writable for us. + Handle := ConfigIni.Open(fmOpenReadWrite); + if (Handle <> -1) then + begin + FileClose(Handle); + UseLocalDirs := true; + end; + end; + end + else // config.ini does not exist + begin + // try to create config.ini + Handle := ConfigIni.CreateFile(); + if (Handle <> -1) then + begin + FileClose(Handle); + UseLocalDirs := true; + end; + end; end; -function TPlatformWindows.GetGameSharedPath: WideString; +function TPlatformWindows.GetLogPath: IPath; begin - Result := GetExecutionDir(); + Result := GetGameUserPath; end; -function TPlatformWindows.GetGameUserPath: WideString; +function TPlatformWindows.GetGameSharedPath: IPath; begin - //Result := GetSpecialPath(CSIDL_APPDATA) + PathDelim + 'UltraStarDX' + PathDelim; Result := GetExecutionDir(); end; -function TPlatformWindows.CopyFile(const Source, Target: WideString; FailIfExists: boolean): boolean; +function TPlatformWindows.GetGameUserPath: IPath; begin - Result := Windows.CopyFileW(PWideChar(Source), PWideChar(Target), FailIfExists); + if UseLocalDirs then + Result := GetExecutionDir() + else + Result := GetSpecialPath(CSIDL_APPDATA).Append('ultrastardx', pdAppend); end; end. diff --git a/cmake/src/base/UPlaylist.pas b/cmake/src/base/UPlaylist.pas index 419ce687..f12e06cf 100644 --- a/cmake/src/base/UPlaylist.pas +++ b/cmake/src/base/UPlaylist.pas @@ -34,21 +34,23 @@ interface {$I switches.inc} uses + Classes, USong, - UPath; + UPath, + UPathUtils; type TPlaylistItem = record - Artist: String; - Title: String; + Artist: UTF8String; + Title: UTF8String; SongID: Integer; end; APlaylistItem = array of TPlaylistItem; TPlaylist = record - Name: String; - Filename: String; + Name: UTF8String; + Filename: IPath; Items: APlaylistItem; end; @@ -68,20 +70,20 @@ type Playlists: APlaylist; constructor Create; - Procedure LoadPlayLists; - Function LoadPlayList(Index: Cardinal; Filename: String): Boolean; - Procedure SavePlayList(Index: Cardinal); + procedure LoadPlayLists; + function LoadPlayList(Index: Cardinal; const Filename: IPath): Boolean; + procedure SavePlayList(Index: Cardinal); - Procedure SetPlayList(Index: Cardinal); + procedure SetPlayList(Index: Cardinal); - Function AddPlaylist(Name: String): Cardinal; - Procedure DelPlaylist(const Index: Cardinal); + function AddPlaylist(const Name: UTF8String): Cardinal; + procedure DelPlaylist(const Index: Cardinal); - Procedure AddItem(const SongID: Cardinal; const iPlaylist: Integer = -1); - Procedure DelItem(const iItem: Cardinal; const iPlaylist: Integer = -1); + procedure AddItem(const SongID: Cardinal; const iPlaylist: Integer = -1); + procedure DelItem(const iItem: Cardinal; const iPlaylist: Integer = -1); - Procedure GetNames(var PLNames: array of String); - Function GetIndexbySongID(const SongID: Cardinal; const iPlaylist: Integer = -1): Integer; + procedure GetNames(var PLNames: array of UTF8String); + function GetIndexbySongID(const SongID: Cardinal; const iPlaylist: Integer = -1): Integer; end; {Modes: @@ -95,13 +97,15 @@ type implementation -uses USongs, - ULog, - UMain, - //UFiles, - UGraphic, - UThemes, - SysUtils; +uses + SysUtils, + USongs, + ULog, + UMain, + UFilesystem, + UGraphic, + UThemes, + UUnicodeUtils; //---------- //Create - Construct Class - Dummy for now @@ -117,90 +121,90 @@ end; //---------- Procedure TPlayListManager.LoadPlayLists; var - SR: TSearchRec; Len: Integer; PlayListBuffer: TPlayList; + Iter: IFileIterator; + FileInfo: TFileInfo; begin SetLength(Playlists, 0); - if FindFirst(PlayListPath + '*.upl', 0, SR) = 0 then + Iter := FileSystem.FileFind(PlayListPath.Append('*.upl'), 0); + while (Iter.HasNext) do begin - repeat - Len := Length(Playlists); - SetLength(Playlists, Len +1); + Len := Length(Playlists); + SetLength(Playlists, Len + 1); + + FileInfo := Iter.Next; - if not LoadPlayList (Len, Sr.Name) then - SetLength(Playlists, Len) - else + if not LoadPlayList(Len, FileInfo.Name) then + SetLength(Playlists, Len) + else + begin + // Sort the Playlists - Insertion Sort + PlayListBuffer := Playlists[Len]; + Dec(Len); + while (Len >= 0) AND (CompareText(Playlists[Len].Name, PlayListBuffer.Name) >= 0) do begin - // Sort the Playlists - Insertion Sort - PlayListBuffer := Playlists[Len]; - Dec(Len); - while (Len >= 0) AND (CompareText(Playlists[Len].Name, PlayListBuffer.Name) >= 0) do - begin - Playlists[Len+1] := Playlists[Len]; - Dec(Len); - end; - Playlists[Len+1] := PlayListBuffer; + Playlists[Len+1] := Playlists[Len]; + Dec(Len); end; - - until FindNext(SR) <> 0; - FindClose(SR); - end; + Playlists[Len+1] := PlayListBuffer; + end; + end; end; //---------- //LoadPlayList - Load a Playlist in the Array //---------- -Function TPlayListManager.LoadPlayList(Index: Cardinal; Filename: String): Boolean; - var - F: TextFile; - Line: String; - PosDelimiter: Integer; - SongID: Integer; - Len: Integer; +function TPlayListManager.LoadPlayList(Index: Cardinal; const Filename: IPath): Boolean; - Function FindSong(Artist, Title: String): Integer; + function FindSong(Artist, Title: UTF8String): Integer; var I: Integer; begin Result := -1; For I := low(CatSongs.Song) to high(CatSongs.Song) do begin - if (CatSongs.Song[I].Title = Title) AND (CatSongs.Song[I].Artist = Artist) then + if (CatSongs.Song[I].Title = Title) and (CatSongs.Song[I].Artist = Artist) then begin Result := I; Break; end; end; end; + +var + TextStream: TTextFileStream; + Line: UTF8String; + PosDelimiter: Integer; + SongID: Integer; + Len: Integer; + FilenameAbs: IPath; begin - if not FileExists(PlayListPath + Filename) then - begin - Log.LogError('Could not load Playlist: ' + Filename); - Result := False; - Exit; + //Load File + try + FilenameAbs := PlaylistPath.Append(Filename); + TextStream := TMemTextFileStream.Create(FilenameAbs, fmOpenRead); + except + begin + Log.LogError('Could not load Playlist: ' + FilenameAbs.ToNative); + Result := False; + Exit; + end; end; Result := True; - //Load File - AssignFile(F, PlayListPath + FileName); - Reset(F); - //Set Filename - PlayLists[Index].Filename := Filename; - PlayLists[Index].Name := ''; + Playlists[Index].Filename := Filename; + Playlists[Index].Name := ''; //Read Until End of File - While not Eof(F) do + while TextStream.ReadLine(Line) do begin - //Read Curent Line - Readln(F, Line); - if (Length(Line) > 0) then begin - PosDelimiter := Pos(':', Line); - if (PosDelimiter <> 0) then + PosDelimiter := UTF8Pos(':', Line); + if (PosDelimiter <> 0) then begin //Comment or Name String if (Line[1] = '#') then @@ -224,7 +228,7 @@ begin PlayLists[Index].Items[Len].Artist := Trim(copy(Line, 1, PosDelimiter - 1)); PlayLists[Index].Items[Len].Title := Trim(copy(Line, PosDelimiter + 1, Length(Line) - PosDelimiter)); end - else Log.LogError('Could not find Song in Playlist: ' + PlayLists[Index].Filename + ', ' + Line); + else Log.LogError('Could not find Song in Playlist: ' + PlayLists[Index].Filename.ToNative + ', ' + Line); end; end; end; @@ -233,71 +237,70 @@ begin //If no special name is given, use Filename if PlayLists[Index].Name = '' then begin - PlayLists[Index].Name := ChangeFileExt(FileName, ''); + PlayLists[Index].Name := FileName.SetExtension('').ToUTF8; end; //Finish (Close File) - CloseFile(F); + TextStream.Free; end; -//---------- -//SavePlayList - Saves the specified Playlist -//---------- -Procedure TPlayListManager.SavePlayList(Index: Cardinal); +{** + * Saves the specified Playlist + *} +procedure TPlayListManager.SavePlayList(Index: Cardinal); var - F: TextFile; + TextStream: TTextFileStream; + PlaylistFile: IPath; I: Integer; begin - if (Not FileExists(PlaylistPath + Playlists[Index].Filename)) OR (Not FileisReadOnly(PlaylistPath + Playlists[Index].Filename)) then - begin + PlaylistFile := PlaylistPath.Append(Playlists[Index].Filename); - //open File for Rewriting - AssignFile(F, PlaylistPath + Playlists[Index].Filename); - try - try - Rewrite(F); + // cannot update read-only file + if PlaylistFile.IsFile() and PlaylistFile.IsReadOnly() then + Exit; - //Write Version (not nessecary but helpful) - WriteLn(F, '######################################'); - WriteLn(F, '#Ultrastar Deluxe Playlist Format v1.0'); - WriteLn(F, '#Playlist "' + Playlists[Index].Name + '" with ' + InttoStr(Length(Playlists[Index].Items)) + ' Songs.'); - WriteLn(F, '######################################'); + // open file for rewriting + TextStream := TMemTextFileStream.Create(PlaylistFile, fmCreate); + try + // Write version (not nessecary but helpful) + TextStream.WriteLine('######################################'); + TextStream.WriteLine('#Ultrastar Deluxe Playlist Format v1.0'); + TextStream.WriteLine(Format('#Playlist %s with %d Songs.', + [ Playlists[Index].Name, Length(Playlists[Index].Items) ])); + TextStream.WriteLine('######################################'); - //Write Name Information - WriteLn(F, '#Name: ' + Playlists[Index].Name); + // Write name information + TextStream.WriteLine('#Name: ' + Playlists[Index].Name); - //Write Song Information - WriteLn(F, '#Songs:'); + // Write song information + TextStream.WriteLine('#Songs:'); - For I := 0 to high(Playlists[Index].Items) do - begin - WriteLn(F, Playlists[Index].Items[I].Artist + ' : ' + Playlists[Index].Items[I].Title); - end; - except - log.LogError('Could not write Playlistfile "' + Playlists[Index].Name + '"'); - end; - finally - CloseFile(F); + for I := 0 to high(Playlists[Index].Items) do + begin + TextStream.WriteLine(Playlists[Index].Items[I].Artist + ' : ' + Playlists[Index].Items[I].Title); end; + except + Log.LogError('Could not write Playlistfile "' + Playlists[Index].Name + '"'); end; + TextStream.Free; end; -//---------- -//SetPlayList - Display a Playlist in CatSongs -//---------- -Procedure TPlayListManager.SetPlayList(Index: Cardinal); +{** + * Display a Playlist in CatSongs + *} +procedure TPlayListManager.SetPlayList(Index: Cardinal); var I: Integer; begin - If (Int(Index) > High(PlayLists)) then + if (Int(Index) > High(PlayLists)) then exit; //Hide all Songs - For I := 0 to high(CatSongs.Song) do + for I := 0 to high(CatSongs.Song) do CatSongs.Song[I].Visible := False; //Show Songs in PL - For I := 0 to high(PlayLists[Index].Items) do + for I := 0 to high(PlayLists[Index].Items) do begin CatSongs.Song[PlayLists[Index].Items[I].SongID].Visible := True; end; @@ -324,31 +327,33 @@ end; //---------- //AddPlaylist - Adds a Playlist and Returns the Index //---------- -Function TPlayListManager.AddPlaylist(Name: String): Cardinal; +function TPlayListManager.AddPlaylist(const Name: UTF8String): cardinal; var I: Integer; + PlaylistFile: IPath; begin Result := Length(Playlists); SetLength(Playlists, Result + 1); // Sort the Playlists - Insertion Sort - while (Result > 0) AND (CompareText(Playlists[Result - 1].Name, Name) >= 0) do + while (Result > 0) and (CompareText(Playlists[Result - 1].Name, Name) >= 0) do begin Dec(Result); Playlists[Result+1] := Playlists[Result]; end; - Playlists[Result].Name := Name; + Playlists[Result].Name := Name; + + // clear playlist items + SetLength(Playlists[Result].Items, 0); I := 1; - if (not FileExists(PlaylistPath + Name + '.upl')) then - Playlists[Result].Filename := Name + '.upl' - else + PlaylistFile := PlaylistPath.Append(Name + '.upl'); + while (PlaylistFile.Exists) do begin - repeat - Inc(I); - until not FileExists(PlaylistPath + Name + InttoStr(I) + '.upl'); - Playlists[Result].Filename := Name + InttoStr(I) + '.upl'; + Inc(I); + PlaylistFile := PlaylistPath.Append(Name + InttoStr(I) + '.upl'); end; + Playlists[Result].Filename := PlaylistFile.GetName; //Save new Playlist SavePlayList(Result); @@ -357,28 +362,28 @@ end; //---------- //DelPlaylist - Deletes a Playlist //---------- -Procedure TPlayListManager.DelPlaylist(const Index: Cardinal); +procedure TPlayListManager.DelPlaylist(const Index: Cardinal); var I: Integer; - Filename: String; + Filename: IPath; begin - If Int(Index) > High(Playlists) then + if Int(Index) > High(Playlists) then Exit; - Filename := PlaylistPath + Playlists[Index].Filename; + Filename := PlaylistPath.Append(Playlists[Index].Filename); //If not FileExists or File is not Writeable then exit - If (Not FileExists(Filename)) OR (FileisReadOnly(Filename)) then + if (not Filename.IsFile()) or (Filename.IsReadOnly()) then Exit; //Delete Playlist from FileSystem - if Not DeleteFile(Filename) then + if not Filename.DeleteFile() then Exit; //Delete Playlist from Array //move all PLs to the Hole - For I := Index to High(Playlists)-1 do + for I := Index to High(Playlists)-1 do PlayLists[I] := PlayLists[I+1]; //Delete last Playlist @@ -390,7 +395,7 @@ begin begin ScreenSong.UnLoadDetailedCover; ScreenSong.HideCatTL; - CatSongs.SetFilter('', 0); + CatSongs.SetFilter('', fltAll); ScreenSong.Interaction := 0; ScreenSong.FixSelected; ScreenSong.ChangeMusic; @@ -471,7 +476,7 @@ end; //---------- //GetNames - Writes Playlist Names in a Array //---------- -Procedure TPlayListManager.GetNames(var PLNames: array of String); +procedure TPlayListManager.GetNames(var PLNames: array of UTF8String); var I: Integer; Len: Integer; diff --git a/cmake/src/base/URecord.pas b/cmake/src/base/URecord.pas index 2c2093a0..c183875c 100644 --- a/cmake/src/base/URecord.pas +++ b/cmake/src/base/URecord.pas @@ -95,14 +95,14 @@ const type TAudioInputSource = record - Name: string; + Name: UTF8String; end; // soundcard input-devices information TAudioInputDevice = class public CfgIndex: integer; // index of this device in Ini.InputDeviceConfig - Name: string; // soundcard name + Name: UTF8String; // soundcard name Source: array of TAudioInputSource; // soundcard input-sources SourceRestore: integer; // source-index that will be selected after capturing (-1: not detected) MicSource: integer; // source-index of mic (-1: none detected) @@ -133,6 +133,7 @@ type destructor Destroy; override; procedure UpdateInputDeviceConfig; + function ValidateSettings: boolean; // handle microphone input procedure HandleMicrophoneData(Buffer: PByteArray; Size: integer; @@ -143,7 +144,7 @@ type private Started: boolean; protected - function UnifyDeviceName(const name: string; deviceIndex: integer): string; + function UnifyDeviceName(const name: UTF8String; deviceIndex: integer): UTF8String; public function GetName: String; virtual; abstract; function InitializeRecord: boolean; virtual; abstract; @@ -162,6 +163,8 @@ implementation uses ULog, + UGraphic, + ULanguage, UNote; var @@ -577,6 +580,7 @@ begin deviceCfg.Name := Trim(device.Name); deviceCfg.Input := 0; + deviceCfg.Latency := LATENCY_AUTODETECT; channelCount := device.AudioFormat.Channels; SetLength(deviceCfg.ChannelToPlayerMap, channelCount); @@ -593,6 +597,50 @@ begin end; end; +function TAudioInputProcessor.ValidateSettings: boolean; +const + MAX_PLAYER_COUNT = 6; // FIXME: there should be a global variable for this +var + I, J: integer; + PlayerID: integer; + PlayerMap: array [0 .. MAX_PLAYER_COUNT] of boolean; + InputDevice: TAudioInputDevice; + InputDeviceCfg: PInputDeviceConfig; +begin + // mark all players as unassigned + for I := 0 to High(PlayerMap) do + PlayerMap[I] := false; + + // iterate over all active devices + for I := 0 to High(DeviceList) do + begin + InputDevice := DeviceList[I]; + InputDeviceCfg := @Ini.InputDeviceConfig[InputDevice.CfgIndex]; + // iterate over all channels of the current devices + for J := 0 to High(InputDeviceCfg.ChannelToPlayerMap) do + begin + // get player that was mapped to the current device channel + PlayerID := InputDeviceCfg.ChannelToPlayerMap[J]; + if (PlayerID <> 0) then + begin + // check if player is already assigned to another device/channel + if (PlayerMap[PlayerID]) then + begin + ScreenPopupError.ShowPopup( + Format(Language.Translate('ERROR_PLAYER_DEVICE_ASSIGNMENT'), + [PlayerID])); + Result := false; + Exit; + end; + + // mark player as assigned to a device + PlayerMap[PlayerID] := true; + end; + end; + end; + Result := true; +end; + {* * Handles captured microphone input data. * Params: @@ -741,11 +789,11 @@ begin Started := false; end; -function TAudioInputBase.UnifyDeviceName(const name: string; deviceIndex: integer): string; +function TAudioInputBase.UnifyDeviceName(const name: UTF8String; deviceIndex: integer): UTF8String; var count: integer; // count of devices with this name - function IsDuplicate(const name: string): boolean; + function IsDuplicate(const name: UTF8String): boolean; var i: integer; begin @@ -753,10 +801,13 @@ var // search devices with same description for i := 0 to deviceIndex-1 do begin - if (AudioInputProcessor.DeviceList[i].Name = name) then + if (AudioInputProcessor.DeviceList[i] <> nil) then begin - Result := true; - Break; + if (AudioInputProcessor.DeviceList[i].Name = name) then + begin + Result := true; + Break; + end; end; end; end; diff --git a/cmake/src/base/USingScores.pas b/cmake/src/base/USingScores.pas index 89896d2d..26c5dfe8 100644 --- a/cmake/src/base/USingScores.pas +++ b/cmake/src/base/USingScores.pas @@ -117,9 +117,9 @@ type TScorePopUp = record Player: byte; // index of the popups player TimeStamp: cardinal; // timestamp of popups spawn - Rating: byte; // 0 to 8, type of rating (cool, bad, etc.) - ScoreGiven: word; // score that has already been given to the player - ScoreDiff: word; // difference between cur score at spawn and old score + Rating: integer; // 0 to 8, type of rating (cool, bad, etc.) + ScoreGiven: integer; // score that has already been given to the player + ScoreDiff: integer; // difference between cur score at spawn and old score Next: PScorePopUp; // next item in list end; aScorePopUp = array of TScorePopUp; @@ -129,7 +129,7 @@ type //----------- TSingScores = class private - Positions: aScorePosition; + aPositions: aScorePosition; aPlayers: aScorePlayer; oPositionCount: byte; oPlayerCount: byte; @@ -138,9 +138,18 @@ type FirstPopUp: PScorePopUp; LastPopUp: PScorePopUp; + // only defined during draw, time passed between + // current and previous call of draw + TimePassed: Cardinal; + // draws a popup by pointer procedure DrawPopUp(const PopUp: PScorePopUp); + // raises players score if RaiseScore was called + // has to be called after DrawPopUp and before + // DrawScore + procedure DoRaiseScore(const Index: integer); + // draws a score by playerindex procedure DrawScore(const Index: integer); @@ -149,6 +158,10 @@ type // removes a popup w/o destroying the list procedure KillPopUp(const last, cur: PScorePopUp); + + // calculate the amount of points for a player that is + // still in popups and therfore not displayed + function GetPopUpPoints(const Index: integer): integer; public Settings: record // Record containing some Displaying Options Phase1Time: real; // time for phase 1 to complete (in msecs) @@ -174,6 +187,7 @@ type property PositionCount: byte read oPositionCount; property PlayerCount: byte read oPlayerCount; property Players: aScorePlayer read aPlayers; + property Positions: aScorePosition read aPositions; // constructor just sets some standard settings constructor Create; @@ -201,8 +215,14 @@ type // it gives every player a score position procedure Init; + // raises the score of a specified player to the specified score + procedure RaiseScore(Player: byte; Score: integer); + + // sets the score of a specified player to the specified score + procedure SetScore(Player: byte; Score: integer); + // spawns a new line bonus popup for the player - procedure SpawnPopUp(const PlayerIndex: byte; const Rating: byte; const Score: word); + procedure SpawnPopUp(const PlayerIndex: byte; const Rating: integer; const Score: integer); // removes all popups from mem procedure KillAllPopUps; @@ -215,6 +235,7 @@ implementation uses SysUtils, + Math, SDL, TextGL, ULog, @@ -266,7 +287,7 @@ procedure TSingScores.AddPosition(const pPosition: PScorePosition); begin if (PositionCount < MaxPositions) then begin - Positions[PositionCount] := pPosition^; + aPositions[PositionCount] := pPosition^; Inc(oPositionCount); end; end; @@ -318,6 +339,7 @@ procedure TSingScores.ClearPlayers; begin KillAllPopUps; oPlayerCount := 0; + TimePassed := 0; end; {** @@ -328,6 +350,7 @@ begin KillAllPopUps; oPlayerCount := 0; oPositionCount := 0; + TimePassed := 0; end; {** @@ -360,7 +383,7 @@ var nPosition.PUW := nPosition.BGW; nPosition.PUH := nPosition.BGH; - nPosition.PUFont := 2; + nPosition.PUFont := ftOutline1; nPosition.PUFontSize := 18; nPosition.PUStartX := nPosition.BGX; @@ -400,9 +423,33 @@ begin end; {** + * raises the score of a specified player to the specified score + *} +procedure TSingScores.RaiseScore(Player: byte; Score: integer); +begin + if (Player <= PlayerCount - 1) then + aPlayers[Player].Score := Score; +end; + +{** + * sets the score of a specified player to the specified score + *} +procedure TSingScores.SetScore(Player: byte; Score: integer); + var + Diff: Integer; +begin + if (Player <= PlayerCount - 1) then + begin + Diff := Score - Players[Player].Score; + aPlayers[Player].Score := Score; + Inc(aPlayers[Player].ScoreDisplayed, Diff); + end; +end; + +{** * spawns a new line bonus popup for the player *} -procedure TSingScores.SpawnPopUp(const PlayerIndex: byte; const Rating: byte; const Score: word); +procedure TSingScores.SpawnPopUp(const PlayerIndex: byte; const Rating: integer; const Score: integer); var Cur: PScorePopUp; begin @@ -414,10 +461,12 @@ begin Cur.Player := PlayerIndex; Cur.TimeStamp := SDL_GetTicks; - // limit rating value to 8 + // limit rating value to 0..8 // a higher value would cause a crash when selecting the bg texture if (Rating > 8) then Cur.Rating := 8 + else if (Rating < 0) then + Cur.Rating := 0 else Cur.Rating := Rating; @@ -513,6 +562,27 @@ begin end; {** + * calculate the amount of points for a player that is + * still in popups and therfore not displayed + *} +function TSingScores.GetPopUpPoints(const Index: integer): integer; + var + CurPopUp: PScorePopUp; +begin + Result := 0; + + CurPopUp := FirstPopUp; + while (CurPopUp <> nil) do + begin + if (CurPopUp.Player = Index) then + begin // add points left "in" popup to result + Inc(Result, CurPopUp.ScoreDiff - CurPopUp.ScoreGiven); + end; + CurPopUp := CurPopUp.Next; + end; +end; + +{** * has to be called after positions and players have been added, before first call of draw * it gives each player a score position *} @@ -532,7 +602,7 @@ var for I := 0 to PositionCount - 1 do begin - if ((Positions[I].PlayerCount and bPlayerCount) <> 0) then + if ((aPositions[I].PlayerCount and bPlayerCount) <> 0) then Inc(Result); end; end; @@ -546,7 +616,7 @@ var for I := 0 to PositionCount - 1 do begin - if ((Positions[I].PlayerCount and bPlayerCount) <> 0) then + if ((aPositions[I].PlayerCount and bPlayerCount) <> 0) then begin if (bPlayer = 0) then begin @@ -614,6 +684,8 @@ var CurPopUp, LastPopUp: PScorePopUp; begin CurTime := SDL_GetTicks; + if (TimePassed <> 0) then + TimePassed := CurTime - TimePassed; if Visible then begin @@ -644,6 +716,7 @@ begin // draw players w/ rating bar for I := 0 to PlayerCount-1 do begin + DoRaiseScore(I); DrawScore(I); DrawRatingBar(I); end @@ -651,10 +724,42 @@ begin // draw players w/o rating bar for I := 0 to PlayerCount-1 do begin + DoRaiseScore(I); DrawScore(I); end; end; // eo visible + + TimePassed := CurTime; +end; + +{** + * raises players score if RaiseScore was called + * has to be called after DrawPopUp and before + * DrawScore + *} +procedure TSingScores.DoRaiseScore(const Index: integer); + var + S: integer; + Diff: integer; + const + RaisePerSecond = 500; +begin + S := (Players[Index].Score - (Players[Index].ScoreDisplayed + GetPopUpPoints(Index))); + + if (S <> 0) then + begin + Diff := Round(RoundTo((RaisePerSecond * TimePassed) / 1000, 1)); + + { minimal raise per frame = 1 } + if Abs(Diff) < 1 then + Diff := Sign(S); + + if (Abs(Diff) < Abs(S)) then + Inc(aPlayers[Index].ScoreDisplayed, Diff) + else + Inc(aPlayers[Index].ScoreDisplayed, S); + end; end; {** @@ -701,13 +806,13 @@ begin Progress := TimeDiff / Settings.Phase1Time; - W := Positions[PIndex].PUW * Sin(Progress/2*Pi); - H := Positions[PIndex].PUH * Sin(Progress/2*Pi); + W := aPositions[PIndex].PUW * Sin(Progress/2*Pi); + H := aPositions[PIndex].PUH * Sin(Progress/2*Pi); - X := Positions[PIndex].PUStartX + (Positions[PIndex].PUW - W)/2; - Y := Positions[PIndex].PUStartY + (Positions[PIndex].PUH - H)/2; + X := aPositions[PIndex].PUStartX + (aPositions[PIndex].PUW - W)/2; + Y := aPositions[PIndex].PUStartY + (aPositions[PIndex].PUH - H)/2; - FontSize := Round(Progress * Positions[PIndex].PUFontSize); + FontSize := Round(Progress * aPositions[PIndex].PUFontSize); FontOffset := (H - FontSize) / 2; Alpha := 1; end @@ -717,20 +822,20 @@ begin // phase 2 - the moving Progress := (TimeDiff - Settings.Phase1Time) / Settings.Phase2Time; - W := Positions[PIndex].PUW; - H := Positions[PIndex].PUH; + W := aPositions[PIndex].PUW; + H := aPositions[PIndex].PUH; - PosDiff := Positions[PIndex].PUTargetX - Positions[PIndex].PUStartX; + PosDiff := aPositions[PIndex].PUTargetX - aPositions[PIndex].PUStartX; if PosDiff > 0 then PosDiff := PosDiff + W; - X := Positions[PIndex].PUStartX + PosDiff * sqr(Progress); + X := aPositions[PIndex].PUStartX + PosDiff * sqr(Progress); - PosDiff := Positions[PIndex].PUTargetY - Positions[PIndex].PUStartY; + PosDiff := aPositions[PIndex].PUTargetY - aPositions[PIndex].PUStartY; if PosDiff < 0 then - PosDiff := PosDiff + Positions[PIndex].BGH; - Y := Positions[PIndex].PUStartY + PosDiff * sqr(Progress); + PosDiff := PosDiff + aPositions[PIndex].BGH; + Y := aPositions[PIndex].PUStartY + PosDiff * sqr(Progress); - FontSize := Positions[PIndex].PUFontSize; + FontSize := aPositions[PIndex].PUFontSize; FontOffset := (H - FontSize) / 2; Alpha := 1 - 0.3 * Progress; end @@ -763,24 +868,24 @@ begin // set positions etc. Alpha := 0.7 - 0.7 * Progress; - W := Positions[PIndex].PUW; - H := Positions[PIndex].PUH; + W := aPositions[PIndex].PUW; + H := aPositions[PIndex].PUH; - PosDiff := Positions[PIndex].PUTargetX - Positions[PIndex].PUStartX; + PosDiff := aPositions[PIndex].PUTargetX - aPositions[PIndex].PUStartX; if (PosDiff > 0) then PosDiff := W else PosDiff := 0; - X := Positions[PIndex].PUTargetX + PosDiff * Progress; + X := aPositions[PIndex].PUTargetX + PosDiff * Progress; - PosDiff := Positions[PIndex].PUTargetY - Positions[PIndex].PUStartY; + PosDiff := aPositions[PIndex].PUTargetY - aPositions[PIndex].PUStartY; if (PosDiff < 0) then - PosDiff := -Positions[PIndex].BGH + PosDiff := -aPositions[PIndex].BGH else PosDiff := 0; - Y := Positions[PIndex].PUTargetY - PosDiff * (1 - Progress); + Y := aPositions[PIndex].PUTargetY - PosDiff * (1 - Progress); - FontSize := Positions[PIndex].PUFontSize; + FontSize := aPositions[PIndex].PUFontSize; FontOffset := (H - FontSize) / 2; end else @@ -817,7 +922,7 @@ begin glDisable(GL_BLEND); // set font style and size - SetFontStyle(Positions[PIndex].PUFont); + SetFontStyle(aPositions[PIndex].PUFont); SetFontItalic(false); SetFontSize(FontSize); SetFontReflection(false, 0); @@ -853,7 +958,7 @@ begin // only draw if player is on cur screen if (((Players[Index].Position and 128) = 0) = (ScreenAct = 1)) and Players[Index].Visible then begin - Position := @Positions[Players[Index].Position and 127]; + Position := @aPositions[Players[Index].Position and 127]; // draw scorebg glEnable(GL_TEXTURE_2D); @@ -905,7 +1010,7 @@ begin Players[index].RBVisible and Players[index].Visible) then begin - Position := @Positions[Players[Index].Position and 127]; + Position := @aPositions[Players[Index].Position and 127]; if (Enabled and Players[Index].Enabled) then begin diff --git a/cmake/src/base/USkins.pas b/cmake/src/base/USkins.pas index a4722d95..a909b081 100644 --- a/cmake/src/base/USkins.pas +++ b/cmake/src/base/USkins.pas @@ -33,32 +33,42 @@ interface {$I switches.inc} +uses + UPath, + UCommon; + type TSkinTexture = record Name: string; - FileName: string; + FileName: IPath; end; TSkinEntry = record Theme: string; Name: string; - Path: string; - FileName: string; + Path: IPath; + FileName: IPath; + + DefaultColor: integer; Creator: string; // not used yet end; TSkin = class Skin: array of TSkinEntry; SkinTexture: array of TSkinTexture; - SkinPath: string; + SkinPath: IPath; Color: integer; constructor Create; procedure LoadList; - procedure ParseDir(Dir: string); - procedure LoadHeader(FileName: string); + procedure ParseDir(Dir: IPath); + procedure LoadHeader(FileName: IPath); procedure LoadSkin(Name: string); - function GetTextureFileName(TextureName: string): string; + function GetTextureFileName(TextureName: string): IPath; function GetSkinNumber(Name: string): integer; + function GetDefaultColor(SkinNo: integer): integer; + + procedure GetSkinsByTheme(Theme: string; out Skins: TUTF8StringDynArray); + procedure onThemeChange; end; @@ -71,10 +81,12 @@ uses IniFiles, Classes, SysUtils, + Math, UIni, ULog, UMain, - UPath; + UPathUtils, + UFileSystem; constructor TSkin.Create; begin @@ -86,48 +98,47 @@ end; procedure TSkin.LoadList; var - SR: TSearchRec; + Iter: IFileIterator; + DirInfo: TFileInfo; begin - if FindFirst(SkinsPath+'*', faDirectory, SR) = 0 then + Iter := FileSystem.FileFind(SkinsPath.Append('*'), faDirectory); + while Iter.HasNext do begin - repeat - if (SR.Name <> '.') and (SR.Name <> '..') then - ParseDir(SkinsPath + SR.Name + PathDelim); - until FindNext(SR) <> 0; - end; // if - FindClose(SR); + DirInfo := Iter.Next(); + if (not DirInfo.Name.Equals('.')) and (not DirInfo.Name.Equals('..')) then + ParseDir(SkinsPath.Append(DirInfo.Name, pdAppend)); + end; end; -procedure TSkin.ParseDir(Dir: string); +procedure TSkin.ParseDir(Dir: IPath); var - SR: TSearchRec; + Iter: IFileIterator; + IniInfo: TFileInfo; begin - if FindFirst(Dir + '*.ini', faAnyFile, SR) = 0 then + Iter := FileSystem.FileFind(Dir.Append('*.ini'), 0); + while Iter.HasNext do begin - repeat - - if (SR.Name <> '.') and (SR.Name <> '..') then - LoadHeader(Dir + SR.Name); - - until FindNext(SR) <> 0; + IniInfo := Iter.Next; + LoadHeader(Dir.Append(IniInfo.Name)); end; end; -procedure TSkin.LoadHeader(FileName: string); +procedure TSkin.LoadHeader(FileName: IPath); var SkinIni: TMemIniFile; S: integer; begin - SkinIni := TMemIniFile.Create(FileName); + SkinIni := TMemIniFile.Create(FileName.ToNative); S := Length(Skin); SetLength(Skin, S+1); - Skin[S].Path := IncludeTrailingPathDelimiter(ExtractFileDir(FileName)); - Skin[S].FileName := ExtractFileName(FileName); + Skin[S].Path := FileName.GetPath; + Skin[S].FileName := FileName.GetName; Skin[S].Theme := SkinIni.ReadString('Skin', 'Theme', ''); Skin[S].Name := SkinIni.ReadString('Skin', 'Name', ''); Skin[S].Creator := SkinIni.ReadString('Skin', 'Creator', ''); + Skin[S].DefaultColor := Max(0, GetArrayIndex(IColor, SkinIni.ReadString('Skin', 'Color', ''), true)); SkinIni.Free; end; @@ -142,7 +153,7 @@ begin S := GetSkinNumber(Name); SkinPath := Skin[S].Path; - SkinIni := TMemIniFile.Create(SkinPath + Skin[S].FileName); + SkinIni := TMemIniFile.Create(SkinPath.Append(Skin[S].FileName).ToNative); SL := TStringList.Create; SkinIni.ReadSection('Textures', SL); @@ -151,42 +162,33 @@ begin for T := 0 to SL.Count-1 do begin SkinTexture[T].Name := SL.Strings[T]; - SkinTexture[T].FileName := SkinIni.ReadString('Textures', SL.Strings[T], ''); + SkinTexture[T].FileName := Path(SkinIni.ReadString('Textures', SL.Strings[T], '')); end; SL.Free; SkinIni.Free; end; -function TSkin.GetTextureFileName(TextureName: string): string; +function TSkin.GetTextureFileName(TextureName: string): IPath; var T: integer; begin - Result := ''; + Result := PATH_NONE; for T := 0 to High(SkinTexture) do begin - if ( SkinTexture[T].Name = TextureName ) and - ( SkinTexture[T].FileName <> '' ) then + if (SkinTexture[T].Name = TextureName) and + (SkinTexture[T].FileName.IsSet) then begin - Result := SkinPath + SkinTexture[T].FileName; + Result := SkinPath.Append(SkinTexture[T].FileName); end; end; - if ( TextureName <> '' ) and - ( Result <> '' ) then + if (TextureName <> '') and (Result.IsSet) then begin //Log.LogError('', '-----------------------------------------'); //Log.LogError(TextureName+' - '+ Result, 'TSkin.GetTextureFileName'); end; - -{ Result := SkinPath + 'Bar.jpg'; - if TextureName = 'Ball' then - Result := SkinPath + 'Ball.bmp'; - if Copy(TextureName, 1, 4) = 'Gray' then - Result := SkinPath + 'Ball.bmp'; - if Copy(TextureName, 1, 6) = 'NoteBG' then - Result := SkinPath + 'Ball.bmp';} end; function TSkin.GetSkinNumber(Name: string): integer; @@ -195,25 +197,52 @@ var begin Result := 0; // set default to the first available skin for S := 0 to High(Skin) do - if Skin[S].Name = Name then + if CompareText(Skin[S].Name, Name) = 0 then Result := S; end; -procedure TSkin.onThemeChange; -var - S: integer; - Name: String; +procedure TSkin.GetSkinsByTheme(Theme: string; out Skins: TUTF8StringDynArray); + var + I: Integer; + Len: integer; begin - Ini.SkinNo:=0; - SetLength(ISkin, 0); - Name := Uppercase(ITheme[Ini.Theme]); - for S := 0 to High(Skin) do - if Name = Uppercase(Skin[S].Theme) then + SetLength(Skins, 0); + Len := 0; + + for I := 0 to High(Skin) do + if CompareText(Theme, Skin[I].Theme) = 0 then begin - SetLength(ISkin, Length(ISkin)+1); - ISkin[High(ISkin)] := Skin[S].Name; + SetLength(Skins, Len + 1); + Skins[Len] := Skin[I].Name; + Inc(Len); end; +end; + +{ returns number of default color for skin with + index SkinNo in ISkin (not in the actual skin array) } +function TSkin.GetDefaultColor(SkinNo: integer): integer; + var + I: Integer; +begin + Result := 0; + for I := 0 to High(Skin) do + if CompareText(ITheme[Ini.Theme], Skin[I].Theme) = 0 then + begin + if SkinNo > 0 then + Dec(SkinNo) + else + begin + Result := Skin[I].DefaultColor; + Break; + end; + end; +end; + +procedure TSkin.onThemeChange; +begin + Ini.SkinNo:=0; + GetSkinsByTheme(ITheme[Ini.Theme], ISkin); end; end. diff --git a/cmake/src/base/USong.pas b/cmake/src/base/USong.pas index 57f78a27..a441fe40 100644 --- a/cmake/src/base/USong.pas +++ b/cmake/src/base/USong.pas @@ -56,7 +56,11 @@ uses PseudoThread, {$ENDIF} UCatCovers, - UXMLSong; + UXMLSong, + UUnicodeUtils, + UTextEncoding, + UFilesystem, + UPath; type @@ -68,42 +72,62 @@ type end; TScore = record - Name: WideString; + Name: UTF8String; Score: integer; - Length: string; + Date: UTF8String; + end; + + { used to hold header tags that are not supported by this version of + usdx (e.g. some tags from ultrastar 0.7.0) when songs are loaded in + songeditor. They will be written the end of the song header } + TCustomHeaderTag = record + Tag: UTF8String; + Content: UTF8String; end; TSong = class + private FileLineNo : integer; // line, which is read last, for error reporting - procedure ParseNote(LineNumber: integer; TypeP: char; StartP, DurationP, NoteP: integer; LyricS: string); + function DecodeFilename(Filename: RawByteString): IPath; + procedure ParseNote(LineNumber: integer; TypeP: char; StartP, DurationP, NoteP: integer; LyricS: UTF8String); procedure NewSentence(LineNumberP: integer; Param1, Param2: integer); - function ReadTXTHeader( const aFileName : WideString ): boolean; - function ReadXMLHeader( const aFileName : WideString ): boolean; + function ParseLyricStringParam(const Line: RawByteString; var LinePos: integer): RawByteString; + function ParseLyricIntParam(const Line: RawByteString; var LinePos: integer): integer; + function ParseLyricFloatParam(const Line: RawByteString; var LinePos: integer): extended; + function ParseLyricCharParam(const Line: RawByteString; var LinePos: integer): AnsiChar; + function ParseLyricText(const Line: RawByteString; var LinePos: integer): RawByteString; + + function ReadTXTHeader(SongFile: TTextFileStream; ReadCustomTags: Boolean): boolean; + function ReadXMLHeader(const aFileName: IPath): boolean; + + function GetFolderCategory(const aFileName: IPath): UTF8String; + function FindSongFile(Dir: IPath; Mask: UTF8String): IPath; public - Path: WideString; - Folder: WideString; // for sorting by folder - fFileName, - FileName: WideString; + Path: IPath; // kust path component of file (only set if file was found) + Folder: UTF8String; // for sorting by folder (only set if file was found) + FileName: IPath; // just name component of file (only set if file was found) + + // filenames + Cover: IPath; + Mp3: IPath; + Background: IPath; + Video: IPath; // sorting methods - //Category: array of WideString; // TODO: do we need this? - Genre: WideString; - Edition: WideString; - Language: WideString; + Genre: UTF8String; + Edition: UTF8String; + Language: UTF8String; + Year: Integer; - Title: WideString; - Artist: WideString; + Title: UTF8String; + Artist: UTF8String; - Text: WideString; - Creator: WideString; + Creator: UTF8String; - Cover: WideString; CoverTex: TTexture; - Mp3: WideString; - Background: WideString; - Video: WideString; + VideoGAP: real; NotesGAP: integer; Start: real; // in seconds @@ -113,6 +137,10 @@ type BPM: array of TBPM; GAP: real; // in miliseconds + Encoding: TEncoding; + + CustomTags: array of TCustomHeaderTag; + Score: array[0..2] of array of TScore; // these are used when sorting is enabled @@ -122,23 +150,21 @@ type 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 - SongFile: TextFile; // all procedures in this unit operate on this file - Base : array[0..1] of integer; Rel : array[0..1] of integer; Mult : integer; MultBPM : integer; - LastError: String; + LastError: AnsiString; function GetErrorLineNo: integer; property ErrorLineNo: integer read GetErrorLineNo; - constructor Create (); overload; - constructor Create ( const aFileName : WideString ); overload; + constructor Create(); overload; + constructor Create(const aFileName : IPath); overload; function LoadSong: boolean; function LoadXMLSong: boolean; - function Analyse(): boolean; + function Analyse(const ReadCustomTags: Boolean = false): boolean; function AnalyseXML(): boolean; procedure Clear(); end; @@ -149,67 +175,82 @@ uses StrUtils, TextGL, UIni, - UPath, + UPathUtils, UMusic, //needed for Lines UNote; //needed for Player +const + DEFAULT_ENCODING = encAuto; + constructor TSong.Create(); begin inherited; + + // to-do : special create for category "songs" + //dirty fix to fix folders=on + Self.Path := PATH_NONE(); + Self.FileName := PATH_NONE(); + Self.Cover := PATH_NONE(); + Self.Mp3 := PATH_NONE(); + Self.Background:= PATH_NONE(); + Self.Video := PATH_NONE(); end; -constructor TSong.Create( const aFileName: WideString ); - // This may be changed, when we rewrite song select code. - // it is some kind of dirty, but imho the best possible - // solution as we do atm not support nested categorys. - // it works like the folder sorting in 1.0.1a - // folder is set to the first folder under the songdir - // so songs ~/.ultrastardx/songs/punk is in the same - // category as songs in shared/ultrastardx/songs are. - // note: folder is just the name of a category it has - // nothing to do with the path used for file loading - function GetFolderCategory: WideString; - var - I: Integer; - P: Integer; //position of next path delimiter - begin - Result := 'Unknown'; //default folder category, if we can't locate the song dir +// This may be changed, when we rewrite song select code. +// it is some kind of dirty, but imho the best possible +// solution as we do atm not support nested categorys. +// it works like the folder sorting in 1.0.1a +// folder is set to the first folder under the songdir +// so songs ~/.ultrastardx/songs/punk is in the same +// category as songs in shared/ultrastardx/songs are. +// note: folder is just the name of a category it has +// nothing to do with the path used for file loading +function TSong.GetFolderCategory(const aFileName: IPath): UTF8String; +var + I: Integer; + CurSongPath: IPath; + CurSongPathRel: IPath; +begin + Result := 'Unknown'; //default folder category, if we can't locate the song dir - for I := 0 to SongPaths.Count-1 do - if (AnsiStartsText(SongPaths.Strings[I], aFilename)) then + for I := 0 to SongPaths.Count-1 do + begin + CurSongPath := SongPaths[I] as IPath; + if (aFileName.IsChildOf(CurSongPath, false)) then + begin + if (aFileName.IsChildOf(CurSongPath, true)) then begin - P := PosEx(PathDelim, aFilename, Length(SongPaths.Strings[I]) + 1); - - If (P > 0) then - begin - // we have found the category name => get it - Result := copy(self.Path, Length(SongPaths.Strings[I]) + 1, P - Length(SongPaths.Strings[I]) - 1); - end - else - begin - // songs are in the "root" of the songdir => use songdir for the categorys name - Result := SongPaths.Strings[I]; - end; - - Exit; + // songs are in the "root" of the songdir => use songdir for the categorys name + Result := CurSongPath.RemovePathDelim.ToUTF8; + end + else + begin + // use the first subdirectory below CurSongPath as the category name + CurSongPathRel := aFileName.GetRelativePath(CurSongPath.AppendPathDelim); + Result := CurSongPathRel.SplitDirs[0].RemovePathDelim.ToUTF8; end; + Exit; + end; end; +end; + +constructor TSong.Create(const aFileName: IPath); begin inherited Create(); Mult := 1; MultBPM := 4; - fFileName := aFileName; LastError := ''; - if fileexists( aFileName ) then + Self.Path := aFileName.GetPath; + Self.FileName := aFileName.GetName; + Self.Folder := GetFolderCategory(aFileName); + + (* + if (aFileName.IsFile) then begin - self.Path := ExtractFilePath( aFileName ); - self.Folder := GetFolderCategory; - self.FileName := ExtractFileName( aFileName ); - (* - if ReadTXTHeader( aFileName ) then + if ReadTXTHeader(aFileName) then begin LoadSong(); end @@ -218,45 +259,189 @@ begin Log.LogError('Error Loading SongHeader, abort Song Loading'); Exit; end; - *) + end; + *) +end; + +function TSong.FindSongFile(Dir: IPath; Mask: UTF8String): IPath; +var + Iter: IFileIterator; + FileInfo: TFileInfo; + FileName: IPath; +begin + Iter := FileSystem.FileFind(Dir.Append(Mask), faDirectory); + if (Iter.HasNext) then + Result := Iter.Next.Name + else + Result := PATH_NONE; +end; + +function TSong.DecodeFilename(Filename: RawByteString): IPath; +begin + Result := UPath.Path(DecodeStringUTF8(Filename, Encoding)); +end; + +type + EUSDXParseException = class(Exception); + +{** + * Parses the Line string starting from LinePos for a parameter. + * Leading whitespace is trimmed, same applies to the first trailing whitespace. + * After the call LinePos will point to the position after the first trailing + * whitespace. + * + * Raises an EUSDXParseException if no string was found. + * + * Example: + * ParseLyricParam(Line:'Param0 Param1 Param2', LinePos:8, ...) + * -> Param:'Param1', LinePos:16 (= start of 'Param2') + *} +function TSong.ParseLyricStringParam(const Line: RawByteString; var LinePos: integer): RawByteString; +var + Start: integer; + OldLinePos: integer; +const + Whitespace = [#9, ' ']; +begin + OldLinePos := LinePos; + + Start := 0; + while (LinePos <= Length(Line)) do + begin + if (Line[LinePos] in Whitespace) then + begin + // check for end of param + if (Start > 0) then + Break; + end + // check for beginning of param + else if (Start = 0) then + begin + Start := LinePos; + end; + Inc(LinePos); + end; + + // check if param was found + if (Start = 0) then + begin + LinePos := OldLinePos; + raise EUSDXParseException.Create('String expected'); + end + else + begin + // copy param without trailing whitespace + Result := Copy(Line, Start, LinePos-Start); + // skip first trailing whitespace (if not at EOL) + if (LinePos <= Length(Line)) then + Inc(LinePos); + end; +end; + +function TSong.ParseLyricIntParam(const Line: RawByteString; var LinePos: integer): integer; +var + Str: RawByteString; + OldLinePos: integer; +begin + OldLinePos := LinePos; + Str := ParseLyricStringParam(Line, LinePos); + + if not TryStrToInt(Str, Result) then + begin // on convert error + Result := 0; + LinePos := OldLinePos; + raise EUSDXParseException.Create('Integer expected'); + end; +end; + +function TSong.ParseLyricFloatParam(const Line: RawByteString; var LinePos: integer): extended; +var + Str: RawByteString; + OldLinePos: integer; +begin + OldLinePos := LinePos; + Str := ParseLyricStringParam(Line, LinePos); + + if not TryStrToFloat(Str, Result) then + begin // on convert error + Result := 0; + LinePos := OldLinePos; + raise EUSDXParseException.Create('Float expected'); end; end; -{function TSong.LoadSong(): boolean; +function TSong.ParseLyricCharParam(const Line: RawByteString; var LinePos: integer): AnsiChar; +var + Str: RawByteString; + OldLinePos: integer; begin + OldLinePos := LinePos; + Str := ParseLyricStringParam(Line, LinePos); + + if (Length(Str) < 1) then + begin + LinePos := OldLinePos; + raise EUSDXParseException.Create('Character expected'); + end + else if (Length(Str) > 1) then + begin + Log.LogWarn(Format('"%s" in line %d: %s', + [FileName.ToNative, FileLineNo, 'character expected but found "' + Str + '"']), + 'TSong.ParseLyricCharParam'); + end; + + LinePos := OldLinePos + 1; + Result := Str[1]; +end; -end; } +{** + * Returns the rest of the line from LinePos as lyric text. + * Leading and trailing whitespace is not trimmed. + *} +function TSong.ParseLyricText(const Line: RawByteString; var LinePos: integer): RawByteString; +begin + if (LinePos > Length(Line)) then + Result := '' + else + begin + Result := Copy(Line, LinePos, Length(Line)-LinePos+1); + LinePos := Length(Line)+1; + end; +end; //Load TXT Song function TSong.LoadSong(): boolean; - var - TempC: char; - Text: string; - CP: integer; // Current Player (0 or 1) + CurLine: RawByteString; + LinePos: integer; Count: integer; Both: boolean; - Param1: integer; - Param2: integer; - Param3: integer; - ParamS: string; - I: integer; + Param0: AnsiChar; + Param1: integer; + Param2: integer; + Param3: integer; + ParamLyric: UTF8String; + + I: integer; + NotesFound: boolean; + SongFile: TTextFileStream; + FileNamePath: IPath; begin Result := false; LastError := ''; - if not FileExists(Path + PathDelim + FileName) then + FileNamePath := Path.Append(FileName); + if not FileNamePath.IsFile() then begin LastError := 'ERROR_CORRUPT_SONG_FILE_NOT_FOUND'; - Log.LogError('File not found: "' + Path + PathDelim + FileName + '"', 'TSong.LoadSong()'); - exit; + Log.LogError('File not found: "' + FileNamePath.ToNative + '"', 'TSong.LoadSong()'); + Exit; end; MultBPM := 4; // multiply beat-count of note by 4 Mult := 1; // accuracy of measurement of note Rel[0] := 0; - CP := 0; Both := false; if Length(Player) = 2 then @@ -264,156 +449,157 @@ begin try // Open song file for reading..... - FileMode := fmOpenRead; - AssignFile(SongFile, fFileName); - Reset(SongFile); - - //Clear old Song Header - if (self.Path = '') then - self.Path := ExtractFilePath(FileName); - - if (self.FileName = '') then - self.Filename := ExtractFileName(FileName); - - FileLineNo := 0; - //Search for Note Begining - repeat - ReadLn(SongFile, Text); - Inc(FileLineNo); + SongFile := TMemTextFileStream.Create(FileNamePath, fmOpenRead); + try + //Search for Note Beginning + FileLineNo := 0; + NotesFound := false; + while (SongFile.ReadLine(CurLine)) do + begin + Inc(FileLineNo); + if (Length(CurLine) > 0) and (CurLine[1] in [':', 'F', '*']) then + begin + NotesFound := true; + Break; + end; + end; - if (EoF(SongFile)) then + if (not NotesFound) then begin //Song File Corrupted - No Notes - CloseFile(SongFile); - Log.LogError('Could not load txt File, no Notes found: ' + FileName); + Log.LogError('Could not load txt File, no notes found: ' + FileNamePath.ToNative); LastError := 'ERROR_CORRUPT_SONG_NO_NOTES'; Exit; end; - Read(SongFile, TempC); - until ((TempC = ':') or (TempC = 'F') or (TempC = '*')); - SetLength(Lines, 2); - for Count := 0 to High(Lines) do - begin - Lines[Count].High := 0; - Lines[Count].Number := 1; - Lines[Count].Current := 0; - Lines[Count].Resolution := self.Resolution; - Lines[Count].NotesGAP := self.NotesGAP; - Lines[Count].ScoreValue := 0; - - //Add first line and set some standard values to fields - //see procedure NewSentence for further explantation - //concerning most of these values - SetLength(Lines[Count].Line, 1); - Lines[Count].Line[0].HighNote := -1; - Lines[Count].Line[0].LastLine := false; - Lines[Count].Line[0].BaseNote := High(Integer); - Lines[Count].Line[0].TotalNotes := 0; - end; - - while (TempC <> 'E') and (not EOF(SongFile)) do - begin - - if (TempC = ':') or (TempC = '*') or (TempC = 'F') then - begin - // read notes - Read(SongFile, Param1); - Read(SongFile, Param2); - Read(SongFile, Param3); - Read(SongFile, ParamS); - - //Check for ZeroNote - if Param2 = 0 then - Log.LogError('Found ZeroNote at "'+TempC+' '+IntToStr(Param1)+' '+IntToStr(Param2)+' '+IntToStr(Param3)+ParamS+'" -> Note ignored!') - else - begin - // add notes - if not Both then - // P1 - ParseNote(0, TempC, (Param1+Rel[0]) * Mult, Param2 * Mult, Param3, ParamS) - else - begin - // P1 + P2 - ParseNote(0, TempC, (Param1+Rel[0]) * Mult, Param2 * Mult, Param3, ParamS); - ParseNote(1, TempC, (Param1+Rel[1]) * Mult, Param2 * Mult, Param3, ParamS); - end; - end; //Zeronote check - end // if - - else if TempC = '-' then + SetLength(Lines, 2); + for Count := 0 to High(Lines) do begin - // reads sentence - Read(SongFile, Param1); - if self.Relative then - Read(SongFile, Param2); // read one more data for relative system - - // new sentence - if not Both then - // P1 - NewSentence(0, (Param1 + Rel[0]) * Mult, Param2) - else - begin - // P1 + P2 - NewSentence(0, (Param1 + Rel[0]) * Mult, Param2); - NewSentence(1, (Param1 + Rel[1]) * Mult, Param2); - end; - end // if + Lines[Count].High := 0; + Lines[Count].Number := 1; + Lines[Count].Current := 0; + Lines[Count].Resolution := self.Resolution; + Lines[Count].NotesGAP := self.NotesGAP; + Lines[Count].ScoreValue := 0; + + //Add first line and set some standard values to fields + //see procedure NewSentence for further explantation + //concerning most of these values + SetLength(Lines[Count].Line, 1); + Lines[Count].Line[0].HighNote := -1; + Lines[Count].Line[0].LastLine := false; + Lines[Count].Line[0].BaseNote := High(Integer); + Lines[Count].Line[0].TotalNotes := 0; + end; - else if TempC = 'B' then + while true do begin - SetLength(self.BPM, Length(self.BPM) + 1); - Read(SongFile, self.BPM[High(self.BPM)].StartBeat); - self.BPM[High(self.BPM)].StartBeat := self.BPM[High(self.BPM)].StartBeat + Rel[0]; + LinePos := 1; - Read(SongFile, Text); - self.BPM[High(self.BPM)].BPM := StrToFloat(Text); - self.BPM[High(self.BPM)].BPM := self.BPM[High(self.BPM)].BPM * Mult * MultBPM; - end; + Param0 := ParseLyricCharParam(CurLine, LinePos); + if (Param0 = 'E') then + begin + Break + end + else if (Param0 in [':', '*', 'F']) then + begin + // read notes + Param1 := ParseLyricIntParam(CurLine, LinePos); + Param2 := ParseLyricIntParam(CurLine, LinePos); + Param3 := ParseLyricIntParam(CurLine, LinePos); + ParamLyric := ParseLyricText(CurLine, LinePos); + + //Check for ZeroNote + if Param2 = 0 then + Log.LogWarn(Format('"%s" in line %d: %s', + [FileNamePath.ToNative, FileLineNo, 'found note with length zero -> note ignored']), 'TSong.LoadSong') + //Log.LogError('Found zero-length note at "'+Param0+' '+IntToStr(Param1)+' '+IntToStr(Param2)+' '+IntToStr(Param3)+ParamLyric+'" -> Note ignored!') + else + begin + // add notes + if not Both then + // P1 + ParseNote(0, Param0, (Param1+Rel[0]) * Mult, Param2 * Mult, Param3, ParamLyric) + else + begin + // P1 + P2 + ParseNote(0, Param0, (Param1+Rel[0]) * Mult, Param2 * Mult, Param3, ParamLyric); + ParseNote(1, Param0, (Param1+Rel[1]) * Mult, Param2 * Mult, Param3, ParamLyric); + end; + end; //Zeronote check + end // if + + else if Param0 = '-' then + begin + // reads sentence + Param1 := ParseLyricIntParam(CurLine, LinePos); + if self.Relative then + Param2 := ParseLyricIntParam(CurLine, LinePos); // read one more data for relative system + + // new sentence + if not Both then + // P1 + NewSentence(0, (Param1 + Rel[0]) * Mult, Param2) + else + begin + // P1 + P2 + NewSentence(0, (Param1 + Rel[0]) * Mult, Param2); + NewSentence(1, (Param1 + Rel[1]) * Mult, Param2); + end; + end // if - ReadLn(SongFile); //Jump to next line in File, otherwise the next Read would catch the linebreak(e.g. #13 #10 on win32) + else if Param0 = 'B' then + begin + SetLength(self.BPM, Length(self.BPM) + 1); + self.BPM[High(self.BPM)].StartBeat := ParseLyricFloatParam(CurLine, LinePos); + self.BPM[High(self.BPM)].StartBeat := self.BPM[High(self.BPM)].StartBeat + Rel[0]; - Read(SongFile, TempC); - Inc(FileLineNo); - end; // while} + self.BPM[High(self.BPM)].BPM := ParseLyricFloatParam(CurLine, LinePos); + self.BPM[High(self.BPM)].BPM := self.BPM[High(self.BPM)].BPM * Mult * MultBPM; + end; - CloseFile(SongFile); + // Read next line in File + if (not SongFile.ReadLine(CurLine)) then + Break; - for I := 0 to High(Lines) do + Inc(FileLineNo); + end; // while + finally + SongFile.Free; + end; + except + on E: Exception do begin - if ((Both) or (I = 0)) then - begin - if (Length(Lines[I].Line) < 2) then - begin - LastError := 'ERROR_CORRUPT_SONG_NO_BREAKS'; - Log.LogError('Error Loading File, Can''t find any Linebreaks: "' + fFileName + '"'); - exit; - end; - - if (Lines[I].Line[Lines[I].High].HighNote < 0) then - begin - SetLength(Lines[I].Line, Lines[I].Number - 1); - Lines[I].High := Lines[I].High - 1; - Lines[I].Number := Lines[I].Number - 1; - Log.LogError('Error loading Song, sentence w/o note found in last line before E: ' + Filename); - end; - end; + Log.LogError(Format('Error loading file: "%s" in line %d,%d: %s', + [FileNamePath.ToNative, FileLineNo, LinePos, E.Message])); + Exit; end; + end; - for Count := 0 to High(Lines) do + for I := 0 to High(Lines) do + begin + if ((Both) or (I = 0)) then begin - if (High(Lines[Count].Line) >= 0) then - Lines[Count].Line[High(Lines[Count].Line)].LastLine := true; - end; - except - try - CloseFile(SongFile); - except + if (Length(Lines[I].Line) < 2) then + begin + LastError := 'ERROR_CORRUPT_SONG_NO_BREAKS'; + Log.LogError('Error loading file: Can''t find any linebreaks in "' + FileNamePath.ToNative + '"'); + exit; + end; + if (Lines[I].Line[Lines[I].High].HighNote < 0) then + begin + SetLength(Lines[I].Line, Lines[I].Number - 1); + Lines[I].High := Lines[I].High - 1; + Lines[I].Number := Lines[I].Number - 1; + Log.LogError('Error loading Song, sentence w/o note found in last line before E: ' + FileNamePath.ToNative); + end; end; + end; - LastError := 'ERROR_CORRUPT_SONG_ERROR_IN_LINE'; - Log.LogError('Error Loading File: "' + fFileName + '" in Line ' + inttostr(FileLineNo)); - exit; + for Count := 0 to High(Lines) do + begin + if (High(Lines[Count].Line) >= 0) then + Lines[Count].Line[High(Lines[Count].Line)].LastLine := true; end; Result := true; @@ -421,11 +607,7 @@ end; //Load XML Song function TSong.LoadXMLSong(): boolean; - var - //TempC: char; - Text: string; - CP: integer; // Current Player (0 or 1) Count: integer; Both: boolean; Param1: integer; @@ -438,14 +620,15 @@ var NoteType: char; SentenceEnd, Rest, Time: integer; Parser: TParser; - + FileNamePath: IPath; begin Result := false; LastError := ''; - if not FileExists(Path + PathDelim + FileName) then + FileNamePath := Path.Append(FileName); + if not FileNamePath.IsFile() then begin - Log.LogError('File not found: "' + Path + PathDelim + FileName + '"', 'TSong.LoadSong()'); + Log.LogError('File not found: "' + FileNamePath.ToNative + '"', 'TSong.LoadSong()'); exit; end; @@ -454,7 +637,6 @@ begin Lines[0].ScoreValue := 0; self.Relative := false; Rel[0] := 0; - CP := 0; Both := false; if Length(Player) = 2 then @@ -484,7 +666,7 @@ begin //Try to Parse the Song - if Parser.ParseSong(Path + PathDelim + FileName) then + if Parser.ParseSong(FileNamePath) then begin //Writeln('XML Inputfile Parsed succesful'); @@ -551,7 +733,7 @@ begin end else begin - Log.LogError('Could not parse Inputfile: ' + Path + PathDelim + FileName); + Log.LogError('Could not parse inputfile: ' + FileNamePath.ToNative); exit; end; @@ -563,14 +745,11 @@ begin Result := true; end; -function TSong.ReadXMLHeader(const aFileName : WideString): boolean; - +function TSong.ReadXMLHeader(const aFileName : IPath): boolean; var - //Line, Identifier, Value: string; - //Temp : word; Done : byte; Parser : TParser; - + FileNamePath: IPath; begin Result := true; Done := 0; @@ -579,7 +758,8 @@ begin Parser := TParser.Create; Parser.Settings.DashReplacement := '~'; - if Parser.ParseSong(self.Path + self.FileName) then + FileNamePath := Self.Path.Append(Self.FileName); + if Parser.ParseSong(FileNamePath) then begin //----------- //Required Attributes @@ -598,9 +778,9 @@ begin Done := Done or 2; //MP3 File //Test if Exists - self.Mp3 := platform.FindSongFile(Path, '*.mp3'); + Self.Mp3 := FindSongFile(Self.Path, '*.mp3'); //Add Mp3 Flag to Done - if (FileExists(self.Path + self.Mp3)) then + if (Self.Path.Append(Self.Mp3).IsFile()) then Done := Done or 4; //Beats per Minute @@ -621,16 +801,16 @@ begin self.GAP := Parser.SongInfo.Header.Gap; //Cover Picture - self.Cover := platform.FindSongFile(Path, '*[CO].jpg'); + self.Cover := FindSongFile(Path, '*[CO].jpg'); //Background Picture - self.Background := platform.FindSongFile(Path, '*[BG].jpg'); + self.Background := FindSongFile(Path, '*[BG].jpg'); // Video File // self.Video := Value // Video Gap - // self.VideoGAP := song_StrtoFloat( Value ) + // self.VideoGAP := StrtoFloatI18n( Value ) //Genre Sorting self.Genre := Parser.SongInfo.Header.Genre; @@ -645,7 +825,7 @@ begin self.Language := Parser.SongInfo.Header.Language; end else - Log.LogError('File Incomplete or not SingStar XML (A): ' + aFileName); + Log.LogError('File incomplete or not SingStar XML (A): ' + aFileName.ToNative); Parser.Free; @@ -654,220 +834,297 @@ begin begin Result := false; if (Done and 8) = 0 then //No BPM Flag - Log.LogError('BPM Tag Missing: ' + self.FileName) + Log.LogError('BPM tag missing: ' + self.FileName.ToNative) else if (Done and 4) = 0 then //No MP3 Flag - Log.LogError('MP3 Tag/File Missing: ' + self.FileName) + Log.LogError('MP3 tag/file missing: ' + self.FileName.ToNative) else if (Done and 2) = 0 then //No Artist Flag - Log.LogError('Artist Tag Missing: ' + self.FileName) + Log.LogError('Artist tag missing: ' + self.FileName.ToNative) else if (Done and 1) = 0 then //No Title Flag - Log.LogError('Title Tag Missing: ' + self.FileName) + Log.LogError('Title tag missing: ' + self.FileName.ToNative) else //unknown Error - Log.LogError('File Incomplete or not SingStar XML (B - '+ inttostr(Done) +'): ' + aFileName); + Log.LogError('File incomplete or not SingStar XML (B - '+ inttostr(Done) +'): ' + aFileName.ToNative); end; end; +{** + * "International" StrToFloat variant. Uses either ',' or '.' as decimal + * separator. + *} +function StrToFloatI18n(const Value: string): extended; +var + TempValue : string; +begin + TempValue := Value; + if (Pos(',', TempValue) <> 0) then + TempValue[Pos(',', TempValue)] := '.'; + Result := StrToFloatDef(TempValue, 0); +end; -function TSong.ReadTXTHeader(const aFileName : WideString): boolean; - - function song_StrtoFloat( aValue : string ) : extended; - - var - lValue : string; - +function TSong.ReadTXTHeader(SongFile: TTextFileStream; ReadCustomTags: Boolean): boolean; +var + Line, Identifier: string; + Value: string; + SepPos: integer; // separator position + Done: byte; // bit-vector of mandatory fields + EncFile: IPath; // encoded filename + FullFileName: string; + + { adds a custom header tag to the song + if there is no ':' in the read line, Tag should be empty + and the whole line should be in Content } + procedure AddCustomTag(const Tag, Content: String); + var Len: Integer; begin - lValue := aValue; - - if (Pos(',', lValue) <> 0) then - lValue[Pos(',', lValue)] := '.'; - - Result := StrToFloatDef(lValue, 0); + if ReadCustomTags then + begin + Len := Length(CustomTags); + SetLength(CustomTags, Len + 1); + CustomTags[Len].Tag := DecodeStringUTF8(Tag, Encoding); + CustomTags[Len].Content := DecodeStringUTF8(Content, Encoding); + end; end; - -var - Line, Identifier, Value: string; - Temp : word; - Done : byte; - begin Result := true; Done := 0; - //Read first Line - ReadLn (SongFile, Line); + FullFileName := Path.Append(Filename).ToNative; + //Read first Line + SongFile.ReadLine(Line); if (Length(Line) <= 0) then begin - Log.LogError('File Starts with Empty Line: ' + aFileName); + Log.LogError('File starts with empty line: ' + FullFileName, + 'TSong.ReadTXTHeader'); Result := false; Exit; end; + // check if file begins with a UTF-8 BOM, if so set encoding to UTF-8 + if (CheckReplaceUTF8BOM(Line)) then + Encoding := encUTF8; + //Read Lines while Line starts with # or its empty while (Length(Line) = 0) or (Line[1] = '#') do begin //Increase Line Number Inc (FileLineNo); - Temp := Pos(':', Line); + SepPos := Pos(':', Line); - //Line has a Seperator-> Headerline - if (Temp <> 0) then + //Line has no Seperator, ignore non header field + if (SepPos = 0) then begin - //Read Identifier and Value - Identifier := Uppercase(Trim(Copy(Line, 2, Temp - 2))); //Uppercase is for Case Insensitive Checks - Value := Trim(Copy(Line, Temp + 1,Length(Line) - Temp)); - - //Check the Identifier (If Value is given) - if (Length(Value) <> 0) then + AddCustomTag('', Copy(Line, 2, Length(Line) - 1)); + // read next line + if (not SongFile.ReadLine(Line)) then begin - //----------- - //Required Attributes - //----------- + Result := false; + Log.LogError('File incomplete or not Ultrastar txt (A): ' + FullFileName); + Break; + end; + Continue; + end; - {$IFDEF UTF8_FILENAMES} - if ((Identifier = 'MP3') or (Identifier = 'BACKGROUND') or (Identifier = 'COVER') or (Identifier = 'VIDEO')) then - Value := Utf8Encode(Value); - {$ENDIF} + //Read Identifier and Value + Identifier := UpperCase(Trim(Copy(Line, 2, SepPos - 2))); //Uppercase is for Case Insensitive Checks + Value := Trim(Copy(Line, SepPos + 1, Length(Line) - SepPos)); - //Title - if (Identifier = 'TITLE') then - begin - self.Title := Value; + //Check the Identifier (If Value is given) + if (Length(Value) = 0) then + begin + Log.LogInfo('Empty field "'+Identifier+'" in file ' + FullFileName, + 'TSong.ReadTXTHeader'); + AddCustomTag(Identifier, ''); + end + else + begin - //Add Title Flag to Done - Done := Done or 1; - end + //----------- + //Required Attributes + //----------- - //Artist - else if (Identifier = 'ARTIST') then - begin - self.Artist := Value; + if (Identifier = 'TITLE') then + begin + DecodeStringUTF8(Value, Title, Encoding); + //Add Title Flag to Done + Done := Done or 1; + end - //Add Artist Flag to Done - Done := Done or 2; - end + else if (Identifier = 'ARTIST') then + begin + DecodeStringUTF8(Value, Artist, Encoding); + //Add Artist Flag to Done + Done := Done or 2; + end - //MP3 File //Test if Exists - else if (Identifier = 'MP3') and (FileExists(self.Path + Value)) then + //MP3 File + else if (Identifier = 'MP3') then + begin + EncFile := DecodeFilename(Value); + if (Self.Path.Append(EncFile).IsFile) then begin - self.Mp3 := Value; + self.Mp3 := EncFile; //Add Mp3 Flag to Done Done := Done or 4; - end + end; + end + + //Beats per Minute + else if (Identifier = 'BPM') then + begin + SetLength(self.BPM, 1); + self.BPM[0].StartBeat := 0; - //Beats per Minute - else if (Identifier = 'BPM') then + self.BPM[0].BPM := StrToFloatI18n( Value ) * Mult * MultBPM; + + if self.BPM[0].BPM <> 0 then begin - SetLength(self.BPM, 1); - self.BPM[0].StartBeat := 0; + //Add BPM Flag to Done + Done := Done or 8; + end; + end - self.BPM[0].BPM := song_StrtoFloat( Value ) * Mult * MultBPM; + //--------- + //Additional Header Information + //--------- - if self.BPM[0].BPM <> 0 then - begin - //Add BPM Flag to Done - Done := Done or 8; - end; - end + // Gap + else if (Identifier = 'GAP') then + begin + self.GAP := StrToFloatI18n(Value); + end - //--------- - //Additional Header Information - //--------- + //Cover Picture + else if (Identifier = 'COVER') then + begin + self.Cover := DecodeFilename(Value); + end - // Gap - else if (Identifier = 'GAP') then - self.GAP := song_StrtoFloat( Value ) + //Background Picture + else if (Identifier = 'BACKGROUND') then + begin + self.Background := DecodeFilename(Value); + end - //Cover Picture - else if (Identifier = 'COVER') then - self.Cover := Value + // Video File + else if (Identifier = 'VIDEO') then + begin + EncFile := DecodeFilename(Value); + if (self.Path.Append(EncFile).IsFile) then + self.Video := EncFile + else + Log.LogError('Can''t find video file in song: ' + FullFileName); + end - //Background Picture - else if (Identifier = 'BACKGROUND') then - self.Background := Value + // Video Gap + else if (Identifier = 'VIDEOGAP') then + begin + self.VideoGAP := StrToFloatI18n( Value ) + end - // Video File - else if (Identifier = 'VIDEO') then - begin - if (FileExists(self.Path + Value)) then - self.Video := Value - else - Log.LogError('Can''t find Video File in Song: ' + aFileName); - end + //Genre Sorting + else if (Identifier = 'GENRE') then + begin + DecodeStringUTF8(Value, Genre, Encoding) + end - // Video Gap - else if (Identifier = 'VIDEOGAP') then - self.VideoGAP := song_StrtoFloat( Value ) + //Edition Sorting + else if (Identifier = 'EDITION') then + begin + DecodeStringUTF8(Value, Edition, Encoding) + end - //Genre Sorting - else if (Identifier = 'GENRE') then - self.Genre := Value + //Creator Tag + else if (Identifier = 'CREATOR') then + begin + DecodeStringUTF8(Value, Creator, Encoding) + end - //Edition Sorting - else if (Identifier = 'EDITION') then - self.Edition := Value + //Language Sorting + else if (Identifier = 'LANGUAGE') then + begin + DecodeStringUTF8(Value, Language, Encoding) + end - //Creator Tag - else if (Identifier = 'CREATOR') then - self.Creator := Value + //Language Sorting + else if (Identifier = 'YEAR') then + begin + TryStrtoInt(Value, self.Year) + end - //Language Sorting - else if (Identifier = 'LANGUAGE') then - self.Language := Value + // Song Start + else if (Identifier = 'START') then + begin + self.Start := StrToFloatI18n( Value ) + end - // Song Start - else if (Identifier = 'START') then - self.Start := song_StrtoFloat( Value ) + // Song Ending + else if (Identifier = 'END') then + begin + TryStrtoInt(Value, self.Finish) + end - // Song Ending - else if (Identifier = 'END') then - TryStrtoInt(Value, self.Finish) + // Resolution + else if (Identifier = 'RESOLUTION') then + begin + TryStrtoInt(Value, self.Resolution) + end - // Resolution - else if (Identifier = 'RESOLUTION') then - TryStrtoInt(Value, self.Resolution) + // Notes Gap + else if (Identifier = 'NOTESGAP') then + begin + TryStrtoInt(Value, self.NotesGAP) + end - // Notes Gap - else if (Identifier = 'NOTESGAP') then - TryStrtoInt(Value, self.NotesGAP) - // Relative Notes - else if (Identifier = 'RELATIVE') and (uppercase(Value) = 'YES') then + // Relative Notes + else if (Identifier = 'RELATIVE') then + begin + if (UpperCase(Value) = 'YES') then self.Relative := true; + end + // File encoding + else if (Identifier = 'ENCODING') then + begin + self.Encoding := ParseEncoding(Value, DEFAULT_ENCODING); + end + + // unsupported tag + else + begin + AddCustomTag(Identifier, Value); end; - end; - if not EOF(SongFile) then - ReadLn (SongFile, Line) - else + end; // End check for non-empty Value + + // read next line + if (not SongFile.ReadLine(Line)) then begin Result := false; - Log.LogError('File Incomplete or not Ultrastar TxT (A): ' + aFileName); - break; + Log.LogError('File incomplete or not Ultrastar txt (A): ' + FullFileName); + Break; end; + end; // while - end; - - if self.Cover = '' then - self.Cover := platform.FindSongFile(Path, '*[CO].jpg'); + if self.Cover.IsUnset then + self.Cover := FindSongFile(Path, '*[CO].jpg'); //Check if all Required Values are given if (Done <> 15) then begin Result := false; if (Done and 8) = 0 then //No BPM Flag - Log.LogError('BPM Tag Missing: ' + self.FileName) + Log.LogError('BPM tag missing: ' + FullFileName) else if (Done and 4) = 0 then //No MP3 Flag - Log.LogError('MP3 Tag/File Missing: ' + self.FileName) + Log.LogError('MP3 tag/file missing: ' + FullFileName) else if (Done and 2) = 0 then //No Artist Flag - Log.LogError('Artist Tag Missing: ' + self.FileName) + Log.LogError('Artist tag missing: ' + FullFileName) else if (Done and 1) = 0 then //No Title Flag - Log.LogError('Title Tag Missing: ' + self.FileName) + Log.LogError('Title tag missing: ' + FullFileName) else //unknown Error - Log.LogError('File Incomplete or not Ultrastar TxT (B - '+ inttostr(Done) +'): ' + aFileName); + Log.LogError('File incomplete or not Ultrastar txt (B - '+ inttostr(Done) +'): ' + FullFileName); end; - end; function TSong.GetErrorLineNo: integer; @@ -878,48 +1135,8 @@ begin Result := -1; end; -procedure TSong.ParseNote(LineNumber: integer; TypeP: char; StartP, DurationP, NoteP: integer; LyricS: string); - +procedure TSong.ParseNote(LineNumber: integer; TypeP: char; StartP, DurationP, NoteP: integer; LyricS: UTF8String); begin - case Ini.Solmization of - 1: // european - begin - case (NoteP mod 12) of - 0..1: LyricS := ' do '; - 2..3: LyricS := ' re '; - 4: LyricS := ' mi '; - 5..6: LyricS := ' fa '; - 7..8: LyricS := ' sol '; - 9..10: LyricS := ' la '; - 11: LyricS := ' si '; - end; - end; - 2: // japanese - begin - case (NoteP mod 12) of - 0..1: LyricS := ' do '; - 2..3: LyricS := ' re '; - 4: LyricS := ' mi '; - 5..6: LyricS := ' fa '; - 7..8: LyricS := ' so '; - 9..10: LyricS := ' la '; - 11: LyricS := ' shi '; - end; - end; - 3: // american - begin - case (NoteP mod 12) of - 0..1: LyricS := ' do '; - 2..3: LyricS := ' re '; - 4: LyricS := ' mi '; - 5..6: LyricS := ' fa '; - 7..8: LyricS := ' sol '; - 9..10: LyricS := ' la '; - 11: LyricS := ' ti '; - end; - end; - end; // case - with Lines[LineNumber].Line[Lines[LineNumber].High] do begin SetLength(Note, Length(Note) + 1); @@ -956,14 +1173,9 @@ begin if Note[HighNote].Tone < BaseNote then BaseNote := Note[HighNote].Tone; - //delete the space that seperates the notes pitch from its lyrics - //it is left in the LyricS string because Read("some ordinal type") will - //set the files pointer to the first whitespace character after the - //ordinal string. Trim is no solution because it would cut the spaces - //that seperate the words of the lyrics, too. - Delete(LyricS, 1, 1); + Note[HighNote].Color := 1; // default color to 1 for editor - Note[HighNote].Text := LyricS; + DecodeStringUTF8(LyricS, Note[HighNote].Text, Encoding); Lyric := Lyric + Note[HighNote].Text; End_ := Note[HighNote].Start + Note[HighNote].Length; @@ -971,10 +1183,8 @@ begin end; procedure TSong.NewSentence(LineNumberP: integer; Param1, Param2: integer); - var I: integer; - begin if (Lines[LineNumberP].Line[Lines[LineNumberP].High].HighNote <> -1) then @@ -985,7 +1195,8 @@ begin end else begin //use old line if it there were no notes added since last call of NewSentence - Log.LogError('Error loading Song, sentence w/o note found in line ' + InttoStr(FileLineNo) + ': ' + Filename); + Log.LogError('Error loading Song, sentence w/o note found in line ' + + InttoStr(FileLineNo) + ': ' + Filename.ToNative); end; Lines[LineNumberP].Line[Lines[LineNumberP].High].HighNote := -1; @@ -1012,8 +1223,7 @@ begin Lines[LineNumberP].Line[Lines[LineNumberP].High].LastLine := false; end; -procedure TSong.clear(); - +procedure TSong.Clear(); begin //Main Information Title := ''; @@ -1022,24 +1232,27 @@ begin //Sortings: Genre := 'Unknown'; Edition := 'Unknown'; - Language := 'Unknown'; //Language Patch + Language := 'Unknown'; + Year := 0; + + // set to default encoding + Encoding := DEFAULT_ENCODING; + + // clear custom header tags + SetLength(CustomTags, 0); //Required Information - Mp3 := ''; - {$IFDEF FPC} - setlength( BPM, 0 ); - {$ELSE} - BPM := nil; - {$ENDIF} + Mp3 := PATH_NONE; + SetLength(BPM, 0); GAP := 0; Start := 0; Finish := 0; //Additional Information - Background := ''; - Cover := ''; - Video := ''; + Background := PATH_NONE; + Cover := PATH_NONE; + Video := PATH_NONE; VideoGAP := 0; NotesGAP := 0; Resolution := 4; @@ -1048,8 +1261,9 @@ begin Relative := false; end; -function TSong.Analyse(): boolean; - +function TSong.Analyse(const ReadCustomTags: Boolean): boolean; +var + SongFile: TTextFileStream; begin Result := false; @@ -1057,20 +1271,15 @@ begin FileLineNo := 0; //Open File and set File Pointer to the beginning - AssignFile(SongFile, self.Path + self.FileName); - + SongFile := TMemTextFileStream.Create(Self.Path.Append(Self.FileName), fmOpenRead); try - Reset(SongFile); - //Clear old Song Header - self.clear; + Self.clear; //Read Header - Result := self.ReadTxTHeader( FileName ) - - //And Close File + Result := Self.ReadTxTHeader(SongFile, ReadCustomTags) finally - CloseFile(SongFile); + SongFile.Free; end; end; diff --git a/cmake/src/base/USongs.pas b/cmake/src/base/USongs.pas index a7231cb3..cfc32a99 100644 --- a/cmake/src/base/USongs.pas +++ b/cmake/src/base/USongs.pas @@ -40,32 +40,36 @@ interface {$ENDIF} uses + SysUtils, + Classes, {$IFDEF MSWINDOWS} Windows, DirWatch, {$ELSE} {$IFNDEF DARWIN} - syscall, + syscall, {$ENDIF} baseunix, UnixType, {$ENDIF} - SysUtils, - Classes, UPlatform, ULog, UTexture, UCommon, - {$IFDEF DARWIN} - cthreads, - {$ENDIF} {$IFDEF USE_PSEUDO_THREAD} - PseudoThread, + PseudoThread, {$ENDIF} + UPath, USong, + UIni, UCatCovers; type + TSongFilter = ( + fltAll, + fltTitle, + fltArtist + ); TBPM = record BPM: real; @@ -73,11 +77,13 @@ type end; TScore = record - Name: widestring; + Name: UTF8String; Score: integer; Length: string; end; + TPathDynArray = array of IPath; + {$IFDEF USE_PSEUDO_THREAD} TSongs = class(TPseudoThread) {$ELSE} @@ -102,11 +108,11 @@ type procedure LoadSongList; // load all songs - procedure BrowseDir(Dir: widestring); // should return number of songs in the future - procedure BrowseTXTFiles(Dir: widestring); - procedure BrowseXMLFiles(Dir: widestring); - procedure Sort(Order: integer); - function FindSongFile(Dir, Mask: widestring): widestring; + procedure FindFilesByExtension(const Dir: IPath; const Ext: IPath; Recursive: Boolean; var Files: TPathDynArray); + procedure BrowseDir(Dir: IPath); // should return number of songs in the future + procedure BrowseTXTFiles(Dir: IPath); + procedure BrowseXMLFiles(Dir: IPath); + procedure Sort(Order: TSortingType); property Processing: boolean read fProcessing; end; @@ -128,7 +134,7 @@ type 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; + function SetFilter(FilterStr: UTF8String; Filter: TSongFilter): cardinal; end; var @@ -156,9 +162,11 @@ uses UCovers, UFiles, UGraphic, - UIni, - UPath, - UNote; + UMain, + UPathUtils, + UNote, + UFilesystem, + UUnicodeUtils; constructor TSongs.Create(); begin @@ -232,7 +240,7 @@ begin // browse directories for I := 0 to SongPaths.Count-1 do - BrowseDir(SongPaths[I]); + BrowseDir(SongPaths[I] as IPath); if assigned(CatSongs) then CatSongs.Refresh; @@ -264,84 +272,92 @@ begin Resume(); end; -procedure TSongs.BrowseDir(Dir: widestring); +procedure TSongs.BrowseDir(Dir: IPath); begin BrowseTXTFiles(Dir); BrowseXMLFiles(Dir); end; -procedure TSongs.BrowseTXTFiles(Dir: widestring); +procedure TSongs.FindFilesByExtension(const Dir: IPath; const Ext: IPath; Recursive: Boolean; var Files: TPathDynArray); var - i: integer; - Files: TDirectoryEntryArray; - lSong: TSong; + Iter: IFileIterator; + FileInfo: TFileInfo; + FileName: IPath; begin - - try - Files := Platform.DirectoryFindFiles(Dir, '.txt', true) - except - Log.LogError('Couldn''t deal with directory/file: ' + Dir + ' in TSongs.BrowseTXTFiles') - end; - - for i := 0 to Length(Files) - 1 do + // search for all files and directories + Iter := FileSystem.FileFind(Dir.Append('*'), faAnyFile); + while (Iter.HasNext) do begin - if Files[i].IsDirectory then + FileInfo := Iter.Next; + FileName := FileInfo.Name; + if ((FileInfo.Attr and faDirectory) <> 0) then begin - BrowseTXTFiles(Dir + Files[i].Name + PathDelim); //Recursive Call + if Recursive and (not FileName.Equals('.')) and (not FileName.Equals('..')) then + FindFilesByExtension(Dir.Append(FileName), Ext, true, Files); end else begin - lSong := TSong.create(Dir + Files[i].Name); - - if lSong.Analyse then - SongList.add(lSong) - else + if (Ext.Equals(FileName.GetExtension(), true)) then begin - Log.LogError('AnalyseFile failed for "' + Files[i].Name + '".'); - freeandnil(lSong); + SetLength(Files, Length(Files)+1); + Files[High(Files)] := Dir.Append(FileName); end; - end; end; - SetLength(Files, 0); - end; -procedure TSongs.BrowseXMLFiles(Dir: widestring); +procedure TSongs.BrowseTXTFiles(Dir: IPath); var - i: integer; - Files: TDirectoryEntryArray; - lSong: TSong; + I: integer; + Files: TPathDynArray; + Song: TSong; + Extension: IPath; begin + SetLength(Files, 0); + Extension := Path('.txt'); + FindFilesByExtension(Dir, Extension, true, Files); - try - Files := Platform.DirectoryFindFiles(Dir, '.xml', true) - except - Log.LogError('Couldn''t deal with directory/file: ' + Dir + ' in TSongs.BrowseXMLFiles') - end; - - for i := 0 to Length(Files) - 1 do + for I := 0 to High(Files) do begin - if Files[i].IsDirectory then - begin - BrowseXMLFiles(Dir + Files[i].Name + PathDelim); // Recursive Call - end + Song := TSong.Create(Files[I]); + + if Song.Analyse then + SongList.Add(Song) else begin - lSong := TSong.create(Dir + Files[i].Name); + Log.LogError('AnalyseFile failed for "' + Files[I].ToNative + '".'); + FreeAndNil(Song); + end; + end; - if lSong.AnalyseXML then - SongList.add(lSong) - else - begin - Log.LogError('AnalyseFile failed for "' + Files[i].Name + '".'); - freeandnil(lSong); - end; + SetLength(Files, 0); +end; +procedure TSongs.BrowseXMLFiles(Dir: IPath); +var + I: integer; + Files: TPathDynArray; + Song: TSong; + Extension: IPath; +begin + SetLength(Files, 0); + Extension := Path('.xml'); + FindFilesByExtension(Dir, Extension, true, Files); + + for I := 0 to High(Files) do + begin + Song := TSong.Create(Files[I]); + + if Song.AnalyseXML then + SongList.Add(Song) + else + begin + Log.LogError('AnalyseFile failed for "' + Files[I].ToNative + '".'); + FreeAndNil(Song); end; end; - SetLength(Files, 0); + SetLength(Files, 0); end; (* @@ -350,35 +366,35 @@ end; function CompareByEdition(Song1, Song2: Pointer): integer; begin - Result := CompareText(TSong(Song1).Edition, TSong(Song2).Edition); + Result := UTF8CompareText(TSong(Song1).Edition, TSong(Song2).Edition); end; function CompareByGenre(Song1, Song2: Pointer): integer; begin - Result := CompareText(TSong(Song1).Genre, TSong(Song2).Genre); + Result := UTF8CompareText(TSong(Song1).Genre, TSong(Song2).Genre); end; function CompareByTitle(Song1, Song2: Pointer): integer; begin - Result := CompareText(TSong(Song1).Title, TSong(Song2).Title); + Result := UTF8CompareText(TSong(Song1).Title, TSong(Song2).Title); end; function CompareByArtist(Song1, Song2: Pointer): integer; begin - Result := CompareText(TSong(Song1).Artist, TSong(Song2).Artist); + Result := UTF8CompareText(TSong(Song1).Artist, TSong(Song2).Artist); end; function CompareByFolder(Song1, Song2: Pointer): integer; begin - Result := CompareText(TSong(Song1).Folder, TSong(Song2).Folder); + Result := UTF8CompareText(TSong(Song1).Folder, TSong(Song2).Folder); end; function CompareByLanguage(Song1, Song2: Pointer): integer; begin - Result := CompareText(TSong(Song1).Language, TSong(Song2).Language); + Result := UTF8CompareText(TSong(Song1).Language, TSong(Song2).Language); end; -procedure TSongs.Sort(Order: integer); +procedure TSongs.Sort(Order: TSortingType); var CompareFunc: TListSortCompare; begin @@ -394,8 +410,6 @@ begin CompareFunc := CompareByArtist; sFolder: // by folder CompareFunc := CompareByFolder; - sTitle2: // by title2 - CompareFunc := CompareByTitle; sArtist2: // by artist2 CompareFunc := CompareByArtist; sLanguage: // by Language @@ -412,21 +426,9 @@ begin MergeSort(SongList, CompareFunc); 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.SortSongs(); begin - case Ini.Sorting of + case TSortingType(Ini.Sorting) of sEdition: begin Songs.Sort(sTitle); Songs.Sort(sArtist); @@ -454,12 +456,8 @@ begin Songs.Sort(sTitle); Songs.Sort(sArtist); end; - sTitle2: begin - Songs.Sort(sArtist2); - Songs.Sort(sTitle2); - end; sArtist2: begin - Songs.Sort(sTitle2); + Songs.Sort(sTitle); Songs.Sort(sArtist2); end; end; // case @@ -469,14 +467,14 @@ procedure TCatSongs.Refresh; var SongIndex: integer; CurSong: TSong; - CatIndex: integer; // index of current song in Song - Letter: char; // current letter for sorting using letter - CurCategory: string; // current edition for sorting using edition, genre etc. - Order: integer; // number used for ordernum - LetterTmp: char; - CatNumber: integer; // Number of Song in Category - - procedure AddCategoryButton(const CategoryName: string); + CatIndex: integer; // index of current song in Song + Letter: UCS4Char; // current letter for sorting using letter + CurCategory: UTF8String; // current edition for sorting using edition, genre etc. + Order: integer; // number used for ordernum + LetterTmp: UCS4Char; + CatNumber: integer; // Number of Song in Category + + procedure AddCategoryButton(const CategoryName: UTF8String); var PrevCatBtnIndex: integer; begin @@ -488,7 +486,7 @@ var Song[CatIndex].Main := true; Song[CatIndex].OrderTyp := 0; Song[CatIndex].OrderNum := Order; - Song[CatIndex].Cover := CatCovers.GetCover(Ini.Sorting, CategoryName); + Song[CatIndex].Cover := CatCovers.GetCover(TSortingType(Ini.Sorting), CategoryName); Song[CatIndex].Visible := true; // set number of songs in previous category @@ -511,7 +509,7 @@ begin // Note: do NOT set Letter to ' ', otherwise no category-button will be // created for songs beginning with ' ' if songs of this category exist. // TODO: trim song-properties so ' ' will not occur as first chararcter. - Letter := #0; + Letter := 0; // clear song-list for SongIndex := 0 to Songs.SongList.Count - 1 do @@ -530,101 +528,102 @@ begin // if tabs are on, add section buttons for each new section if (Ini.Tabs = 1) then begin - if (Ini.Sorting = sEdition) and - (CompareText(CurCategory, CurSong.Edition) <> 0) then - begin - CurCategory := CurSong.Edition; - - // TODO: remove this block if it is not needed anymore - { - if CurSection = 'Singstar Part 2' then CoverName := 'Singstar'; - if CurSection = 'Singstar German' then CoverName := 'Singstar'; - if CurSection = 'Singstar Spanish' then CoverName := 'Singstar'; - if CurSection = 'Singstar Italian' then CoverName := 'Singstar'; - if CurSection = 'Singstar French' then CoverName := 'Singstar'; - if CurSection = 'Singstar 80s Polish' then CoverName := 'Singstar 80s'; - } - - // add Category Button - AddCategoryButton(CurCategory); - end - - else if (Ini.Sorting = sGenre) and - (CompareText(CurCategory, CurSong.Genre) <> 0) then - begin - CurCategory := CurSong.Genre; - // add Genre Button - AddCategoryButton(CurCategory); - end - - else if (Ini.Sorting = sLanguage) and - (CompareText(CurCategory, CurSong.Language) <> 0) then - begin - CurCategory := CurSong.Language; - // add Language Button - AddCategoryButton(CurCategory); - end - - else if (Ini.Sorting = sTitle) and - (Length(CurSong.Title) >= 1) and - (Letter <> UpperCase(CurSong.Title)[1]) then - begin - Letter := Uppercase(CurSong.Title)[1]; - // add a letter Category Button - AddCategoryButton(Letter); - end + case (TSortingType(Ini.Sorting)) of + sEdition: begin + if (CompareText(CurCategory, CurSong.Edition) <> 0) then + begin + CurCategory := CurSong.Edition; + + // add Category Button + AddCategoryButton(CurCategory); + end; + end; - else if (Ini.Sorting = sArtist) and - (Length(CurSong.Artist) >= 1) and - (Letter <> UpperCase(CurSong.Artist)[1]) then - begin - Letter := UpperCase(CurSong.Artist)[1]; - // add a letter Category Button - AddCategoryButton(Letter); - end + sGenre: begin + if (CompareText(CurCategory, CurSong.Genre) <> 0) then + begin + CurCategory := CurSong.Genre; + // add Genre Button + AddCategoryButton(CurCategory); + end; + end; - else if (Ini.Sorting = sFolder) and - (CompareText(CurCategory, CurSong.Folder) <> 0) then - begin - CurCategory := CurSong.Folder; - // add folder tab - AddCategoryButton(CurCategory); - end + sLanguage: begin + if (CompareText(CurCategory, CurSong.Language) <> 0) then + begin + CurCategory := CurSong.Language; + // add Language Button + AddCategoryButton(CurCategory); + end + end; - else if (Ini.Sorting = sTitle2) and - (Length(CurSong.Title) >= 1) then - begin - // pack all numbers into a category named '#' - if (CurSong.Title[1] >= '0') and (CurSong.Title[1] <= '9') then - LetterTmp := '#' - else - LetterTmp := UpperCase(CurSong.Title)[1]; + sTitle: begin + if (Length(CurSong.Title) >= 1) then + begin + LetterTmp := UCS4UpperCase(UTF8ToUCS4String(CurSong.Title)[0]); + { all numbers and some punctuation chars are put into a + category named '#' + we can't put the other punctuation chars into this category + because they are not in order, so there will be two different + categories named '#' } + if (LetterTmp in [Ord('!') .. Ord('?')]) then + LetterTmp := Ord('#') + else + LetterTmp := UCS4UpperCase(LetterTmp); + if (Letter <> LetterTmp) then + begin + Letter := LetterTmp; + // add a letter Category Button + AddCategoryButton(UCS4ToUTF8String(Letter)); + end; + end; + end; - if (Letter <> LetterTmp) then - begin - Letter := LetterTmp; - // add a letter Category Button - AddCategoryButton(Letter); + sArtist: begin + if (Length(CurSong.Artist) >= 1) then + begin + LetterTmp := UCS4UpperCase(UTF8ToUCS4String(CurSong.Artist)[0]); + { all numbers and some punctuation chars are put into a + category named '#' + we can't put the other punctuation chars into this category + because they are not in order, so there will be two different + categories named '#' } + if (LetterTmp in [Ord('!') .. Ord('?')]) then + LetterTmp := Ord('#') + else + LetterTmp := UCS4UpperCase(LetterTmp); + + if (Letter <> LetterTmp) then + begin + Letter := LetterTmp; + // add a letter Category Button + AddCategoryButton(UCS4ToUTF8String(Letter)); + end; + end; end; - end - else if (Ini.Sorting = sArtist2) and - (Length(CurSong.Artist)>=1) then - begin - // pack all numbers into a category named '#' - if (CurSong.Artist[1] >= '0') and (CurSong.Artist[1] <= '9') then - LetterTmp := '#' - else - LetterTmp := UpperCase(CurSong.Artist)[1]; + sFolder: begin + if (UTF8CompareText(CurCategory, CurSong.Folder) <> 0) then + begin + CurCategory := CurSong.Folder; + // add folder tab + AddCategoryButton(CurCategory); + end; + end; - if (Letter <> LetterTmp) then - begin - Letter := LetterTmp; - // add a letter Category Button - AddCategoryButton(Letter); + sArtist2: begin + { this new sorting puts all songs by the same artist into + a single category } + if (UTF8CompareText(CurCategory, CurSong.Artist) <> 0) then + begin + CurCategory := CurSong.Artist; + // add folder tab + AddCategoryButton(CurCategory); + end; end; - end; - end; + + end; // case (Ini.Sorting) + end; // if (Ini.Tabs = 1) CatIndex := Length(Song); SetLength(Song, CatIndex+1); @@ -728,14 +727,18 @@ var I: integer; begin Result := -1; - I := SearchFrom + 1; - while not CatSongs.Song[I].Visible do + I := SearchFrom; + while (Result = -1) do begin Inc (I); - if (I>high(CatSongs.Song)) then - I := low(CatSongs.Song); + + if (I > High(CatSongs.Song)) then + I := Low(CatSongs.Song); if (I = SearchFrom) then // Make One Round and no song found->quit - break; + Break; + + if (CatSongs.Song[I].Visible) then + Result := I; end; end; // Wrong song selected when tabs on bug End @@ -771,58 +774,58 @@ begin end; end; -function TCatSongs.SetFilter(FilterStr: string; const fType: byte): cardinal; +function TCatSongs.SetFilter(FilterStr: UTF8String; Filter: TSongFilter): cardinal; var I, J: integer; - cString: string; - SearchStr: array of string; + TmpString: UTF8String; + WordArray: array of UTF8String; begin -{ - fType: 0: All - 1: Title - 2: Artist -} FilterStr := Trim(FilterStr); - if FilterStr<>'' then + if (FilterStr <> '') then begin Result := 0; - // Create Search Array - SetLength(SearchStr, 1); + + // initialize word array + SetLength(WordArray, 1); + + // Copy words to SearchStr 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); + WordArray[High(WordArray)] := Copy(FilterStr, 1, I-1); + SetLength(WordArray, Length(WordArray) + 1); - I := Pos (' ', FilterStr); + FilterStr := TrimLeft(Copy(FilterStr, I+1, Length(FilterStr)-I)); + I := Pos(' ', FilterStr); end; - // Copy last Word - if (FilterStr <> ' ') and (FilterStr <> '') then - SearchStr[High(SearchStr)] := FilterStr; + + // Copy last word + WordArray[High(WordArray)] := 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; + case Filter of + fltAll: + TmpString := Song[I].Artist + ' ' + Song[i].Title + ' ' + Song[i].Folder; + fltTitle: + TmpString := Song[I].Title; + fltArtist: + TmpString := Song[I].Artist; end; - Song[i].Visible:=true; - // Look for every Searched Word - for J := 0 to High(SearchStr) do + Song[i].Visible := true; + // Look for every searched word + for J := 0 to High(WordArray) do begin - Song[i].Visible := Song[i].Visible and AnsiContainsText(cString, SearchStr[J]) + Song[i].Visible := Song[i].Visible and + UTF8ContainsText(TmpString, WordArray[J]) end; if Song[i].Visible then Inc(Result); end else - Song[i].Visible:=false; + Song[i].Visible := false; end; CatNumShow := -2; end @@ -830,7 +833,7 @@ begin begin for i := 0 to High(Song) do begin - Song[i].Visible := (Ini.Tabs=1) = Song[i].Main; + Song[i].Visible := (Ini.Tabs = 1) = Song[i].Main; CatNumShow := -1; end; Result := 0; diff --git a/cmake/src/base/UTextEncoding.pas b/cmake/src/base/UTextEncoding.pas index 6eec8eec..0c9ba4cc 100644 --- a/cmake/src/base/UTextEncoding.pas +++ b/cmake/src/base/UTextEncoding.pas @@ -19,8 +19,8 @@ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, * Boston, MA 02110-1301, USA. * - * $URL: https://ultrastardx.svn.sourceforge.net/svnroot/ultrastardx/trunk/src/menu/UMenuText.pas $ - * $Id: UMenuText.pas 1485 2008-10-28 20:16:05Z tobigun $ + * $URL$ + * $Id$ *} unit UTextEncoding; @@ -34,114 +34,215 @@ interface {$I switches.inc} uses - SysUtils; + SysUtils, + UUnicodeUtils; type - TEncoding = (encCP1250, encCP1252, encUTF8, encNative); + TEncoding = ( + encLocale, // current locale (needs cwstring on linux) + encUTF8, // UTF-8 + encCP1250, // Windows-1250 Central/Eastern Europe (used by Ultrastar) + encCP1252, // Windows-1252 Western Europe (used by UltraStar Deluxe < 1.1) + encAuto // try to match the w3c regex and decode as unicode on match + // and as fallback if not match + ); + +const + UTF8_BOM: UTF8String = #$EF#$BB#$BF; + +{** + * Decodes Src encoded in SrcEncoding to a UTF-16 or UTF-8 encoded Dst string. + * Returns true if the conversion was successful. + *} +function DecodeString(const Src: RawByteString; out Dst: WideString; SrcEncoding: TEncoding): boolean; overload; +function DecodeString(const Src: RawByteString; SrcEncoding: TEncoding): WideString; overload; +function DecodeStringUTF8(const Src: RawByteString; out Dst: UTF8String; SrcEncoding: TEncoding): boolean; overload; +function DecodeStringUTF8(const Src: RawByteString; SrcEncoding: TEncoding): UTF8String; overload; + +{** + * Encodes the UTF-16 or UTF-8 encoded Src string to Dst using DstEncoding + * Returns true if the conversion was successful. + *} +function EncodeString(const Src: WideString; out Dst: RawByteString; DstEncoding: TEncoding): boolean; overload; +function EncodeString(const Src: WideString; DstEncoding: TEncoding): RawByteString; overload; +function EncodeStringUTF8(const Src: UTF8String; out Dst: RawByteString; DstEncoding: TEncoding): boolean; overload; +function EncodeStringUTF8(const Src: UTF8String; DstEncoding: TEncoding): RawByteString; overload; + +{** + * If Text starts with an UTF-8 BOM, the BOM is removed and true will + * be returned. + *} +function CheckReplaceUTF8BOM(var Text: RawByteString): boolean; -function RecodeString(const Src: string; SrcEncoding: TEncoding): WideString; +{** + * Parses an encoding string to its TEncoding equivalent. + * Surrounding whitespace and dashes ('-') are removed, the upper-cased + * resulting value is then compared with TEncodingNames. + * If the encoding was not found, the result is set to the Default encoding. + *} +function ParseEncoding(const EncodingStr: AnsiString; Default: TEncoding): TEncoding; + +{** + * Returns the name of an encoding. + *} +function EncodingName(Encoding: TEncoding): AnsiString; implementation +uses + StrUtils, + pcre, + UCommon, + ULog; + type - TConversionTable = array[0..127] of WideChar; + IEncoder = interface + function GetName(): AnsiString; + function Encode(const InStr: UCS4String; out OutStr: RawByteString): boolean; + function Decode(const InStr: RawByteString; out OutStr: UCS4String): boolean; + end; + + TEncoder = class(TInterfacedObject, IEncoder) + public + function GetName(): AnsiString; virtual; abstract; + function Encode(const InStr: UCS4String; out OutStr: RawByteString): boolean; virtual; abstract; + function Decode(const InStr: RawByteString; out OutStr: UCS4String): boolean; virtual; abstract; + end; + + TSingleByteEncoder = class(TEncoder) + public + function Encode(const InStr: UCS4String; out OutStr: RawByteString): boolean; override; + function Decode(const InStr: RawByteString; out OutStr: UCS4String): boolean; override; + function DecodeChar(InChr: AnsiChar; out OutChr: UCS4Char): boolean; virtual; abstract; + function EncodeChar(InChr: UCS4Char; out OutChr: AnsiChar): boolean; virtual; abstract; + end; const - // Windows-1250 Central/Eastern Europe (used by Ultrastar) - CP1250Table: TConversionTable = ( - { $80 } - #$20AC, #0, #$201A, #0, #$201E, #$2026, #$2020, #$2021, - #0, #$2030, #$0160, #$2039, #$015A, #$0164, #$017D, #$0179, - { $90 } - #0, #$2018, #$2019, #$201C, #$201D, #$2022, #$2013, #$2014, - #0, #$2122, #$0161, #$203A, #$015B, #$0165, #$017E, #$017A, - { $A0 } - #$00A0, #$02C7, #$02D8, #$0141, #$00A4, #$0104, #$00A6, #$00A7, - #$00A8, #$00A9, #$015E, #$00AB, #$00AC, #$00AD, #$00AE, #$017B, - { $B0 } - #$00B0, #$00B1, #$02DB, #$0142, #$00B4, #$00B5, #$00B6, #$00B7, - #$00B8, #$0105, #$015F, #$00BB, #$013D, #$02DD, #$013E, #$017C, - { $C0 } - #$0154, #$00C1, #$00C2, #$0102, #$00C4, #$0139, #$0106, #$00C7, - #$010C, #$00C9, #$0118, #$00CB, #$011A, #$00CD, #$00CE, #$010E, - { $D0 } - #$0110, #$0143, #$0147, #$00D3, #$00D4, #$0150, #$00D6, #$00D7, - #$0158, #$016E, #$00DA, #$0170, #$00DC, #$00DD, #$0162, #$00DF, - { $E0 } - #$0155, #$00E1, #$00E2, #$0103, #$00E4, #$013A, #$0107, #$00E7, - #$010D, #$00E9, #$0119, #$00EB, #$011B, #$00ED, #$00EE, #$010F, - { $F0 } - #$0111, #$0144, #$0148, #$00F3, #$00F4, #$0151, #$00F6, #$00F7, - #$0159, #$016F, #$00FA, #$0171, #$00FC, #$00FD, #$0163, #$02D9 - ); + ERROR_CHAR = '?'; - // Windows-1252 Western Europe (used by UltraStar Deluxe < 1.1) - CP1252Table: TConversionTable = ( - { $80 } - #$20AC, #0, #$201A, #$0192, #$201E, #$2026, #$2020, #$2021, - #$02C6, #$2030, #$0160, #$2039, #$0152, #0, #$017D, #0, - { $90 } - #0, #$2018, #$2019, #$201C, #$201D, #$2022, #$2013, #$2014, - #$02DC, #$2122, #$0161, #$203A, #$0153, #0, #$017E, #$0178, - { $A0 } - #$00A0, #$00A1, #$00A2, #$00A3, #$00A4, #$00A5, #$00A6, #$00A7, - #$00A8, #$00A9, #$00AA, #$00AB, #$00AC, #$00AD, #$00AE, #$00AF, - { $B0 } - #$00B0, #$00B1, #$00B2, #$00B3, #$00B4, #$00B5, #$00B6, #$00B7, - #$00B8, #$00B9, #$00BA, #$00BB, #$00BC, #$00BD, #$00BE, #$00BF, - { $C0 } - #$00C0, #$00C1, #$00C2, #$00C3, #$00C4, #$00C5, #$00C6, #$00C7, - #$00C8, #$00C9, #$00CA, #$00CB, #$00CC, #$00CD, #$00CE, #$00CF, - { $D0 } - #$00D0, #$00D1, #$00D2, #$00D3, #$00D4, #$00D5, #$00D6, #$00D7, - #$00D8, #$00D9, #$00DA, #$00DB, #$00DC, #$00DD, #$00DE, #$00DF, - { $E0 } - #$00E0, #$00E1, #$00E2, #$00E3, #$00E4, #$00E5, #$00E6, #$00E7, - #$00E8, #$00E9, #$00EA, #$00EB, #$00EC, #$00ED, #$00EE, #$00EF, - { $F0 } - #$00F0, #$00F1, #$00F2, #$00F3, #$00F4, #$00F5, #$00F6, #$00F7, - #$00F8, #$00F9, #$00FA, #$00FB, #$00FC, #$00FD, #$00FE, #$00FF - ); +var + Encoders: array[TEncoding] of IEncoder; +function TSingleByteEncoder.Encode(const InStr: UCS4String; out OutStr: RawByteString): boolean; +var + I: integer; +begin + SetLength(OutStr, LengthUCS4(InStr)); + Result := true; + for I := 1 to Length(OutStr) do + begin + if (not EncodeChar(InStr[I-1], OutStr[I])) then + Result := false; + end; +end; -function Convert(const Src: string; const Table: TConversionTable): WideString; +function TSingleByteEncoder.Decode(const InStr: RawByteString; out OutStr: UCS4String): boolean; var - SrcPos, DstPos: integer; + I: integer; begin - SetLength(Result, Length(Src)); - DstPos := 1; - for SrcPos := 1 to Length(Src) do + SetLength(OutStr, Length(InStr)+1); + Result := true; + for I := 1 to Length(InStr) do begin - if (Src[SrcPos] < #128) then - begin - // copy ASCII char - Result[DstPos] := Src[SrcPos]; - Inc(DstPos); - end - else + if (not DecodeChar(InStr[I], OutStr[I-1])) then + Result := false; + end; + OutStr[High(OutStr)] := 0; +end; + +function DecodeString(const Src: RawByteString; out Dst: WideString; SrcEncoding: TEncoding): boolean; +var + DstUCS4: UCS4String; +begin + Result := Encoders[SrcEncoding].Decode(Src, DstUCS4); + Dst := UCS4StringToWideString(DstUCS4); +end; + +function DecodeString(const Src: RawByteString; SrcEncoding: TEncoding): WideString; +begin + DecodeString(Src, Result, SrcEncoding); +end; + +function DecodeStringUTF8(const Src: RawByteString; out Dst: UTF8String; SrcEncoding: TEncoding): boolean; +var + DstUCS4: UCS4String; +begin + Result := Encoders[SrcEncoding].Decode(Src, DstUCS4); + Dst := UCS4ToUTF8String(DstUCS4); +end; + +function DecodeStringUTF8(const Src: RawByteString; SrcEncoding: TEncoding): UTF8String; +begin + DecodeStringUTF8(Src, Result, SrcEncoding); +end; + +function EncodeString(const Src: WideString; out Dst: RawByteString; DstEncoding: TEncoding): boolean; +begin + Result := Encoders[DstEncoding].Encode(WideStringToUCS4String(Src), Dst); +end; + +function EncodeString(const Src: WideString; DstEncoding: TEncoding): RawByteString; +begin + EncodeString(Src, Result, DstEncoding); +end; + +function EncodeStringUTF8(const Src: UTF8String; out Dst: RawByteString; DstEncoding: TEncoding): boolean; +begin + Result := Encoders[DstEncoding].Encode(UTF8ToUCS4String(Src), Dst); +end; + +function EncodeStringUTF8(const Src: UTF8String; DstEncoding: TEncoding): RawByteString; +begin + EncodeStringUTF8(Src, Result, DstEncoding); +end; + +function CheckReplaceUTF8BOM(var Text: RawByteString): boolean; +begin + if AnsiStartsStr(UTF8_BOM, Text) then + begin + Text := Copy(Text, Length(UTF8_BOM)+1, Length(Text)-Length(UTF8_BOM)); + Result := true; + Exit; + end; + Result := false; +end; + +function ParseEncoding(const EncodingStr: AnsiString; Default: TEncoding): TEncoding; +var + PrepStr: AnsiString; // prepared encoding string + Encoding: TEncoding; +begin + // remove surrounding whitespace, replace dashes, to upper case + PrepStr := UpperCase(AnsiReplaceStr(Trim(EncodingStr), '-', '')); + for Encoding := Low(TEncoding) to High(TEncoding) do + begin + if (Encoders[Encoding].GetName() = PrepStr) then begin - // look-up char - Result[DstPos] := Table[Ord(Src[SrcPos]) - 128]; - // ignore invalid characters - if (Result[DstPos] <> #0) then - Inc(DstPos); + Result := Encoding; + Exit; end; end; - SetLength(Result, DstPos-1); + Result := Default; end; -function RecodeString(const Src: string; SrcEncoding: TEncoding): WideString; +function EncodingName(Encoding: TEncoding): AnsiString; begin - case SrcEncoding of - encCP1250: - Result := Convert(Src, CP1250Table); - encCP1252: - Result := Convert(Src, CP1252Table); - encUTF8: - Result := UTF8Decode(Src); - encNative: - Result := UTF8Decode(AnsiToUtf8(Src)); - end; + Result := Encoders[Encoding].GetName(); end; +{$I ..\\encoding\\Locale.inc} +{$I ..\\encoding\\UTF8.inc} +{$I ..\\encoding\\CP1250.inc} +{$I ..\\encoding\\CP1252.inc} +{$I ..\\encoding\\Auto.inc} + +initialization + Encoders[encLocale] := TEncoderLocale.Create; + Encoders[encUTF8] := TEncoderUTF8.Create; + Encoders[encCP1250] := TEncoderCP1250.Create; + Encoders[encCP1252] := TEncoderCP1252.Create; + + // use USDX < 1.1 encoding for backward compatibility (encCP1252) + Encoders[encAuto] := TEncoderAuto.Create(Encoders[encUTF8], Encoders[encCP1252]); + end. diff --git a/cmake/src/base/UTexture.pas b/cmake/src/base/UTexture.pas index 97f244fe..c1334dd7 100644 --- a/cmake/src/base/UTexture.pas +++ b/cmake/src/base/UTexture.pas @@ -40,6 +40,7 @@ uses Classes, SysUtils, UCommon, + UPath, SDL, SDL_Image; @@ -66,7 +67,7 @@ type TexX2: real; TexY2: real; Alpha: real; - Name: string; // experimental for handling cache images. maybe it's useful for dynamic skins + Name: IPath; // experimental for handling cache images. maybe it's useful for dynamic skins end; type @@ -91,7 +92,7 @@ procedure AdjustPixelFormat(var TexSurface: PSDL_Surface; Typ: TTextureType); type PTextureEntry = ^TTextureEntry; TTextureEntry = record - Name: string; + Name: IPath; Typ: TTextureType; Color: cardinal; @@ -105,7 +106,7 @@ type Texture: array of TTextureEntry; public procedure AddTexture(var Tex: TTexture; Typ: TTextureType; Color: cardinal; Cache: boolean); - function FindTexture(const Name: string; Typ: TTextureType; Color: cardinal): integer; + function FindTexture(const Name: IPath; Typ: TTextureType; Color: cardinal): integer; end; TTextureUnit = class @@ -116,14 +117,14 @@ type procedure AddTexture(var Tex: TTexture; Typ: TTextureType; Cache: boolean = false); overload; procedure AddTexture(var Tex: TTexture; Typ: TTextureType; Color: cardinal; Cache: boolean = false); overload; - function GetTexture(const Name: string; Typ: TTextureType; FromCache: boolean = false): TTexture; overload; - function GetTexture(const Name: string; Typ: TTextureType; Col: LongWord; FromCache: boolean = false): TTexture; overload; - function LoadTexture(FromRegistry: boolean; const Identifier: string; Typ: TTextureType; Col: LongWord): TTexture; overload; - function LoadTexture(const Identifier: string; Typ: TTextureType; Col: LongWord): TTexture; overload; - function LoadTexture(const Identifier: string): TTexture; overload; - function CreateTexture(Data: PChar; const Name: string; Width, Height: word; BitsPerPixel: byte): TTexture; - procedure UnloadTexture(const Name: string; Typ: TTextureType; FromCache: boolean); overload; - procedure UnloadTexture(const Name: string; Typ: TTextureType; Col: cardinal; FromCache: boolean); overload; + function GetTexture(const Name: IPath; Typ: TTextureType; FromCache: boolean = false): TTexture; overload; + function GetTexture(const Name: IPath; Typ: TTextureType; Col: LongWord; FromCache: boolean = false): TTexture; overload; + function LoadTexture(FromRegistry: boolean; const Identifier: IPath; Typ: TTextureType; Col: LongWord): TTexture; overload; + function LoadTexture(const Identifier: IPath; Typ: TTextureType; Col: LongWord): TTexture; overload; + function LoadTexture(const Identifier: IPath): TTexture; overload; + function CreateTexture(Data: PChar; const Name: IPath; Width, Height: word; BitsPerPixel: byte): TTexture; + procedure UnloadTexture(const Name: IPath; Typ: TTextureType; FromCache: boolean); overload; + procedure UnloadTexture(const Name: IPath; Typ: TTextureType; Col: cardinal; FromCache: boolean); overload; //procedure FlushTextureDatabase(); constructor Create; @@ -188,7 +189,7 @@ begin Texture[TextureIndex].Texture := Tex; end; -function TTextureDatabase.FindTexture(const Name: string; Typ: TTextureType; Color: cardinal): integer; +function TTextureDatabase.FindTexture(const Name: IPath; Typ: TTextureType; Color: cardinal): integer; var TextureIndex: integer; CurrentTexture: PTextureEntry; @@ -197,7 +198,7 @@ begin for TextureIndex := 0 to High(Texture) do begin CurrentTexture := @Texture[TextureIndex]; - if (CurrentTexture.Name = Name) and + if (CurrentTexture.Name.Equals(Name)) and (CurrentTexture.Typ = Typ) then begin // colorized textures must match in their color too @@ -235,18 +236,18 @@ begin TextureDatabase.AddTexture(Tex, Typ, Color, Cache); end; -function TTextureUnit.LoadTexture(FromRegistry: boolean; const Identifier: string; Typ: TTextureType; Col: LongWord): TTexture; +function TTextureUnit.LoadTexture(FromRegistry: boolean; const Identifier: IPath; Typ: TTextureType; Col: LongWord): TTexture; begin // FIXME: what is the FromRegistry parameter supposed to do? Result := LoadTexture(Identifier, Typ, Col); end; -function TTextureUnit.LoadTexture(const Identifier: string): TTexture; +function TTextureUnit.LoadTexture(const Identifier: IPath): TTexture; begin Result := LoadTexture(Identifier, TEXTURE_TYPE_PLAIN, 0); end; -function TTextureUnit.LoadTexture(const Identifier: string; Typ: TTextureType; Col: LongWord): TTexture; +function TTextureUnit.LoadTexture(const Identifier: IPath; Typ: TTextureType; Col: LongWord): TTexture; var TexSurface: PSDL_Surface; newWidth, newHeight: integer; @@ -260,7 +261,7 @@ begin TexSurface := LoadImage(Identifier); if not assigned(TexSurface) then begin - Log.LogError('Could not load texture: "' + Identifier +'" with type "'+ TextureTypeToStr(Typ) +'"', + Log.LogError('Could not load texture: "' + Identifier.ToNative +'" with type "'+ TextureTypeToStr(Typ) +'"', 'TTextureUnit.LoadTexture'); Exit; end; @@ -363,16 +364,16 @@ begin SDL_FreeSurface(TexSurface); end; -function TTextureUnit.GetTexture(const Name: string; Typ: TTextureType; FromCache: boolean): TTexture; +function TTextureUnit.GetTexture(const Name: IPath; Typ: TTextureType; FromCache: boolean): TTexture; begin Result := GetTexture(Name, Typ, 0, FromCache); end; -function TTextureUnit.GetTexture(const Name: string; Typ: TTextureType; Col: LongWord; FromCache: boolean): TTexture; +function TTextureUnit.GetTexture(const Name: IPath; Typ: TTextureType; Col: LongWord; FromCache: boolean): TTexture; var TextureIndex: integer; begin - if (Name = '') then + if (Name.IsUnset) then begin // zero texture data FillChar(Result, SizeOf(Result), 0); @@ -413,7 +414,7 @@ begin Result := TextureDatabase.Texture[TextureIndex].Texture; end; -function TTextureUnit.CreateTexture(Data: PChar; const Name: string; Width, Height: word; BitsPerPixel: byte): TTexture; +function TTextureUnit.CreateTexture(Data: PChar; const Name: IPath; Width, Height: word; BitsPerPixel: byte): TTexture; var //Error: integer; ActTex: GLuint; @@ -467,12 +468,12 @@ begin Result.Name := Name; end; -procedure TTextureUnit.UnloadTexture(const Name: string; Typ: TTextureType; FromCache: boolean); +procedure TTextureUnit.UnloadTexture(const Name: IPath; Typ: TTextureType; FromCache: boolean); begin UnloadTexture(Name, Typ, 0, FromCache); end; -procedure TTextureUnit.UnloadTexture(const Name: string; Typ: TTextureType; Col: cardinal; FromCache: boolean); +procedure TTextureUnit.UnloadTexture(const Name: IPath; Typ: TTextureType; Col: cardinal; FromCache: boolean); var T: integer; TexNum: GLuint; @@ -539,7 +540,8 @@ begin Exit; end; end; - Log.LogWarn('Unknown texture type: "' + TypeStr + '". Using default texture type "' + TextureTypeToStr(Default) + '"', 'ParseTextureType'); + Log.LogInfo('Unknown texture type: "' + TypeStr + '". Using default texture type "' + + TextureTypeToStr(Default) + '"', 'UTexture.ParseTextureType'); Result := Default; end; diff --git a/cmake/src/base/UThemes.pas b/cmake/src/base/UThemes.pas index 3fd77853..b385406f 100644 --- a/cmake/src/base/UThemes.pas +++ b/cmake/src/base/UThemes.pas @@ -34,11 +34,12 @@ interface {$I switches.inc} uses - ULog, IniFiles, SysUtils, Classes, - UTexture; + ULog, + UTexture, + UPath; type TRGB = record @@ -112,7 +113,7 @@ type Font: integer; Size: integer; Align: integer; - Text: string; + Text: UTF8String; //Reflection Reflection: boolean; ReflectionSpacing: real; @@ -169,7 +170,9 @@ type TThemeSelectSlide = record Tex: string; + Typ: TTextureType; TexSBG: string; + TypSBG: TTextureType; X: integer; Y: integer; W: integer; @@ -182,7 +185,7 @@ type showArrows:boolean; oneItemOnly:boolean; - Text: string; + Text: UTF8String; ColR, ColG, ColB, Int: real; DColR, DColG, DColB, DInt: real; TColR, TColG, TColB, TInt: real; @@ -215,7 +218,7 @@ type TThemeBasic = class Background: TThemeBackground; Text: AThemeText; - Static: AThemeStatic; + Statics: AThemeStatic; //Button Collection Mod ButtonCollection: AThemeButtonCollection; @@ -236,8 +239,8 @@ type TextDescription: TThemeText; TextDescriptionLong: TThemeText; - Description: array[0..5] of string; - DescriptionLong: array[0..5] of string; + Description: array[0..5] of UTF8String; + DescriptionLong: array[0..5] of UTF8String; end; TThemeName = class(TThemeBasic) @@ -354,7 +357,7 @@ type TextP3RScore: TThemeText; //Linebonus Translations - LineBonusText: array [0..8] of string; + LineBonusText: array [0..8] of UTF8String; //Pause Popup PausePopUp: TThemeStatic; @@ -396,6 +399,7 @@ type StaticBackLevelRound: array[1..6] of TThemeStatic; StaticLevel: array[1..6] of TThemeStatic; StaticLevelRound: array[1..6] of TThemeStatic; + StaticPlayerIdBox: array[1..6] of TThemeStatic; // Description: array[0..5] of string;} end; @@ -408,6 +412,7 @@ type TextNumber: AThemeText; TextName: AThemeText; TextScore: AThemeText; + TextDate: AThemeText; end; TThemeOptions = class(TThemeBasic) @@ -421,7 +426,7 @@ type ButtonExit: TThemeButton; TextDescription: TThemeText; - Description: array[0..7] of string; + Description: array[0..7] of UTF8String; end; TThemeOptionsGame = class(TThemeBasic) @@ -496,8 +501,8 @@ type TextDescription: TThemeText; TextDescriptionLong: TThemeText; - Description: array[0..5] of string; - DescriptionLong: array[0..5] of string; + Description: array[0..5] of UTF8string; + DescriptionLong: array[0..5] of UTF8string; end; //Error- and Check-Popup @@ -531,10 +536,10 @@ type TextFound: TThemeText; //Translated Texts - Songsfound: string; - NoSongsfound: string; - CatText: string; - IType: array [0..2] of string; + Songsfound: UTF8String; + NoSongsfound: UTF8String; + CatText: UTF8String; + IType: array [0..2] of UTF8String; end; //Party Screens @@ -646,17 +651,17 @@ type SelectLevel: TThemeSelectSlide; SelectPlayList: TThemeSelectSlide; SelectPlayList2: TThemeSelectSlide; - SelectRounds: TThemeSelectSlide; - SelectTeams: TThemeSelectSlide; - SelectPlayers1: TThemeSelectSlide; - SelectPlayers2: TThemeSelectSlide; - SelectPlayers3: TThemeSelectSlide; {ButtonNext: TThemeButton; ButtonPrev: TThemeButton;} end; TThemePartyPlayer = class(TThemeBasic) + SelectTeams: TThemeSelectSlide; + SelectPlayers1: TThemeSelectSlide; + SelectPlayers2: TThemeSelectSlide; + SelectPlayers3: TThemeSelectSlide; + Team1Name: TThemeButton; Player1Name: TThemeButton; Player2Name: TThemeButton; @@ -679,6 +684,11 @@ type ButtonPrev: TThemeButton;} end; + TThemePartyRounds = class(TThemeBasic) + SelectRoundCount: TThemeSelectSlide; + SelectRound: array [0..6] of TThemeSelectSlide; + end; + //Stats Screens TThemeStatMain = class(TThemeBasic) ButtonScores: TThemeButton; @@ -700,15 +710,22 @@ type TextPage: TThemeText; TextList: AThemeText; - Description: array[0..3] of string; - DescriptionR: array[0..3] of string; - FormatStr: array[0..3] of string; - PageStr: string; + Description: array[0..3] of UTF8String; + DescriptionR: array[0..3] of UTF8String; + FormatStr: array[0..3] of UTF8String; + PageStr: UTF8String; end; //Playlist Translations TThemePlaylist = record - CatText: string; + CatText: UTF8String; + end; + + TThemeEntry = record + Name: string; + Filename: IPath; + DefaultSkin: integer; + Creator: string; end; TTheme = class @@ -721,8 +738,9 @@ type LastThemeBasic: TThemeBasic; procedure CreateThemeObjects(); - + procedure LoadHeader(FileName: IPath); public + Themes: array of TThemeEntry; Loading: TThemeLoading; Main: TThemeMain; Name: TThemeName; @@ -754,6 +772,7 @@ type PartyWin: TThemePartyWin; PartyOptions: TThemePartyOptions; PartyPlayer: TThemePartyPlayer; + PartyRounds: TThemePartyRounds; //Stats Screens: StatMain: TThemeStatMain; @@ -761,11 +780,13 @@ type Playlist: TThemePlaylist; - ILevel: array[0..2] of string; + ILevel: array[0..2] of UTF8String; + + constructor Create; - constructor Create(const FileName: string); overload; // Initialize theme system - constructor Create(const FileName: string; Color: integer); overload; // Initialize theme system with color - function LoadTheme(FileName: string; sColor: integer): boolean; // Load some theme settings from file + procedure LoadList; + + function LoadTheme(ThemeNum: integer; sColor: integer): boolean; // Load some theme settings from file procedure LoadColors; @@ -818,9 +839,13 @@ uses ULanguage, USkins, UIni, + UPathUtils, + UFileSystem, + TextGL, gl, glext, - math; + math, + StrUtils; //----------- //Helper procs to use TRGB in Opengl ...maybe this should be somewhere else @@ -845,12 +870,7 @@ begin glColor4f(Color.R, Color.G, Color.B, Min(Color.A, Alpha)); end; -constructor TTheme.Create(const FileName: string); -begin - Create(FileName, 0); -end; - -constructor TTheme.Create(const FileName: string; Color: integer); +constructor TTheme.Create; begin inherited Create(); @@ -884,16 +904,89 @@ begin PartyScore := TThemePartyScore.Create; PartyOptions := TThemePartyOptions.Create; PartyPlayer := TThemePartyPlayer.Create; + PartyRounds := TThemePartyRounds.Create; //Stats Screens: StatMain := TThemeStatMain.Create; StatDetail := TThemeStatDetail.Create; - LoadTheme(FileName, Color); + //LoadTheme(FileName, Color); + LoadList; +end; + +procedure TTheme.LoadHeader(FileName: IPath); + var + Entry: TThemeEntry; + Ini: TMemIniFile; + SkinName: string; + SkinsFound: boolean; + ThemeVersion: string; + I: integer; + Len: integer; + Skins: TUTF8StringDynArray; +begin + Entry.Filename := ThemePath.Append(FileName); + //read info from theme header + Ini := TMemIniFile.Create(Entry.Filename.ToNative); + + Entry.Name := Ini.ReadString('Theme', 'Name', FileName.SetExtension('').ToNative); + ThemeVersion := Trim(UpperCase(Ini.ReadString('Theme', 'US_Version', 'no version tag'))); + Entry.Creator := Ini.ReadString('Theme', 'Creator', 'Unknown'); + SkinName := Ini.ReadString('Theme', 'DefaultSkin', FileName.SetExtension('').ToNative); + + Ini.Free; + + // don't load theme with wrong version tag + if ThemeVersion <> 'USD 110' then + begin + Log.LogWarn('Wrong Version (' + ThemeVersion + ') in Theme : ' + Entry.Name, 'Theme.LoadHeader'); + end + else + begin + //Search for Skins for this Theme + SkinsFound := false; + for I := Low(Skin.Skin) to High(Skin.Skin) do + begin + if (CompareText(Skin.Skin[I].Theme, Entry.Name) = 0) then + begin + SkinsFound := true; + break; + end; + end; + + if SkinsFound then + begin + { found a valid Theme } + // set correct default skin + Skin.GetSkinsByTheme(Entry.Name, Skins); + Entry.DefaultSkin := max(0, GetArrayIndex(Skins, SkinName, true)); + + Len := Length(Themes); + SetLength(Themes, Len + 1); + SetLength(ITheme, Len + 1); + Themes[Len] := Entry; + ITheme[Len] := Entry.Name; + end; + end; +end; +procedure TTheme.LoadList; + var + Iter: IFileIterator; + FileInfo: TFileInfo; +begin + Log.LogStatus('Searching for Theme : ' + ThemePath.ToNative + '*.ini', 'Theme.LoadList'); + + Iter := FileSystem.FileFind(ThemePath.Append('*.ini'), 0); + while (Iter.HasNext) do + begin + FileInfo := Iter.Next; + Log.LogStatus('Found Theme: ' + FileInfo.Name.ToNative, 'Theme.LoadList'); + LoadHeader(Fileinfo.Name); + end; end; -function TTheme.LoadTheme(FileName: string; sColor: integer): boolean; +function TTheme.LoadTheme(ThemeNum: integer; sColor: integer): boolean; var I: integer; begin @@ -901,23 +994,21 @@ begin CreateThemeObjects(); - Log.LogStatus('Loading: '+ FileName, 'TTheme.LoadTheme'); + Log.LogStatus('Loading: '+ Themes[ThemeNum].FileName.ToNative, 'TTheme.LoadTheme'); - FileName := AdaptFilePaths(FileName); - - if not FileExists(FileName) then + if not Themes[ThemeNum].FileName.IsFile() then begin - Log.LogError('Theme does not exist ('+ FileName +')', 'TTheme.LoadTheme'); + Log.LogError('Theme does not exist ('+ Themes[ThemeNum].FileName.ToNative +')', 'TTheme.LoadTheme'); end; - if FileExists(FileName) then + if Themes[ThemeNum].FileName.IsFile() then begin Result := true; {$IFDEF THEMESAVE} - ThemeIni := TIniFile.Create(FileName); + ThemeIni := TIniFile.Create(Themes[ThemeNum].FileName.ToNative); {$ELSE} - ThemeIni := TMemIniFile.Create(FileName); + ThemeIni := TMemIniFile.Create(Themes[ThemeNum].FileName.ToNative); {$ENDIF} if ThemeIni.ReadString('Theme', 'Name', '') <> '' then @@ -1164,6 +1255,7 @@ begin ThemeLoadStatic(Score.StaticBackLevelRound[I], 'ScoreStaticBackLevelRound' + IntToStr(I)); ThemeLoadStatic(Score.StaticLevel[I], 'ScoreStaticLevel' + IntToStr(I)); ThemeLoadStatic(Score.StaticLevelRound[I], 'ScoreStaticLevelRound' + IntToStr(I)); + ThemeLoadStatic(Score.StaticPlayerIdBox[I], 'ScoreStaticPlayerIdBox' + IntToStr(I)); ThemeLoadStatic(Score.StaticRatings[I], 'ScoreStaticRatingPicture' + IntToStr(I)); end; @@ -1177,6 +1269,7 @@ begin ThemeLoadTexts(Top5.TextNumber, 'Top5TextNumber'); ThemeLoadTexts(Top5.TextName, 'Top5TextName'); ThemeLoadTexts(Top5.TextScore, 'Top5TextScore'); + ThemeLoadTexts(Top5.TextDate, 'Top5TextDate'); // Options ThemeLoadBasic(Options, 'Options'); @@ -1434,17 +1527,17 @@ begin ThemeLoadSelectSlide(PartyOptions.SelectLevel, 'PartyOptionsSelectLevel'); ThemeLoadSelectSlide(PartyOptions.SelectPlayList, 'PartyOptionsSelectPlayList'); ThemeLoadSelectSlide(PartyOptions.SelectPlayList2, 'PartyOptionsSelectPlayList2'); - ThemeLoadSelectSlide(PartyOptions.SelectRounds, 'PartyOptionsSelectRounds'); - ThemeLoadSelectSlide(PartyOptions.SelectTeams, 'PartyOptionsSelectTeams'); - ThemeLoadSelectSlide(PartyOptions.SelectPlayers1, 'PartyOptionsSelectPlayers1'); - ThemeLoadSelectSlide(PartyOptions.SelectPlayers2, 'PartyOptionsSelectPlayers2'); - ThemeLoadSelectSlide(PartyOptions.SelectPlayers3, 'PartyOptionsSelectPlayers3'); - {ThemeLoadButton (ButtonNext, 'ButtonNext'); ThemeLoadButton (ButtonPrev, 'ButtonPrev');} //Party Player ThemeLoadBasic(PartyPlayer, 'PartyPlayer'); + + ThemeLoadSelectSlide(PartyPlayer.SelectTeams, 'PartyPlayerSelectTeams'); + ThemeLoadSelectSlide(PartyPlayer.SelectPlayers1, 'PartyPlayerSelectPlayers1'); + ThemeLoadSelectSlide(PartyPlayer.SelectPlayers2, 'PartyPlayerSelectPlayers2'); + ThemeLoadSelectSlide(PartyPlayer.SelectPlayers3, 'PartyPlayerSelectPlayers3'); + ThemeLoadButton(PartyPlayer.Team1Name, 'PartyPlayerTeam1Name'); ThemeLoadButton(PartyPlayer.Player1Name, 'PartyPlayerPlayer1Name'); ThemeLoadButton(PartyPlayer.Player2Name, 'PartyPlayerPlayer2Name'); @@ -1463,6 +1556,13 @@ begin ThemeLoadButton(PartyPlayer.Player11Name, 'PartyPlayerPlayer11Name'); ThemeLoadButton(PartyPlayer.Player12Name, 'PartyPlayerPlayer12Name'); + // Party Rounds + ThemeLoadBasic(PartyRounds, 'PartyRounds'); + + ThemeLoadSelectSlide(PartyRounds.SelectRoundCount, 'PartyRoundsSelectRoundCount'); + for I := 0 to High(PartyRounds.SelectRound) do + ThemeLoadSelectSlide(PartyRounds.SelectRound[I], 'PartyRoundsSelectRound' + IntToStr(I + 1)); + {ThemeLoadButton(ButtonNext, 'PartyPlayerButtonNext'); ThemeLoadButton(ButtonPrev, 'PartyPlayerButtonPrev');} @@ -1524,7 +1624,7 @@ procedure TTheme.ThemeLoadBasic(Theme: TThemeBasic; const Name: string); begin ThemeLoadBackground(Theme.Background, Name); ThemeLoadTexts(Theme.Text, Name + 'Text'); - ThemeLoadStatics(Theme.Static, Name + 'Static'); + ThemeLoadStatics(Theme.Statics, Name + 'Static'); ThemeLoadButtonCollections(Theme.ButtonCollection, Name + 'ButtonCollection'); LastThemeBasic := Theme; @@ -1568,7 +1668,7 @@ begin ThemeText.ColG := ThemeIni.ReadFloat(Name, 'ColG', 0); ThemeText.ColB := ThemeIni.ReadFloat(Name, 'ColB', 0); - ThemeText.Font := ThemeIni.ReadInteger(Name, 'Font', 0); + ThemeText.Font := ThemeIni.ReadInteger(Name, 'Font', ftNormal); ThemeText.Size := ThemeIni.ReadInteger(Name, 'Size', 0); ThemeText.Align := ThemeIni.ReadInteger(Name, 'Align', 0); @@ -1773,7 +1873,9 @@ begin ThemeSelectS.Text := Language.Translate(ThemeIni.ReadString(Name, 'Text', '')); ThemeSelectS.Tex := {Skin.SkinPath + }ThemeIni.ReadString(Name, 'Tex', ''); + ThemeSelectS.Typ := ParseTextureType(ThemeIni.ReadString(Name, 'Type', ''), TEXTURE_TYPE_PLAIN); ThemeSelectS.TexSBG := {Skin.SkinPath + }ThemeIni.ReadString(Name, 'TexSBG', ''); + ThemeSelectS.TypSBG := ParseTextureType(ThemeIni.ReadString(Name, 'TypeSBG', ''), TEXTURE_TYPE_PLAIN); ThemeSelectS.X := ThemeIni.ReadInteger(Name, 'X', 0); ThemeSelectS.Y := ThemeIni.ReadInteger(Name, 'Y', 0); @@ -1807,6 +1909,9 @@ begin ThemeSelectS.STInt := ThemeIni.ReadFloat(Name, 'STInt', 1); LoadColor(ThemeSelectS.STDColR, ThemeSelectS.STDColG, ThemeSelectS.STDColB, ThemeIni.ReadString(Name, 'STDColor', '')); ThemeSelectS.STDInt := ThemeIni.ReadFloat(Name, 'STDInt', 1); + + ThemeSelectS.showArrows := (ThemeIni.ReadInteger(Name, 'ShowArrows', 0) = 1); + ThemeSelectS.oneItemOnly := (ThemeIni.ReadInteger(Name, 'OneItemOnly', 0) = 1); end; procedure TTheme.ThemeLoadEqualizer(var ThemeEqualizer: TThemeEqualizer; const Name: string); @@ -2023,15 +2128,15 @@ begin //New Theme-Color Patch 4: begin // violet - Result.R := 230/255; - Result.G := 63/255; - Result.B := 230/255; + Result.R := 212/255; + Result.G := 71/255; + Result.B := 247/255; end; 5: begin // orange - Result.R := 255/255; + Result.R := 247/255; Result.G := 144/255; - Result.B := 0; + Result.B := 71/255; end; 6: begin // yellow @@ -2193,7 +2298,7 @@ begin ThemeIni.WriteInteger(Name, 'Texts', Length(Theme.Text)); ThemeSaveBackground(Theme.Background, Name + 'Background'); - ThemeSaveStatics(Theme.Static, Name + 'Static'); + ThemeSaveStatics(Theme.Statics, Name + 'Static'); ThemeSaveTexts(Theme.Text, Name + 'Text'); end; diff --git a/cmake/src/base/UTime.pas b/cmake/src/base/UTime.pas index 83844cb5..0610ef59 100644 --- a/cmake/src/base/UTime.pas +++ b/cmake/src/base/UTime.pas @@ -40,20 +40,26 @@ type function GetTime(): real; end; + TRelativeTimerState = (rtsStopped, rtsWait, rtsPaused, rtsRunning); + TRelativeTimer = class private AbsoluteTime: int64; // system-clock reference time for calculation of CurrentTime - RelativeTimeOffset: real; - Paused: boolean; + RelativeTime: real; TriggerMode: boolean; + State: TRelativeTimerState; public - constructor Create(TriggerMode: boolean = false); + constructor Create(); + procedure Start(WaitForTrigger: boolean = false); procedure Pause(); - procedure Resume(); + procedure Stop(); function GetTime(): real; - function GetAndResetTime(): real; - procedure SetTime(Time: real; Trigger: boolean = true); - procedure Reset(); + procedure SetTime(Time: real); + function GetState(): TRelativeTimerState; + end; + + TSyncSource = class + function GetClock(): real; virtual; abstract; end; procedure CountSkipTimeSet; @@ -126,85 +132,115 @@ end; * TRelativeTimer **} -(* - * creates a new timer. - * if triggermode is false (default), the timer - * will immediately begin with counting. - * if triggermode is true, it will wait until get/settime() or pause() is called - * for the first time. +(** + * Creates a new relative timer. + * A relative timer works like a stop-watch. It can be paused and + * resumed afterwards, continuing with the counter it had when it was paused. *) -constructor TRelativeTimer.Create(TriggerMode: boolean); +constructor TRelativeTimer.Create(); begin - inherited Create(); - Self.TriggerMode := TriggerMode; - Reset(); - Paused := false; + State := rtsStopped; + AbsoluteTime := 0; + RelativeTime := 0; end; -procedure TRelativeTimer.Pause(); +(** + * Starts the timer. + * If WaitForTrigger is false the timer will be started immediately. + * If WaitForTrigger is true the timer will be started when a trigger event + * occurs. A trigger event is a call of one of the Get-/SetTime() methods. + * In addition the timer can be started by calling this method again with + * WaitForTrigger set to false. + *) +procedure TRelativeTimer.Start(WaitForTrigger: boolean = false); begin - RelativeTimeOffset := GetTime(); - Paused := true; + case (State) of + rtsStopped, rtsPaused: begin + if (WaitForTrigger) then + begin + State := rtsWait; + end + else + begin + State := rtsRunning; + AbsoluteTime := SDL_GetTicks(); + end; + end; + + rtsWait: begin + if (not WaitForTrigger) then + begin + State := rtsRunning; + AbsoluteTime := SDL_GetTicks(); + RelativeTime := 0; + end; + end; + end; end; -procedure TRelativeTimer.Resume(); +(** + * Pauses the timer and leaves the counter untouched. + *) +procedure TRelativeTimer.Pause(); begin - AbsoluteTime := SDL_GetTicks(); - Paused := false; + if (State = rtsRunning) then + begin + // Important: GetTime() must be called in running state + RelativeTime := GetTime(); + State := rtsPaused; + end; end; -(* - * Returns the counter of the timer. - * If in TriggerMode it will return 0 and start the counter on the first call. +(** + * Stops the timer and sets its counter to 0. *) -function TRelativeTimer.GetTime: real; +procedure TRelativeTimer.Stop(); begin - // initialize absolute time on first call in triggered mode - if (TriggerMode and (AbsoluteTime = 0)) then + if (State <> rtsStopped) then begin - AbsoluteTime := SDL_GetTicks(); - Result := RelativeTimeOffset; - Exit; + State := rtsStopped; + RelativeTime := 0; end; - - if Paused then - Result := RelativeTimeOffset - else - Result := RelativeTimeOffset + (SDL_GetTicks() - AbsoluteTime) / cSDLCorrectionRatio; end; -(* - * Returns the counter of the timer and resets the counter to 0 afterwards. - * Note: In TriggerMode the counter will not be stopped as with Reset(). +(** + * Returns the current counter of the timer. + * If WaitForTrigger was true in Start() the timer will be started + * if it was not already running. *) -function TRelativeTimer.GetAndResetTime(): real; +function TRelativeTimer.GetTime(): real; begin - Result := GetTime(); - SetTime(0); + case (State) of + rtsStopped, rtsPaused: + Result := RelativeTime; + rtsRunning: + Result := RelativeTime + (SDL_GetTicks() - AbsoluteTime) / cSDLCorrectionRatio; + rtsWait: begin + // start triggered + State := rtsRunning; + AbsoluteTime := SDL_GetTicks(); + Result := RelativeTime; + end; + end; end; -(* - * Sets the timer to the given time. This will trigger in TriggerMode if - * Trigger is set to true. Otherwise the counter's state will not change. +(** + * Sets the counter of the timer. + * If WaitForTrigger was true in Start() the timer will be started + * if it was not already running. *) -procedure TRelativeTimer.SetTime(Time: real; Trigger: boolean); +procedure TRelativeTimer.SetTime(Time: real); begin - RelativeTimeOffset := Time; - if ((not TriggerMode) or Trigger) then - AbsoluteTime := SDL_GetTicks(); + RelativeTime := Time; + AbsoluteTime := SDL_GetTicks(); + // start triggered + if (State = rtsWait) then + State := rtsRunning; end; -(* - * Resets the counter of the timer to 0. - * If in TriggerMode the timer will not start counting until it is triggered again. - *) -procedure TRelativeTimer.Reset(); +function TRelativeTimer.GetState(): TRelativeTimerState; begin - RelativeTimeOffset := 0; - if (TriggerMode) then - AbsoluteTime := 0 - else - AbsoluteTime := SDL_GetTicks(); + Result := State; end; end. diff --git a/cmake/src/base/UUnicodeUtils.pas b/cmake/src/base/UUnicodeUtils.pas new file mode 100644 index 00000000..37b53a67 --- /dev/null +++ b/cmake/src/base/UUnicodeUtils.pas @@ -0,0 +1,670 @@ +{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +unit UUnicodeUtils; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +uses +{$IFDEF MSWINDOWS} + Windows, +{$ENDIF} + StrUtils, + SysUtils; + +type + // String with unknown encoding. Introduced with Delphi 2009 and maybe soon + // with FPC. + RawByteString = AnsiString; + +{** + * Returns true if the system uses UTF-8 as default string type + * (filesystem or API calls). + * This is always true on Mac OS X and always false on Win32. On Unix it depends + * on the LC_CTYPE setting. + * Do not use AnsiToUTF8() or UTF8ToAnsi() if this function returns true. + *} +function IsNativeUTF8(): boolean; + +(* + * Character classes + *) + +function IsAlphaChar(ch: WideChar): boolean; overload; +function IsAlphaChar(ch: UCS4Char): boolean; overload; + +function IsNumericChar(ch: WideChar): boolean; overload; +function IsNumericChar(ch: UCS4Char): boolean; overload; + +function IsAlphaNumericChar(ch: WideChar): boolean; overload; +function IsAlphaNumericChar(ch: UCS4Char): boolean; overload; + +function IsPunctuationChar(ch: WideChar): boolean; overload; +function IsPunctuationChar(ch: UCS4Char): boolean; overload; + +function IsControlChar(ch: WideChar): boolean; overload; +function IsControlChar(ch: UCS4Char): boolean; overload; + +function IsPrintableChar(ch: WideChar): boolean; overload; +function IsPrintableChar(ch: UCS4Char): boolean; overload; + +{** + * Checks if the given string is a valid UTF-8 string. + * If an ANSI encoded string (with char codes >= 128) is passed, the + * function will most probably return false, as most ANSI strings sequences + * are illegal in UTF-8. + *} +function IsUTF8String(const str: RawByteString): boolean; + +{** + * Iterates over an UTF-8 encoded string. + * StrPtr will be increased to the beginning of the next character on each + * call. + * Results true if the given string starts with an UTF-8 encoded char. + *} +function NextCharUTF8(var StrPtr: PAnsiChar; out Ch: UCS4Char): boolean; + +{** + * Deletes Count chars (not bytes) beginning at char- (not byte-) position Index. + * Index values start with 1. + *} +procedure UTF8Delete(var Str: UTF8String; Index: Integer; Count: Integer); +procedure UCS4Delete(var Str: UCS4String; Index: Integer; Count: Integer); + +{** + * Checks if the string is composed of ASCII characters. + *} +function IsASCIIString(const str: RawByteString): boolean; + +{* + * String format conversion + *} + +function UTF8ToUCS4String(const str: UTF8String): UCS4String; +function UCS4ToUTF8String(const str: UCS4String): UTF8String; overload; +function UCS4ToUTF8String(ch: UCS4Char): UTF8String; overload; + +{** + * Returns the number of characters (not bytes) in string str. + *} +function LengthUTF8(const str: UTF8String): integer; + +{** + * Returns the length of an UCS4String. Note that Length(UCS4String) returns + * the length+1 as UCS4Strings are zero-terminated. + *} +function LengthUCS4(const str: UCS4String): integer; + +{** @seealso WideCompareStr *} +function UTF8CompareStr(const S1, S2: UTF8String): integer; +{** @seealso WideCompareText *} +function UTF8CompareText(const S1, S2: UTF8String): integer; + +function UTF8StartsText(const SubText, Text: UTF8String): boolean; + +function UTF8ContainsStr(const Text, SubText: UTF8String): boolean; +function UTF8ContainsText(const Text, SubText: UTF8String): boolean; + +{** @seealso WideUpperCase *} +function UTF8UpperCase(const str: UTF8String): UTF8String; +{** @seealso WideCompareText *} +function UTF8LowerCase(const str: UTF8String): UTF8String; + +{** + * Converts a UCS-4 char ch to its upper-case representation. + *} +function UCS4UpperCase(ch: UCS4Char): UCS4Char; overload; + +{** + * Converts a UCS-4 string str to its upper-case representation. + *} +function UCS4UpperCase(const str: UCS4String): UCS4String; overload; + +{** + * Converts a UCS4Char to an UCS4String. + * Note that UCS4Strings are zero-terminated dynamic arrays. + *} +function UCS4CharToString(ch: UCS4Char): UCS4String; + +{** + * @seealso System.Pos() + *} +function UTF8Pos(const substr: UTF8String; const str: UTF8String): Integer; + +{** + * Copies a segment of str starting with Index (1-based) with Count characters (not bytes). + *} +function UTF8Copy(const str: UTF8String; Index: Integer = 1; Count: Integer = -1): UTF8String; + +{** + * Copies a segment of str starting with Index (0-based) with Count characters. + * Note: Do not use Copy() to copy UCS4Strings as the result will not contain + * a trailing #0 character and hence is invalid. + *} +function UCS4Copy(const str: UCS4String; Index: Integer = 0; Count: Integer = -1): UCS4String; + +(* + * Converts a WideString to its upper- or lower-case representation. + * Wrapper for WideUpper/LowerCase. Needed because some plattforms have + * problems with unicode support. + * + * Note that characters in UTF-16 might consist of one or two WideChar valus + * (see surrogates). So instead of using WideStringUpperCase(ch)[1] for single + * character access, convert to UCS-4 where each character is represented by + * one UCS4Char. + *) +function WideStringUpperCase(const str: WideString) : WideString; overload; +function WideStringUpperCase(ch: WideChar): WideString; overload; +function WideStringLowerCase(const str: WideString): WideString; overload; +function WideStringLowerCase(ch: WideChar): WideString; overload; + +function WideStringReplaceChar(const text: WideString; search, rep: WideChar): WideString; + +implementation + +{$IFDEF UNIX} +{$IFNDEF DARWIN} +const + LC_CTYPE = 0; + +function setlocale(category: integer; locale: PChar): PChar; cdecl; external 'c'; +{$ENDIF} +{$ENDIF} + +var + NativeUTF8: boolean; + +procedure InitUnicodeUtils(); +{$IFDEF UNIX} +{$IFNDEF DARWIN} +var + localeName: PChar; +{$ENDIF} +{$ENDIF} +begin + {$IF Defined(DARWIN)} + NativeUTF8 := true; + {$ELSEIF Defined(MSWindows)} + NativeUTF8 := false; + {$ELSEIF Defined(UNIX)} + // check if locale name contains UTF8 or UTF-8 + localeName := setlocale(LC_CTYPE, nil); + NativeUTF8 := Pos('UTF8', UpperCase(AnsiReplaceStr(localeName, '-', ''))) > 0; + {$ELSE} + raise Exception.Create('Unknown system'); + {$IFEND} +end; + +function IsNativeUTF8(): boolean; +begin + Result := NativeUTF8; +end; + +function IsAlphaChar(ch: WideChar): boolean; +begin + {$IFDEF MSWINDOWS} + Result := IsCharAlphaW(ch); + {$ELSE} + // TODO: add chars > 255 (or replace with libxml2 functions?) + case ch of + 'A'..'Z', // A-Z + 'a'..'z', // a-z + #170,#181,#186, + #192..#214, + #216..#246, + #248..#255: + Result := true; + else + Result := false; + end; + {$ENDIF} +end; + +function IsAlphaChar(ch: UCS4Char): boolean; +begin + Result := IsAlphaChar(WideChar(Ord(ch))); +end; + +function IsNumericChar(ch: WideChar): boolean; +begin + // TODO: replace with libxml2 functions? + // ignore non-arabic numerals as we do not want to handle them + case ch of + '0'..'9': + Result := true; + else + Result := false; + end; +end; + +function IsNumericChar(ch: UCS4Char): boolean; +begin + Result := IsNumericChar(WideChar(Ord(ch))); +end; + +function IsAlphaNumericChar(ch: WideChar): boolean; +begin + Result := (IsAlphaChar(ch) or IsNumericChar(ch)); +end; + +function IsAlphaNumericChar(ch: UCS4Char): boolean; +begin + Result := (IsAlphaChar(ch) or IsNumericChar(ch)); +end; + +function IsPunctuationChar(ch: WideChar): boolean; +begin + // TODO: add chars > 255 (or replace with libxml2 functions?) + case ch of + ' '..'/',':'..'@','['..'`','{'..'~', + #160..#191,#215,#247: + Result := true; + else + Result := false; + end; +end; + +function IsPunctuationChar(ch: UCS4Char): boolean; +begin + Result := IsPunctuationChar(WideChar(Ord(ch))); +end; + +function IsControlChar(ch: WideChar): boolean; +begin + case ch of + #0..#31, + #127..#159: + Result := true; + else + Result := false; + end; +end; + +function IsControlChar(ch: UCS4Char): boolean; +begin + Result := IsControlChar(WideChar(Ord(ch))); +end; + +function IsPrintableChar(ch: WideChar): boolean; +begin + Result := not IsControlChar(ch); +end; + +function IsPrintableChar(ch: UCS4Char): boolean; +begin + Result := IsPrintableChar(WideChar(Ord(ch))); +end; + + +function NextCharUTF8(var StrPtr: PAnsiChar; out Ch: UCS4Char): boolean; + + // find the most significant zero bit (Result: [7..-1]) + function FindZeroMSB(b: byte): integer; + var + Mask: byte; + begin + Mask := $80; + Result := 7; + while (b and Mask <> 0) do + begin + Mask := Mask shr 1; + Dec(Result); + end; + end; + +var + ZeroBit: integer; + SeqCount: integer; // number of trailing bytes to follow +const + Mask: array[1..3] of byte = ($1F, $0F, $07); +begin + Result := false; + SeqCount := 0; + Ch := 0; + + while (StrPtr^ <> #0) do + begin + if (StrPtr^ < #128) then + begin + // check that no more trailing bytes are expected + if (SeqCount = 0) then + begin + Ch := Ord(StrPtr^); + Inc(StrPtr); + Result := true; + end; + Break; + end + else + begin + ZeroBit := FindZeroMSB(Ord(StrPtr^)); + // trailing byte expected + if (SeqCount > 0) then + begin + // check if trailing byte has pattern 10xxxxxx + if (ZeroBit <> 6) then + begin + Inc(StrPtr); + Break; + end; + + Dec(SeqCount); + Ch := (Ch shl 6) or (Ord(StrPtr^) and $3F); + + // check if char is finished + if (SeqCount = 0) then + begin + Inc(StrPtr); + Result := true; + Break; + end; + end + else // leading byte expected + begin + // check if pattern is one of 110xxxxx/1110xxxx/11110xxx + if (ZeroBit > 5) or (ZeroBit < 3) then + begin + Inc(StrPtr); + Break; + end; + // calculate number of trailing bytes (1, 2 or 3) + SeqCount := 6 - ZeroBit; + // extract first part of char + Ch := Ord(StrPtr^) and Mask[SeqCount]; + end; + end; + + Inc(StrPtr); + end; + + if (not Result) then + Ch := Ord('?'); +end; + +function IsUTF8String(const str: RawByteString): boolean; +var + Ch: UCS4Char; + StrPtr: PAnsiChar; +begin + Result := true; + StrPtr := PChar(str); + while (StrPtr^ <> #0) do + begin + if (not NextCharUTF8(StrPtr, Ch)) then + begin + Result := false; + Exit; + end; + end; +end; + +function IsASCIIString(const str: RawByteString): boolean; +var + I: integer; +begin + for I := 1 to Length(str) do + begin + if (str[I] >= #128) then + begin + Result := false; + Exit; + end; + end; + Result := true; +end; + + +function UTF8ToUCS4String(const str: UTF8String): UCS4String; +begin + Result := WideStringToUCS4String(UTF8Decode(str)); +end; + +function UCS4ToUTF8String(const str: UCS4String): UTF8String; +begin + Result := UTF8Encode(UCS4StringToWideString(str)); +end; + +function UCS4ToUTF8String(ch: UCS4Char): UTF8String; +begin + Result := UCS4ToUTF8String(UCS4CharToString(ch)); +end; + +function LengthUTF8(const str: UTF8String): integer; +begin + Result := LengthUCS4(UTF8ToUCS4String(str)); +end; + +function LengthUCS4(const str: UCS4String): integer; +begin + Result := High(str); + if (Result = -1) then + Result := 0; +end; + +function UTF8CompareStr(const S1, S2: UTF8String): integer; +begin + Result := WideCompareStr(UTF8Decode(S1), UTF8Decode(S2)); +end; + +function UTF8CompareText(const S1, S2: UTF8String): integer; +begin + Result := WideCompareText(UTF8Decode(S1), UTF8Decode(S2)); +end; + +function UTF8StartsStr(const SubText, Text: UTF8String): boolean; +begin + // TODO: use WideSameStr (slower but handles different representations of the same char)? + Result := (Pos(SubText, Text) = 1); +end; + +function UTF8StartsText(const SubText, Text: UTF8String): boolean; +begin + // TODO: use WideSameText (slower but handles different representations of the same char)? + Result := (Pos(UTF8UpperCase(SubText), UTF8UpperCase(Text)) = 1); +end; + +function UTF8ContainsStr(const Text, SubText: UTF8String): boolean; +begin + Result := Pos(SubText, Text) > 0; +end; + +function UTF8ContainsText(const Text, SubText: UTF8String): boolean; +begin + Result := Pos(UTF8UpperCase(SubText), UTF8UpperCase(Text)) > 0; +end; + +function UTF8UpperCase(const str: UTF8String): UTF8String; +begin + Result := UTF8Encode(WideStringUpperCase(UTF8Decode(str))); +end; + +function UTF8LowerCase(const str: UTF8String): UTF8String; +begin + Result := UTF8Encode(WideStringLowerCase(UTF8Decode(str))); +end; + +function UCS4UpperCase(ch: UCS4Char): UCS4Char; +begin + Result := UCS4UpperCase(UCS4CharToString(ch))[0]; +end; + +function UCS4UpperCase(const str: UCS4String): UCS4String; +begin + // convert to upper-case as WideString and convert result back to UCS-4 + Result := WideStringToUCS4String( + WideStringUpperCase( + UCS4StringToWideString(str))); +end; + +function UCS4CharToString(ch: UCS4Char): UCS4String; +begin + SetLength(Result, 2); + Result[0] := ch; + Result[1] := 0; +end; + +function UTF8Pos(const substr: UTF8String; const str: UTF8String): Integer; +begin + Result := Pos(substr, str); +end; + +function UTF8Copy(const str: UTF8String; Index: Integer; Count: Integer): UTF8String; +begin + Result := UCS4ToUTF8String(UCS4Copy(UTF8ToUCS4String(str), Index-1, Count)); +end; + +function UCS4Copy(const str: UCS4String; Index: Integer; Count: Integer): UCS4String; +var + I: integer; + MaxCount: integer; +begin + // calculate max. copy count + MaxCount := LengthUCS4(str)-Index; + if (MaxCount < 0) then + MaxCount := 0; + // adjust copy count + if (Count > MaxCount) or (Count < 0) then + Count := MaxCount; + + // copy (and add zero terminator) + SetLength(Result, Count + 1); + for I := 0 to Count-1 do + Result[I] := str[Index+I]; + Result[Count] := 0; +end; + +procedure UTF8Delete(var Str: UTF8String; Index: Integer; Count: Integer); +var + StrUCS4: UCS4String; +begin + StrUCS4 := UTF8ToUCS4String(str); + UCS4Delete(StrUCS4, Index-1, Count); + Str := UCS4ToUTF8String(StrUCS4); +end; + +procedure UCS4Delete(var Str: UCS4String; Index: Integer; Count: Integer); +var + Len: integer; + OldStr: UCS4String; + I: integer; +begin + Len := LengthUCS4(Str); + if (Count <= 0) or (Index < 0) or (Index >= Len) then + Exit; + if (Index + Count > Len) then + Count := Len-Index; + + OldStr := Str; + SetLength(Str, Len-Count+1); + for I := 0 to Index-1 do + Str[I] := OldStr[I]; + for I := Index+Count to Len-1 do + Str[I-Count] := OldStr[I]; + Str[High(Str)] := 0; +end; + +function WideStringUpperCase(ch: WideChar): WideString; +begin + // If WideChar #0 is converted to a WideString in Delphi, a string with + // length 1 and a single char #0 is returned. In FPC an empty (length=0) + // string will be returned. This will crash, if a non printable key was + // pressed, its char code (#0) is translated to upper-case and the the first + // character is accessed with Result[1]. + // We cannot catch this error in the WideString parameter variant as the string + // has length 0 already. + + // Force min. string length of 1 + if (ch = #0) then + Result := #0 + else + Result := WideStringUpperCase(WideString(ch)); +end; + +function WideStringUpperCase(const str: WideString): WideString; +begin + // On Linux and MacOSX the cwstring unit is necessary for Unicode function-calls. + // Otherwise you will get an EIntOverflow exception (thrown by unimplementedwidestring()). + // The Unicode manager cwstring does not work with MacOSX at the moment because + // of missing references to iconv. + // Note: Should be fixed now + + {.$IFNDEF DARWIN} + {.$IFDEF NOIGNORE} + Result := WideUpperCase(str) + {.$ELSE} + //Result := UTF8Decode(UpperCase(UTF8Encode(str))); + {.$ENDIF} +end; + +function WideStringLowerCase(ch: WideChar): WideString; +begin + // see WideStringUpperCase + if (ch = #0) then + Result := #0 + else + Result := WideStringLowerCase(WideString(ch)); +end; + +function WideStringLowerCase(const str: WideString): WideString; +begin + // see WideStringUpperCase + Result := WideLowerCase(str) +end; + +function WideStringReplaceChar(const text: WideString; search, rep: WideChar): WideString; +var + iPos : integer; +// sTemp : WideString; +begin +(* + result := text; + iPos := Pos(search, result); + while (iPos > 0) do + begin + sTemp := copy(result, iPos + length(search), length(result)); + result := copy(result, 1, iPos - 1) + rep + sTEmp; + iPos := Pos(search, result); + end; +*) + result := text; + + if search = rep then + exit; + + for iPos := 1 to length(result) do + begin + if result[iPos] = search then + result[iPos] := rep; + end; +end; + +initialization + InitUnicodeUtils; + +end. diff --git a/cmake/src/base/UXMLSong.pas b/cmake/src/base/UXMLSong.pas index 58b48789..e9751eba 100644 --- a/cmake/src/base/UXMLSong.pas +++ b/cmake/src/base/UXMLSong.pas @@ -34,7 +34,9 @@ interface {$I switches.inc} uses - Classes; + Classes, + UPath, + UUnicodeUtils; type TNote = record @@ -42,30 +44,30 @@ type Duration: Cardinal; Tone: Integer; NoteTyp: Byte; - Lyric: String; + Lyric: UTF8String; end; - ANote = Array of TNote; + ANote = array of TNote; TSentence = record Singer: Byte; Duration: Cardinal; Notes: ANote; end; - ASentence = Array of TSentence; + ASentence = array of TSentence; - TSongInfo = Record + TSongInfo = record ID: Cardinal; DualChannel: Boolean; - Header: Record - Artist: String; - Title: String; + Header: record + Artist: UTF8String; + Title: UTF8String; Gap: Cardinal; BPM: Real; Resolution: Byte; - Edition: String; - Genre: String; - Year: String; - Language: String; + Edition: UTF8String; + Genre: UTF8String; + Year: UTF8String; + Language: UTF8String; end; CountSentences: Cardinal; Sentences: ASentence; @@ -81,23 +83,23 @@ type BindLyrics: Boolean; //Should the Lyrics be bind to the last Word (no Space) FirstNote: Boolean; //Is this the First Note found? For Gap calculating - Function ParseLine(Line: String): Boolean; + function ParseLine(Line: RawByteString): Boolean; public SongInfo: TSongInfo; - ErrorMessage: String; - Edition: String; - SingstarVersion: String; + ErrorMessage: string; + Edition: UTF8String; + SingstarVersion: string; - Settings: Record + Settings: record DashReplacement: Char; end; - Constructor Create; + constructor Create; - Function ParseConfigforEdition(const Filename: String): String; + function ParseConfigForEdition(const Filename: IPath): String; - Function ParseSongHeader(const Filename: String): Boolean; //Parse Song Header only - Function ParseSong (const Filename: String): Boolean; //Parse whole Song + function ParseSongHeader(const Filename: IPath): Boolean; //Parse Song Header only + function ParseSong (const Filename: IPath): Boolean; //Parse whole Song end; const @@ -114,9 +116,12 @@ const DS_Both = 3; implementation -uses SysUtils, StrUtils; -Constructor TParser.Create; +uses + SysUtils, + StrUtils; + +constructor TParser.Create; begin inherited Create; ErrorMessage := ''; @@ -124,19 +129,24 @@ begin DecimalSeparator := '.'; end; -Function TParser.ParseSong (const Filename: String): Boolean; -var I: Integer; +function TParser.ParseSong(const Filename: IPath): Boolean; +var + I: Integer; + FileStream: TBinaryFileStream; begin Result := False; - if FileExists(Filename) then + if Filename.IsFile() then begin - SSFile := TStringList.Create; + ErrorMessage := 'Can''t open melody.xml file'; + SSFile := TStringList.Create; + FileStream := TBinaryFileStream.Create(Filename, fmOpenRead); try - ErrorMessage := 'Can''t open melody.xml file'; - SSFile.LoadFromFile(Filename); + SSFile.LoadFromStream(FileStream); + ErrorMessage := ''; Result := True; + I := 0; SongInfo.CountSentences := 0; @@ -153,7 +163,7 @@ begin SetLength(SongInfo.Sentences, 0); - While Result And (I < SSFile.Count) do + while Result and (I < SSFile.Count) do begin Result := ParseLine(SSFile.Strings[I]); @@ -162,21 +172,24 @@ begin finally SSFile.Free; + FileStream.Free; end; end; end; -Function TParser.ParseSongHeader (const Filename: String): Boolean; -var I: Integer; +function TParser.ParseSongHeader (const Filename: IPath): Boolean; +var + I: Integer; + Stream: TBinaryFileStream; begin Result := False; - if FileExists(Filename) then + + if Filename.IsFile() then begin SSFile := TStringList.Create; - SSFile.Clear; - + Stream := TBinaryFileStream.Create(Filename, fmOpenRead); try - SSFile.LoadFromFile(Filename); + SSFile.LoadFromStream(Stream); If (SSFile.Count > 0) then begin @@ -207,6 +220,7 @@ begin finally SSFile.Free; + Stream.Free; end; end else @@ -569,18 +583,20 @@ begin Result := true; end; -Function TParser.ParseConfigforEdition(const Filename: String): String; +Function TParser.ParseConfigForEdition(const Filename: IPath): String; var txt: TStringlist; + Stream: TBinaryFileStream; I: Integer; J, K: Integer; S: String; begin Result := ''; - txt := TStringlist.Create; - try - txt.LoadFromFile(Filename); + Stream := TBinaryFileStream.Create(Filename, fmOpenRead); + try + txt := TStringlist.Create; + txt.LoadFromStream(Stream); For I := 0 to txt.Count-1 do begin S := Trim(txt.Strings[I]); @@ -600,6 +616,7 @@ begin Edition := Result; finally txt.Free; + Stream.Free; end; end; diff --git a/cmake/src/config-win.inc b/cmake/src/config-win.inc index e3ca8840..72e00aef 100644 --- a/cmake/src/config-win.inc +++ b/cmake/src/config-win.inc @@ -1,4 +1,4 @@ -{***************************************************************** +{***************************************************************** * Configuration file for UltraStar Deluxe 1.1 *****************************************************************} @@ -6,28 +6,28 @@ {$DEFINE HaveFFmpeg} {$IF Defined(HaveFFmpeg) and Defined(IncludeConstants)} - av__codec = 'avcodec-51'; - LIBAVCODEC_VERSION_MAJOR = 51; - LIBAVCODEC_VERSION_MINOR = 16; + av__codec = 'avcodec-52'; + LIBAVCODEC_VERSION_MAJOR = 52; + LIBAVCODEC_VERSION_MINOR = 45; LIBAVCODEC_VERSION_RELEASE = 0; - av__format = 'avformat-50'; - LIBAVFORMAT_VERSION_MAJOR = 50; - LIBAVFORMAT_VERSION_MINOR = 5; + av__format = 'avformat-52'; + LIBAVFORMAT_VERSION_MAJOR = 52; + LIBAVFORMAT_VERSION_MINOR = 46; LIBAVFORMAT_VERSION_RELEASE = 0; - av__util = 'avutil-49'; - LIBAVUTIL_VERSION_MAJOR = 49; - LIBAVUTIL_VERSION_MINOR = 0; - LIBAVUTIL_VERSION_RELEASE = 1; + av__util = 'avutil-50'; + LIBAVUTIL_VERSION_MAJOR = 50; + LIBAVUTIL_VERSION_MINOR = 7; + LIBAVUTIL_VERSION_RELEASE = 0; {$IFEND} -{$UNDEF HaveSWScale} +{$DEFINE HaveSWScale} {$IF Defined(HaveSWScale) and Defined(IncludeConstants)} sw__scale = 'swscale-0'; LIBSWSCALE_VERSION_MAJOR = 0; - LIBSWSCALE_VERSION_MINOR = 5; - LIBSWSCALE_VERSION_RELEASE = 0; + LIBSWSCALE_VERSION_MINOR = 7; + LIBSWSCALE_VERSION_RELEASE = 2; {$IFEND} {$DEFINE HaveProjectM} @@ -53,4 +53,3 @@ LIBSAMPLERATE_VERSION_MINOR = 1; LIBSAMPLERATE_VERSION_RELEASE = 3; {$IFEND} - diff --git a/cmake/src/config.inc.in b/cmake/src/config.inc.in index b955aa2c..7750a7aa 100644 --- a/cmake/src/config.inc.in +++ b/cmake/src/config.inc.in @@ -5,6 +5,10 @@ {* Libraries *} +{$IF Defined(IncludeConstants)} + lua_lib_name = '@lua_LIB_NAME@'; +{$IFEND} + {$CMAKEDEFINE(ffmpeg_FOUND) HaveFFmpeg} {$IF Defined(HaveFFmpeg) and Defined(IncludeConstants)} av__codec = 'libavcodec'; @@ -47,4 +51,3 @@ {$IFEND} {$CMAKEDEFINE(portmixer_FOUND) HavePortmixer} - diff --git a/cmake/src/encoding/Auto.inc b/cmake/src/encoding/Auto.inc new file mode 100644 index 00000000..f404c2f6 --- /dev/null +++ b/cmake/src/encoding/Auto.inc @@ -0,0 +1,137 @@ +{* UltraStar Deluxe - Karaoke Game
+ *
+ * UltraStar Deluxe is the legal property of its developers, whose names
+ * are too numerous to list here. Please refer to the COPYRIGHT
+ * file distributed with this source distribution.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301, USA.
+ *
+ * $URL$
+ * $Id$
+ *}
+
+// Auto
+// try to match the w3c regex and decode as unicode on match and as fallback if not match
+// (copied from http://www.w3.org/International/questions/qa-forms-utf-8.en.php)
+//
+// m/\A(
+// [\x09\x0A\x0D\x20-\x7E] # ASCII
+// | [\xC2-\xDF][\x80-\xBF] # non-overlong 2-byte
+// | \xE0[\xA0-\xBF][\x80-\xBF] # excluding overlongs
+// | [\xE1-\xEC\xEE\xEF][\x80-\xBF]{2} # straight 3-byte
+// | \xED[\x80-\x9F][\x80-\xBF] # excluding surrogates
+// | \xF0[\x90-\xBF][\x80-\xBF]{2} # planes 1-3
+// | [\xF1-\xF3][\x80-\xBF]{3} # planes 4-15
+// | \xF4[\x80-\x8F][\x80-\xBF]{2} # plane 16
+// )*\z/x
+
+type
+ TEncoderAuto = class(TEncoder)
+ public
+ function GetName(): AnsiString; override;
+ function Encode(const InStr: UCS4String; out OutStr: AnsiString): boolean; override;
+ function Decode(const InStr: AnsiString; out OutStr: UCS4String): boolean; override;
+
+ constructor Create(const UTF8Encoder, FallbackEncoder: IEncoder);
+
+ private
+ FallbackEncoder: IEncoder;
+ UTF8Encoder: IEncoder;
+ Regex: PPCRE;
+ RegexExtra: PPCREExtra;
+ end;
+
+function PCREGetMem(Size: SizeInt): Pointer; cdecl;
+begin
+ GetMem(Result, Size);
+end;
+
+procedure PCREFreeMem(P: Pointer); cdecl;
+begin
+ FreeMem(P);
+end;
+
+// NOTICE: Log.LogError/ConsoleWriteLn/DebugWriteLn are initialized yet
+procedure ShowError(const msg: string);
+begin
+ {$IFDEF CONSOLE}
+ WriteLn('ERROR: ', msg);
+ {$ENDIF}
+end;
+
+constructor TEncoderAuto.Create(const UTF8Encoder, FallbackEncoder: IEncoder);
+var
+ Error: PChar;
+ ErrorOffset: Integer;
+begin
+ inherited Create();
+ self.FallbackEncoder := FallbackEncoder;
+ self.UTF8Encoder := UTF8Encoder;
+
+ // Load and initialize PCRE Library
+ if LoadPCRE() then
+ begin
+ // compile regex
+ self.Regex := pcre_compile('\A([\x09\x0A\x0D\x20-\x7E]|[\xC2-\xDF][\x80-\xBF]|\xE0[\xA0-\xBF][\x80-\xBF]|[\xE1-\xEC\xEE\xEF][\x80-\xBF]{2}|\xED[\x80-\x9F][\x80-\xBF]|\xF0[\x90-\xBF][\x80-\xBF]{2}|[\xF1-\xF3][\x80-\xBF]{3}|\xF4[\x80-\x8F][\x80-\xBF]{2})*\z', 0, @Error, @ErrorOffset, nil);
+
+ if self.Regex = Nil then
+ begin
+ ShowError(Format('UTF8 Regex compilation failed: %s at %d', [Error, ErrorOffset]));
+ end
+ else
+ begin
+ // if compiled successfull, try to get more informations the speed up the matching
+ self.RegexExtra := pcre_study(self.Regex, 0, @Error);
+
+ if Error <> Nil then
+ begin
+ ShowError('UTF8 Regex study failed: ' + Error);
+ end;
+ end;
+ end
+ else
+ begin
+ ShowError('pcre not loaded. utf-8 autodetection will not work.');
+ end;
+end;
+
+function TEncoderAuto.GetName(): AnsiString;
+begin
+ Result := 'Auto';
+end;
+
+function TEncoderAuto.Decode(const InStr: AnsiString; out OutStr: UCS4String): boolean;
+var
+ RegexResults: Integer;
+begin
+ if (self.Regex <> Nil) then
+ begin
+ RegexResults := pcre_exec(Regex, RegexExtra, PChar(InStr), Length(InStr), 0, 0, Nil, 0);
+
+ if RegexResults >= 0 then
+ begin
+ Result := UTF8Encoder.Decode(InStr, OutStr);
+ Exit;
+ end;
+ end;
+
+ Result := FallbackEncoder.Decode(InStr, OutStr);
+end;
+
+function TEncoderAuto.Encode(const InStr: UCS4String; out OutStr: AnsiString): boolean;
+begin
+ Result := UTF8Encoder.Encode(InStr, OutStr);
+end;
diff --git a/cmake/src/encoding/CP1250.inc b/cmake/src/encoding/CP1250.inc new file mode 100644 index 00000000..5628156e --- /dev/null +++ b/cmake/src/encoding/CP1250.inc @@ -0,0 +1,236 @@ +{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +{* + * Windows-1250 Central/Eastern Europe + * (used by Ultrastar) + *} + +type + TEncoderCP1250 = class(TSingleByteEncoder) + public + function GetName(): AnsiString; override; + function DecodeChar(InChr: AnsiChar; out OutChr: UCS4Char): boolean; override; + function EncodeChar(InChr: UCS4Char; out OutChr: AnsiChar): boolean; override; + end; + +function TEncoderCP1250.GetName(): AnsiString; +begin + Result := 'CP1250'; +end; + +const + // Positions marked as #0 are invalid. + CP1250Table: array[128..255] of UCS4Char = ( + { $80 } + $20AC, 0, $201A, 0, $201E, $2026, $2020, $2021, + 0, $2030, $0160, $2039, $015A, $0164, $017D, $0179, + { $90 } + 0, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + 0, $2122, $0161, $203A, $015B, $0165, $017E, $017A, + { $A0 } + $00A0, $02C7, $02D8, $0141, $00A4, $0104, $00A6, $00A7, + $00A8, $00A9, $015E, $00AB, $00AC, $00AD, $00AE, $017B, + { $B0 } + $00B0, $00B1, $02DB, $0142, $00B4, $00B5, $00B6, $00B7, + $00B8, $0105, $015F, $00BB, $013D, $02DD, $013E, $017C, + { $C0 } + $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7, + $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E, + { $D0 } + $0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7, + $0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF, + { $E0 } + $0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7, + $010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F, + { $F0 } + $0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7, + $0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9 + ); + +function TEncoderCP1250.DecodeChar(InChr: AnsiChar; out OutChr: UCS4Char): boolean; +begin + Result := true; + if (InChr < #128) then + OutChr := UCS4Char(Ord(InChr)) // use Ord() to avoid automatic conversion + else + begin + OutChr := CP1250Table[Ord(InChr)]; + if (OutChr = 0) then + begin + Result := false; + OutChr := Ord(ERROR_CHAR); + end; + end; +end; + +function TEncoderCP1250.EncodeChar(InChr: UCS4Char; out OutChr: AnsiChar): boolean; +begin + if (InChr < 128) then + begin + OutChr := AnsiChar(Ord(InChr)); + Result := true; + end + else + begin + case InChr of + $20AC: OutChr := #128; + // invalid: #129 + $201A: OutChr := #130; + // invalid: #131 + $201E: OutChr := #132; + $2026: OutChr := #133; + $2020: OutChr := #134; + $2021: OutChr := #135; + // invalid: #136 + $2030: OutChr := #137; + $0160: OutChr := #138; + $2039: OutChr := #139; + $015A: OutChr := #140; + $0164: OutChr := #141; + $017D: OutChr := #142; + $0179: OutChr := #143; + // invalid: #144 + $2018: OutChr := #145; + $2019: OutChr := #146; + $201C: OutChr := #147; + $201D: OutChr := #148; + $2022: OutChr := #149; + $2013: OutChr := #150; + $2014: OutChr := #151; + // invalid: #152 + $2122: OutChr := #153; + $0161: OutChr := #154; + $203A: OutChr := #155; + $015B: OutChr := #156; + $0165: OutChr := #157; + $017E: OutChr := #158; + $017A: OutChr := #159; + $00A0: OutChr := #160; + $02C7: OutChr := #161; + $02D8: OutChr := #162; + $0141: OutChr := #163; + $00A4: OutChr := #164; + $0104: OutChr := #165; + $00A6: OutChr := #166; + $00A7: OutChr := #167; + $00A8: OutChr := #168; + $00A9: OutChr := #169; + $015E: OutChr := #170; + $00AB: OutChr := #171; + $00AC: OutChr := #172; + $00AD: OutChr := #173; + $00AE: OutChr := #174; + $017B: OutChr := #175; + $00B0: OutChr := #176; + $00B1: OutChr := #177; + $02DB: OutChr := #178; + $0142: OutChr := #179; + $00B4: OutChr := #180; + $00B5: OutChr := #181; + $00B6: OutChr := #182; + $00B7: OutChr := #183; + $00B8: OutChr := #184; + $0105: OutChr := #185; + $015F: OutChr := #186; + $00BB: OutChr := #187; + $013D: OutChr := #188; + $02DD: OutChr := #189; + $013E: OutChr := #190; + $017C: OutChr := #191; + $0154: OutChr := #192; + $00C1: OutChr := #193; + $00C2: OutChr := #194; + $0102: OutChr := #195; + $00C4: OutChr := #196; + $0139: OutChr := #197; + $0106: OutChr := #198; + $00C7: OutChr := #199; + $010C: OutChr := #200; + $00C9: OutChr := #201; + $0118: OutChr := #202; + $00CB: OutChr := #203; + $011A: OutChr := #204; + $00CD: OutChr := #205; + $00CE: OutChr := #206; + $010E: OutChr := #207; + $0110: OutChr := #208; + $0143: OutChr := #209; + $0147: OutChr := #210; + $00D3: OutChr := #211; + $00D4: OutChr := #212; + $0150: OutChr := #213; + $00D6: OutChr := #214; + $00D7: OutChr := #215; + $0158: OutChr := #216; + $016E: OutChr := #217; + $00DA: OutChr := #218; + $0170: OutChr := #219; + $00DC: OutChr := #220; + $00DD: OutChr := #221; + $0162: OutChr := #222; + $00DF: OutChr := #223; + $0155: OutChr := #224; + $00E1: OutChr := #225; + $00E2: OutChr := #226; + $0103: OutChr := #227; + $00E4: OutChr := #228; + $013A: OutChr := #229; + $0107: OutChr := #230; + $00E7: OutChr := #231; + $010D: OutChr := #232; + $00E9: OutChr := #233; + $0119: OutChr := #234; + $00EB: OutChr := #235; + $011B: OutChr := #236; + $00ED: OutChr := #237; + $00EE: OutChr := #238; + $010F: OutChr := #239; + $0111: OutChr := #240; + $0144: OutChr := #241; + $0148: OutChr := #242; + $00F3: OutChr := #243; + $00F4: OutChr := #244; + $0151: OutChr := #245; + $00F6: OutChr := #246; + $00F7: OutChr := #247; + $0159: OutChr := #248; + $016F: OutChr := #249; + $00FA: OutChr := #250; + $0171: OutChr := #251; + $00FC: OutChr := #252; + $00FD: OutChr := #253; + $0163: OutChr := #254; + $02D9: OutChr := #255; + else begin + OutChr := ERROR_CHAR; + Result := false; + Exit; + end; + end; + Result := true; + end; +end; + diff --git a/cmake/src/encoding/CP1252.inc b/cmake/src/encoding/CP1252.inc new file mode 100644 index 00000000..f7d3f8ea --- /dev/null +++ b/cmake/src/encoding/CP1252.inc @@ -0,0 +1,122 @@ +{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +{* + * Windows-1252 Western Europe + * (used by UltraStar Deluxe < 1.1) + *} + +type + TEncoderCP1252 = class(TSingleByteEncoder) + public + function GetName(): AnsiString; override; + function DecodeChar(InChr: AnsiChar; out OutChr: UCS4Char): boolean; override; + function EncodeChar(InChr: UCS4Char; out OutChr: AnsiChar): boolean; override; + end; + +function TEncoderCP1252.GetName(): AnsiString; +begin + Result := 'CP1252'; +end; + +const + // Positions marked as #0 are invalid. + CP1252Table: array[128..159] of UCS4Char = ( + { $80 } + $20AC, 0, $201A, $0192, $201E, $2026, $2020, $2021, + $02C6, $2030, $0160, $2039, $0152, 0, $017D, 0, + { $90 } + 0, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $02DC, $2122, $0161, $203A, $0153, 0, $017E, $0178 + ); + +function TEncoderCP1252.DecodeChar(InChr: AnsiChar; out OutChr: UCS4Char): boolean; +begin + Result := true; + if (InChr < #128) or (InChr >= #160) then + OutChr := UCS4Char(Ord(InChr)) // use Ord() to avoid automatic conversion + else + begin + OutChr := CP1252Table[Ord(InChr)]; + if (OutChr = 0) then + begin + Result := false; + OutChr := Ord(ERROR_CHAR); + end; + end; +end; + +function TEncoderCP1252.EncodeChar(InChr: UCS4Char; out OutChr: AnsiChar): boolean; +begin + if (InChr < 128) or ((InChr >= 160) and (InChr <= 255)) then + begin + OutChr := AnsiChar(Ord(InChr)); + Result := true; + end + else + begin + case InChr of + $20AC: OutChr := #128; + // invalid: #129 + $201A: OutChr := #130; + $0192: OutChr := #131; + $201E: OutChr := #132; + $2026: OutChr := #133; + $2020: OutChr := #134; + $2021: OutChr := #135; + $02C6: OutChr := #136; + $2030: OutChr := #137; + $0160: OutChr := #138; + $2039: OutChr := #139; + $0152: OutChr := #140; + // invalid: #141 + $017D: OutChr := #142; + // invalid: #143 + // invalid: #144 + $2018: OutChr := #145; + $2019: OutChr := #146; + $201C: OutChr := #147; + $201D: OutChr := #148; + $2022: OutChr := #149; + $2013: OutChr := #150; + $2014: OutChr := #151; + $02DC: OutChr := #152; + $2122: OutChr := #153; + $0161: OutChr := #154; + $203A: OutChr := #155; + $0153: OutChr := #156; + // invalid: #157 + $017E: OutChr := #158; + $0178: OutChr := #159; + else begin + OutChr := ERROR_CHAR; + Result := false; + Exit; + end; + end; + Result := true; + end; +end; + diff --git a/cmake/src/encoding/Locale.inc b/cmake/src/encoding/Locale.inc new file mode 100644 index 00000000..a3cdcebc --- /dev/null +++ b/cmake/src/encoding/Locale.inc @@ -0,0 +1,55 @@ +{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +{* + * Locale + *} + +type + TEncoderLocale = class(TEncoder) + public + function GetName(): AnsiString; override; + function Encode(const InStr: UCS4String; out OutStr: AnsiString): boolean; override; + function Decode(const InStr: AnsiString; out OutStr: UCS4String): boolean; override; + end; + +function TEncoderLocale.GetName(): AnsiString; +begin + Result := 'LOCALE'; +end; + +function TEncoderLocale.Decode(const InStr: AnsiString; out OutStr: UCS4String): boolean; +begin + OutStr := WideStringToUCS4String(InStr); // use implicit conversion + Result := true; +end; + +function TEncoderLocale.Encode(const InStr: UCS4String; out OutStr: AnsiString): boolean; +begin + OutStr := UCS4StringToWideString(InStr); // use implicit conversion + // any way to check for errors? + Result := true; +end; + diff --git a/cmake/src/encoding/UTF8.inc b/cmake/src/encoding/UTF8.inc new file mode 100644 index 00000000..43eacfbd --- /dev/null +++ b/cmake/src/encoding/UTF8.inc @@ -0,0 +1,70 @@ +{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +{* + * UTF-8 + *} + +type + TEncoderUTF8 = class(TEncoder) + public + function GetName(): AnsiString; override; + function Encode(const InStr: UCS4String; out OutStr: AnsiString): boolean; override; + function Decode(const InStr: AnsiString; out OutStr: UCS4String): boolean; override; + end; + +function TEncoderUTF8.GetName(): AnsiString; +begin + Result := 'UTF8'; +end; + +function TEncoderUTF8.Decode(const InStr: AnsiString; out OutStr: UCS4String): boolean; +var + I: integer; + StrPtr: PAnsiChar; +begin + // UTF8Decode() may crash with FPC < 2.2.2 if the input string is not UTF-8 + // encoded. Newer versions do not crash but do not signal errors either. + // So let's implement this stuff again. + Result := true; + SetLength(OutStr, Length(InStr)+1); + I := 0; + StrPtr := PChar(InStr); + while (StrPtr^ <> #0) do + begin + if (not NextCharUTF8(StrPtr, OutStr[I])) then + Result := false;; + Inc(I); + end; + SetLength(OutStr, I+1); + OutStr[High(OutStr)] := 0; +end; + +function TEncoderUTF8.Encode(const InStr: UCS4String; out OutStr: AnsiString): boolean; +begin + OutStr := UCS4ToUTF8String(InStr); + Result := true; +end; + diff --git a/cmake/src/lib/FreeImage/FreeBitmap.pas b/cmake/src/lib/FreeImage/FreeBitmap.pas index 4e5f50a4..d32fb5cb 100644 --- a/cmake/src/lib/FreeImage/FreeBitmap.pas +++ b/cmake/src/lib/FreeImage/FreeBitmap.pas @@ -33,7 +33,7 @@ unit FreeBitmap; {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} interface diff --git a/cmake/src/lib/JEDI-SDL/OpenGL/Pas/glext.pas b/cmake/src/lib/JEDI-SDL/OpenGL/Pas/glext.pas index 1fc70f8a..871247a9 100644 --- a/cmake/src/lib/JEDI-SDL/OpenGL/Pas/glext.pas +++ b/cmake/src/lib/JEDI-SDL/OpenGL/Pas/glext.pas @@ -4282,32 +4282,33 @@ begin if (Pos(' ', extension) <> 0) or (extension = '') then begin - Result := FALSE; + Result := false; Exit; end; if searchIn = '' then extensions := glGetString(GL_EXTENSIONS) else - //StrLCopy( extensions, searchIn, StrLen(searchIn)+1 ); + //StrLCopy(extensions, searchIn, StrLen(searchIn) + 1); extensions := searchIn; start := extensions; - while TRUE do + while true do begin - where := StrPos(start, extension ); - if where = nil then Break; - terminator := Pointer(Integer(where) + Integer( strlen( extension ) ) ); - if (where = start) or (PChar(Integer(where) - 1)^ = ' ') then + where := StrPos(start, extension); + if where = nil then + Break; + terminator := where + Length(extension); + if (where = start) or ((where - 1)^ = ' ') then begin if (terminator^ = ' ') or (terminator^ = #0) then begin - Result := TRUE; + Result := true; Exit; end; end; start := terminator; end; - Result := FALSE; + Result := false; end; diff --git a/cmake/src/lib/JEDI-SDL/SDL/Pas/jedi-sdl.inc b/cmake/src/lib/JEDI-SDL/SDL/Pas/jedi-sdl.inc index fed972b5..31817d24 100644 --- a/cmake/src/lib/JEDI-SDL/SDL/Pas/jedi-sdl.inc +++ b/cmake/src/lib/JEDI-SDL/SDL/Pas/jedi-sdl.inc @@ -332,7 +332,7 @@ {$ELSE} {$DEFINE __OS_DOS__} {$ENDIF} - {$IFDEF WIN32} + {$IFDEF MSWINDOWS} {$DEFINE UseWin} {$ENDIF} {$DEFINE HAS_TYPES} @@ -380,13 +380,13 @@ {$OA+} // Objects and structures align {$ENDIF} -{$IFDEF Win32} +{$IFDEF MSWINDOWS} {$DEFINE OS_BigMem} -{$ELSE Win32} +{$ELSE MSWINDOWS} {$IFDEF ver70} {$DEFINE assembler} {$ENDIF} { use 16-bit assembler! } -{$ENDIF Win32} +{$ENDIF MSWINDOWS} { ************************** dos/dos-like platforms **************} {$IFDEF Windows} diff --git a/cmake/src/lib/JEDI-SDL/SDL/Pas/moduleloader.pas b/cmake/src/lib/JEDI-SDL/SDL/Pas/moduleloader.pas index ea4f220c..796aa0ab 100644 --- a/cmake/src/lib/JEDI-SDL/SDL/Pas/moduleloader.pas +++ b/cmake/src/lib/JEDI-SDL/SDL/Pas/moduleloader.pas @@ -59,7 +59,7 @@ interface // each OS gets its own IFDEFed complete code block to make reading easier -{$IFDEF WIN32} +{$IFDEF MSWINDOWS} uses Windows; diff --git a/cmake/src/lib/JEDI-SDL/SDL/Pas/sdl.pas b/cmake/src/lib/JEDI-SDL/SDL/Pas/sdl.pas index 0d7e46af..736009c2 100644 --- a/cmake/src/lib/JEDI-SDL/SDL/Pas/sdl.pas +++ b/cmake/src/lib/JEDI-SDL/SDL/Pas/sdl.pas @@ -370,7 +370,7 @@ const {$IFDEF DARWIN} SDLLibName = 'libSDL-1.2.0.dylib'; {$linklib libSDL-1.2.0} - {$linklib gcc} +// {$linklib gcc} {$linklib SDLmain} {$linkframework Cocoa} {$PASCALMAINNAME SDL_main} diff --git a/cmake/src/lib/Lua/ULua.pas b/cmake/src/lib/Lua/ULua.pas new file mode 100644 index 00000000..1de48a3c --- /dev/null +++ b/cmake/src/lib/Lua/ULua.pas @@ -0,0 +1,1086 @@ +unit ULua; + +(* + * A complete Pascal wrapper for Lua 5.1 DLL module. + * + * Created by Geo Massar, 2006 + * Distributed as free/open source. + *) + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$IFDEF UNIX} +uses + dl, + UConfig; +{$ENDIF} + +{$DEFINE LUA51} + +type + size_t = type Cardinal; + Psize_t = ^size_t; + PPointer = ^Pointer; + + lua_State = record end; + Plua_State = ^lua_State; + +const +{$IFDEF WIN32} + LuaDLL = 'lua5.1.dll'; +{$ENDIF} +{$IFDEF UNIX} +{$IFDEF DARWIN} + LuaDLL = 'liblua.5.1.dylib'; + {$linklib liblua.5.1} +{$ELSE} + LuaDLL = lua_lib_name; +{$ENDIF} +{$ENDIF} +{$IFDEF MACOS} + SDLgfxLibName = 'lua5.1'; +{$ENDIF} + +(* formats for Lua numbers *) +{$IFNDEF LUA_NUMBER_SCAN} +const + LUA_NUMBER_SCAN = '%lf'; +{$ENDIF} + +{$IFNDEF LUA_NUMBER_FMT} +const + LUA_NUMBER_FMT = '%.14g'; +{$ENDIF} + +(*****************************************************************************) +(* luaconfig.h *) +(*****************************************************************************) + +(* +** $Id: luaconf.h,v 1.81 2006/02/10 17:44:06 roberto Exp $ +** Configuration file for Lua +** See Copyright Notice in lua.h +*) + +(* +** {================================================================== +@@ LUA_NUMBER is the type of numbers in Lua. +** CHANGE the following definitions only if you want to build Lua +** with a number type different from double. You may also need to +** change lua_number2int & lua_number2integer. +** =================================================================== +*) +type + LUA_NUMBER_ = type Double; // ending underscore is needed in Pascal + LUA_INTEGER_ = type Integer; + +(* +@@ LUA_IDSIZE gives the maximum size for the description of the source +@* of a function in debug information. +** CHANGE it if you want a different size. +*) +const + LUA_IDSIZE = 60; + +(* +@@ LUAL_BUFFERSIZE is the buffer size used by the lauxlib buffer system. +*) +const + LUAL_BUFFERSIZE = 1024; + +(* +@@ LUA_PROMPT is the default prompt used by stand-alone Lua. +@@ LUA_PROMPT2 is the default continuation prompt used by stand-alone Lua. +** CHANGE them if you want different prompts. (You can also change the +** prompts dynamically, assigning to globals _PROMPT/_PROMPT2.) +*) +const + LUA_PROMPT = '> '; + LUA_PROMPT2 = '>> '; + +(* +@@ lua_readline defines how to show a prompt and then read a line from +@* the standard input. +@@ lua_saveline defines how to "save" a read line in a "history". +@@ lua_freeline defines how to free a line read by lua_readline. +** CHANGE them if you want to improve this functionality (e.g., by using +** GNU readline and history facilities). +*) +function lua_readline(L : Plua_State; var b : PChar; p : PChar): Boolean; +procedure lua_saveline(L : Plua_State; idx : Integer); +procedure lua_freeline(L : Plua_State; b : PChar); + +(* +@@ lua_stdin_is_tty detects whether the standard input is a 'tty' (that +@* is, whether we're running lua interactively). +** CHANGE it if you have a better definition for non-POSIX/non-Windows +** systems. +*/ +#include <io.h> +#include <stdio.h> +#define lua_stdin_is_tty() _isatty(_fileno(stdin)) +*) +const + lua_stdin_is_tty = TRUE; + +(*****************************************************************************) +(* lua.h *) +(*****************************************************************************) + +(* +** $Id: lua.h,v 1.216 2006/01/10 12:50:13 roberto Exp $ +** Lua - An Extensible Extension Language +** Lua.org, PUC-Rio, Brazil (http://www.lua.org) +** See Copyright Notice at the end of this file +*) + +const + LUA_VERSION = 'Lua 5.1'; + LUA_VERSION_NUM = 501; + LUA_COPYRIGHT = 'Copyright (C) 1994-2006 Tecgraf, PUC-Rio'; + LUA_AUTHORS = 'R. Ierusalimschy, L. H. de Figueiredo & W. Celes'; + + (* mark for precompiled code (`<esc>Lua') *) + LUA_SIGNATURE = #27'Lua'; + + (* option for multiple returns in `lua_pcall' and `lua_call' *) + LUA_MULTRET = -1; + + (* + ** pseudo-indices + *) + LUA_REGISTRYINDEX = -10000; + LUA_ENVIRONINDEX = -10001; + LUA_GLOBALSINDEX = -10002; + +function lua_upvalueindex(idx : Integer) : Integer; // a marco + +const + (* thread status; 0 is OK *) + LUA_YIELD_ = 1; // Note: the ending underscore is needed in Pascal + LUA_ERRRUN = 2; + LUA_ERRSYNTAX = 3; + LUA_ERRMEM = 4; + LUA_ERRERR = 5; + +type + lua_CFunction = function(L : Plua_State) : Integer; cdecl; + + (* + ** functions that read/write blocks when loading/dumping Lua chunks + *) + lua_Reader = function (L : Plua_State; ud : Pointer; + sz : Psize_t) : PChar; cdecl; + lua_Writer = function (L : Plua_State; const p : Pointer; sz : size_t; + ud : Pointer) : Integer; cdecl; + + (* + ** prototype for memory-allocation functions + *) + lua_Alloc = function (ud, ptr : Pointer; + osize, nsize : size_t) : Pointer; cdecl; + +const + (* + ** basic types + *) + LUA_TNONE = -1; + + LUA_TNIL = 0; + LUA_TBOOLEAN = 1; + LUA_TLIGHTUSERDATA = 2; + LUA_TNUMBER = 3; + LUA_TSTRING = 4; + LUA_TTABLE = 5; + LUA_TFUNCTION = 6; + LUA_TUSERDATA = 7; + LUA_TTHREAD = 8; + + (* minimum Lua stack available to a C function *) + LUA_MINSTACK = 20; + +type + (* type of numbers in Lua *) + lua_Number = LUA_NUMBER_; + + (* type for integer functions *) + lua_Integer = LUA_INTEGER_; + +(* +** state manipulation +*) +function lua_newstate(f : lua_Alloc; ud : Pointer) : Plua_State; + cdecl; external LuaDLL; +procedure lua_close(L: Plua_State); + cdecl; external LuaDLL; +function lua_newthread(L : Plua_State) : Plua_State; + cdecl; external LuaDLL; + +function lua_atpanic(L : Plua_State; panicf : lua_CFunction) : lua_CFunction; + cdecl; external LuaDLL; + + +(* +** basic stack manipulation +*) +function lua_gettop(L : Plua_State) : Integer; + cdecl; external LuaDLL; +procedure lua_settop(L : Plua_State; idx : Integer); + cdecl; external LuaDLL; +procedure lua_pushvalue(L : Plua_State; idx : Integer); + cdecl; external LuaDLL; +procedure lua_remove(L : Plua_State; idx : Integer); + cdecl; external LuaDLL; +procedure lua_insert(L : Plua_State; idx : Integer); + cdecl; external LuaDLL; +procedure lua_replace(L : Plua_State; idx : Integer); + cdecl; external LuaDLL; +function lua_checkstack(L : Plua_State; sz : Integer) : LongBool; + cdecl; external LuaDLL; + +procedure lua_xmove(src, dest : Plua_State; n : Integer); + cdecl; external LuaDLL; + + +(* +** access functions (stack -> C) +*) +function lua_isnumber(L : Plua_State; idx : Integer) : LongBool; + cdecl; external LuaDLL; +function lua_isstring(L : Plua_State; idx : Integer) : LongBool; + cdecl; external LuaDLL; +function lua_iscfunction(L : Plua_State; idx : Integer) : LongBool; + cdecl; external LuaDLL; +function lua_isuserdata(L : Plua_State; idx : Integer) : LongBool; + cdecl; external LuaDLL; +function lua_type(L : Plua_State; idx : Integer) : Integer; + cdecl; external LuaDLL; +function lua_typename(L : Plua_State; tp : Integer) : PChar; + cdecl; external LuaDLL; + +function lua_equal(L : Plua_State; idx1, idx2 : Integer) : LongBool; + cdecl; external LuaDLL; +function lua_rawequal(L : Plua_State; idx1, idx2 : Integer) : LongBool; + cdecl; external LuaDLL; +function lua_lessthan(L : Plua_State; idx1, idx2 : Integer) : LongBool; + cdecl; external LuaDLL; + +function lua_tonumber(L : Plua_State; idx : Integer) : lua_Number; + cdecl; external LuaDLL; +function lua_tointeger(L : Plua_State; idx : Integer) : lua_Integer; + cdecl; external LuaDLL; +function lua_toboolean(L : Plua_State; idx : Integer) : LongBool; + cdecl; external LuaDLL; +function lua_tolstring(L : Plua_State; idx : Integer; + len : Psize_t) : PChar; + cdecl; external LuaDLL; +function lua_objlen(L : Plua_State; idx : Integer) : size_t; + cdecl; external LuaDLL; +function lua_tocfunction(L : Plua_State; idx : Integer) : lua_CFunction; + cdecl; external LuaDLL; +function lua_touserdata(L : Plua_State; idx : Integer) : Pointer; + cdecl; external LuaDLL; +function lua_tothread(L : Plua_State; idx : Integer) : Plua_State; + cdecl; external LuaDLL; +function lua_topointer(L : Plua_State; idx : Integer) : Pointer; + cdecl; external LuaDLL; + + +(* +** push functions (C -> stack) +*) +procedure lua_pushnil(L : Plua_State); + cdecl; external LuaDLL; +procedure lua_pushnumber(L : Plua_State; n : lua_Number); + cdecl; external LuaDLL; +procedure lua_pushinteger(L : Plua_State; n : lua_Integer); + cdecl; external LuaDLL; +procedure lua_pushlstring(L : Plua_State; const s : PChar; ls : size_t); + cdecl; external LuaDLL; +procedure lua_pushstring(L : Plua_State; const s : PChar); + cdecl; external LuaDLL; +function lua_pushvfstring(L : Plua_State; + const fmt : PChar; argp : Pointer) : PChar; + cdecl; external LuaDLL; +function lua_pushfstring(L : Plua_State; const fmt : PChar) : PChar; varargs; + cdecl; external LuaDLL; +procedure lua_pushcclosure(L : Plua_State; fn : lua_CFunction; n : Integer); + cdecl; external LuaDLL; +procedure lua_pushboolean(L : Plua_State; b : LongBool); + cdecl; external LuaDLL; +procedure lua_pushlightuserdata(L : Plua_State; p : Pointer); + cdecl; external LuaDLL; +function lua_pushthread(L : Plua_state) : Cardinal; + cdecl; external LuaDLL; + + +(* +** get functions (Lua -> stack) +*) +procedure lua_gettable(L : Plua_State ; idx : Integer); + cdecl; external LuaDLL; +procedure lua_getfield(L : Plua_State; idx : Integer; k : PChar); + cdecl; external LuaDLL; +procedure lua_rawget(L : Plua_State; idx : Integer); + cdecl; external LuaDLL; +procedure lua_rawgeti(L : Plua_State; idx, n : Integer); + cdecl; external LuaDLL; +procedure lua_createtable(L : Plua_State; narr, nrec : Integer); + cdecl; external LuaDLL; +function lua_newuserdata(L : Plua_State; sz : size_t) : Pointer; + cdecl; external LuaDLL; +function lua_getmetatable(L : Plua_State; objindex : Integer) : LongBool; + cdecl; external LuaDLL; +procedure lua_getfenv(L : Plua_State; idx : Integer); + cdecl; external LuaDLL; + + +(* +** set functions (stack -> Lua) +*) +procedure lua_settable(L : Plua_State; idx : Integer); + cdecl; external LuaDLL; +procedure lua_setfield(L : Plua_State; idx : Integer; const k : PChar); + cdecl; external LuaDLL; +procedure lua_rawset(L : Plua_State; idx : Integer); + cdecl; external LuaDLL; +procedure lua_rawseti(L : Plua_State; idx , n: Integer); + cdecl; external LuaDLL; +function lua_setmetatable(L : Plua_State; objindex : Integer): LongBool; + cdecl; external LuaDLL; +function lua_setfenv(L : Plua_State; idx : Integer): LongBool; + cdecl; external LuaDLL; + +(* +** `load' and `call' functions (load and run Lua code) +*) +procedure lua_call(L : Plua_State; nargs, nresults : Integer); + cdecl; external LuaDLL; +function lua_pcall(L : Plua_State; + nargs, nresults, errfunc : Integer) : Integer; + cdecl; external LuaDLL; +function lua_cpcall(L : Plua_State; + func : lua_CFunction; ud : Pointer) : Integer; + cdecl; external LuaDLL; +function lua_load(L : Plua_State; reader : lua_Reader; + dt : Pointer; const chunkname : PChar) : Integer; + cdecl; external LuaDLL; + +function lua_dump(L : Plua_State; writer : lua_Writer; data: Pointer) : Integer; + cdecl; external LuaDLL; + + +(* +** coroutine functions +*) +function lua_yield(L : Plua_State; nresults : Integer) : Integer; + cdecl; external LuaDLL; +function lua_resume(L : Plua_State; narg : Integer) : Integer; + cdecl; external LuaDLL; +function lua_status(L : Plua_State) : Integer; + cdecl; external LuaDLL; + +(* +** garbage-collection functions and options +*) +const + LUA_GCSTOP = 0; + LUA_GCRESTART = 1; + LUA_GCCOLLECT = 2; + LUA_GCCOUNT = 3; + LUA_GCCOUNTB = 4; + LUA_GCSTEP = 5; + LUA_GCSETPAUSE = 6; + LUA_GCSETSTEPMUL = 7; + +function lua_gc(L : Plua_State; what, data : Integer) : Integer; + cdecl; external LuaDLL; + +(* +** miscellaneous functions +*) +function lua_error(L : Plua_State) : Integer; + cdecl; external LuaDLL; + +function lua_next(L : Plua_State; idx : Integer) : Integer; + cdecl; external LuaDLL; + +procedure lua_concat(L : Plua_State; n : Integer); + cdecl; external LuaDLL; + +function lua_getallocf(L : Plua_State; ud : PPointer) : lua_Alloc; + cdecl; external LuaDLL; +procedure lua_setallocf(L : Plua_State; f : lua_Alloc; ud : Pointer); + cdecl; external LuaDLL; + +(* +** =============================================================== +** some useful macros +** =============================================================== +*) +procedure lua_pop(L : Plua_State; n : Integer); + +procedure lua_newtable(L : Plua_State); + +procedure lua_register(L : Plua_State; n : PChar; f : lua_CFunction); + +procedure lua_pushcfunction(L : Plua_State; f : lua_CFunction); + +function lua_strlen(L : Plua_State; idx : Integer) : Integer; + +function lua_isfunction(L : Plua_State; n : Integer) : Boolean; +function lua_istable(L : Plua_State; n : Integer) : Boolean; +function lua_islightuserdata(L : Plua_State; n : Integer) : Boolean; +function lua_isnil(L : Plua_State; n : Integer) : Boolean; +function lua_isboolean(L : Plua_State; n : Integer) : Boolean; +function lua_isthread(L : Plua_State; n : Integer) : Boolean; +function lua_isnone(L : Plua_State; n : Integer) : Boolean; +function lua_isnoneornil(L : Plua_State; n : Integer) : Boolean; + +procedure lua_pushliteral(L : Plua_State; s : PChar); + +procedure lua_setglobal(L : Plua_State; s : PChar); +procedure lua_getglobal(L : Plua_State; s : PChar); + +function lua_tostring(L : Plua_State; idx : Integer) : PChar; + + +(* +** compatibility macros and functions +*) +function lua_open : Plua_State; + +procedure lua_getregistry(L : Plua_State); + +function lua_getgccount(L : Plua_State) : Integer; + +type + lua_Chuckreader = type lua_Reader; + lua_Chuckwriter = type lua_Writer; + +(* ====================================================================== *) + +(* +** {====================================================================== +** Debug API +** ======================================================================= +*) + +(* +** Event codes +*) +const + LUA_HOOKCALL = 0; + LUA_HOOKRET = 1; + LUA_HOOKLINE = 2; + LUA_HOOKCOUNT = 3; + LUA_HOOKTAILRET = 4; + + +(* +** Event masks +*) + LUA_MASKCALL = 1 shl LUA_HOOKCALL; + LUA_MASKRET = 1 shl LUA_HOOKRET; + LUA_MASKLINE = 1 shl LUA_HOOKLINE; + LUA_MASKCOUNT = 1 shl LUA_HOOKCOUNT; + +type + lua_Debug = packed record + event : Integer; + name : PChar; (* (n) *) + namewhat : PChar; (* (n) `global', `local', `field', `method' *) + what : PChar; (* (S) `Lua', `C', `main', `tail' *) + source : PChar; (* (S) *) + currentline : Integer; (* (l) *) + nups : Integer; (* (u) number of upvalues *) + linedefined : Integer; (* (S) *) + short_src : array [0..LUA_IDSIZE-1] of Char; (* (S) *) + (* private part *) + i_ci : Integer; (* active function *) + end; + Plua_Debug = ^lua_Debug; + + (* Functions to be called by the debuger in specific events *) + lua_Hook = procedure (L : Plua_State; ar : Plua_Debug); cdecl; + + +function lua_getstack(L : Plua_State; level : Integer; + ar : Plua_Debug) : Integer; + cdecl; external LuaDLL; +function lua_getinfo(L : Plua_State; const what : PChar; + ar: Plua_Debug): Integer; + cdecl; external LuaDLL; +function lua_getlocal(L : Plua_State; + ar : Plua_Debug; n : Integer) : PChar; + cdecl; external LuaDLL; +function lua_setlocal(L : Plua_State; + ar : Plua_Debug; n : Integer) : PChar; + cdecl; external LuaDLL; +function lua_getupvalue(L : Plua_State; funcindex, n : Integer) : PChar; + cdecl; external LuaDLL; +function lua_setupvalue(L : Plua_State; funcindex, n : Integer) : PChar; + cdecl; external LuaDLL; + +function lua_sethook(L : Plua_State; func : lua_Hook; + mask, count: Integer): Integer; + cdecl; external LuaDLL; +{ +function lua_gethook(L : Plua_State) : lua_Hook; + cdecl; external LuaDLL; +} +function lua_gethookmask(L : Plua_State) : Integer; + cdecl; external LuaDLL; +function lua_gethookcount(L : Plua_State) : Integer; + cdecl; external LuaDLL; + + +(*****************************************************************************) +(* lualib.h *) +(*****************************************************************************) + +(* +** $Id: lualib.h,v 1.36 2005/12/27 17:12:00 roberto Exp $ +** Lua standard libraries +** See Copyright Notice at the end of this file +*) + +const + (* Key to file-handle type *) + LUA_FILEHANDLE = 'FILE*'; + + LUA_COLIBNAME = 'coroutine'; + LUA_TABLIBNAME = 'table'; + LUA_IOLIBNAME = 'io'; + LUA_OSLIBNAME = 'os'; + LUA_STRLIBNAME = 'string'; + LUA_MATHLIBNAME = 'math'; + LUA_DBLIBNAME = 'debug'; + LUA_LOADLIBNAME = 'package'; + +function luaopen_base(L : Plua_State) : Integer; + cdecl; external LuaDLL; + +function luaopen_table(L : Plua_State) : Integer; + cdecl; external LuaDLL; + +function luaopen_io(L : Plua_State) : Integer; + cdecl; external LuaDLL; + +function luaopen_os(L : Plua_State) : Integer; + cdecl; external LuaDLL; + +function luaopen_string(L : Plua_State) : Integer; + cdecl; external LuaDLL; + +function luaopen_math(L : Plua_State) : Integer; + cdecl; external LuaDLL; + +function luaopen_debug(L : Plua_State) : Integer; + cdecl; external LuaDLL; + +function luaopen_package(L : Plua_State) : Integer; + cdecl; external LuaDLL; + +procedure luaL_openlibs(L : Plua_State); + cdecl; external LuaDLL; + +procedure lua_assert(x : Boolean); // a macro + + +(*****************************************************************************) +(* lauxlib.h *) +(*****************************************************************************) + +(* +** $Id: lauxlib.h,v 1.87 2005/12/29 15:32:11 roberto Exp $ +** Auxiliary functions for building Lua libraries +** See Copyright Notice at the end of this file. +*) + +// not compatibility with the behavior of setn/getn in Lua 5.0 +function luaL_getn(L : Plua_State; idx : Integer) : Integer; +procedure luaL_setn(L : Plua_State; i, j : Integer); + +const + LUA_ERRFILE = LUA_ERRERR + 1; + +type + luaL_Reg = packed record + name : PChar; + func : lua_CFunction; + end; + PluaL_Reg = ^luaL_Reg; + + +procedure luaL_openlib(L : Plua_State; const libname : PChar; + const lr : PluaL_Reg; nup : Integer); + cdecl; external LuaDLL; +procedure luaL_register(L : Plua_State; const libname : PChar; + const lr : PluaL_Reg); + cdecl; external LuaDLL; +function luaL_getmetafield(L : Plua_State; obj : Integer; + const e : PChar) : Integer; + cdecl; external LuaDLL; +function luaL_callmeta(L : Plua_State; obj : Integer; + const e : PChar) : Integer; + cdecl; external LuaDLL; +function luaL_typerror(L : Plua_State; narg : Integer; + const tname : PChar) : Integer; + cdecl; external LuaDLL; +function luaL_argerror(L : Plua_State; numarg : Integer; + const extramsg : PChar) : Integer; + cdecl; external LuaDLL; +function luaL_checklstring(L : Plua_State; numArg : Integer; + ls : Psize_t) : PChar; + cdecl; external LuaDLL; +function luaL_optlstring(L : Plua_State; numArg : Integer; + const def: PChar; ls: Psize_t) : PChar; + cdecl; external LuaDLL; +function luaL_checknumber(L : Plua_State; numArg : Integer) : lua_Number; + cdecl; external LuaDLL; +function luaL_optnumber(L : Plua_State; nArg : Integer; + def : lua_Number) : lua_Number; + cdecl; external LuaDLL; + +function luaL_checkinteger(L : Plua_State; numArg : Integer) : lua_Integer; + cdecl; external LuaDLL; +function luaL_optinteger(L : Plua_State; nArg : Integer; + def : lua_Integer) : lua_Integer; + cdecl; external LuaDLL; + +procedure luaL_checkstack(L : Plua_State; sz : Integer; const msg : PChar); + cdecl; external LuaDLL; +procedure luaL_checktype(L : Plua_State; narg, t : Integer); + cdecl; external LuaDLL; +procedure luaL_checkany(L : Plua_State; narg : Integer); + cdecl; external LuaDLL; + +function luaL_newmetatable(L : Plua_State; const tname : PChar) : Integer; + cdecl; external LuaDLL; +function luaL_checkudata(L : Plua_State; ud : Integer; + const tname : PChar) : Pointer; + cdecl; external LuaDLL; + +procedure luaL_where(L : Plua_State; lvl : Integer); + cdecl; external LuaDLL; +function luaL_error(L : Plua_State; const fmt : PChar) : Integer; varargs; + cdecl; external LuaDLL; + +function luaL_checkoption(L : Plua_State; narg : Integer; const def : PChar; + const lst : array of PChar) : Integer; + cdecl; external LuaDLL; + +function luaL_ref(L : Plua_State; t : Integer) : Integer; + cdecl; external LuaDLL; +procedure luaL_unref(L : Plua_State; t, ref : Integer); + cdecl; external LuaDLL; + +function luaL_loadfile(L : Plua_State; const filename : PChar) : Integer; + cdecl; external LuaDLL; +function luaL_loadbuffer(L : Plua_State; const buff : PChar; + sz : size_t; const name: PChar) : Integer; + cdecl; external LuaDLL; + +function luaL_loadstring(L : Plua_State; const s : Pchar) : Integer; + cdecl; external LuaDLL; + +function luaL_newstate : Plua_State; + cdecl; external LuaDLL; + +function luaL_gsub(L : Plua_State; const s, p, r : PChar) : PChar; + cdecl; external LuaDLL; + +function luaL_findtable(L : Plua_State; idx : Integer; + const fname : PChar; szhint : Integer) : PChar; + cdecl; external LuaDLL; + + +(* +** =============================================================== +** some useful macros +** =============================================================== +*) + +function luaL_argcheck(L : Plua_State; cond : Boolean; numarg : Integer; + extramsg : PChar): Integer; +function luaL_checkstring(L : Plua_State; n : Integer) : PChar; +function luaL_optstring(L : Plua_State; n : Integer; d : PChar) : PChar; +function luaL_checkint(L : Plua_State; n : Integer) : Integer; +function luaL_optint(L : Plua_State; n, d : Integer): Integer; +function luaL_checklong(L : Plua_State; n : LongInt) : LongInt; +function luaL_optlong(L : Plua_State; n : Integer; d : LongInt) : LongInt; + +function luaL_typename(L : Plua_State; idx : Integer) : PChar; + +function luaL_dofile(L : Plua_State; fn : PChar) : Integer; + +function luaL_dostring(L : Plua_State; s : PChar) : Integer; + +procedure luaL_getmetatable(L : Plua_State; n : PChar); + +(* not implemented yet +#define luaL_opt(L,f,n,d) (lua_isnoneornil(L,(n)) ? (d) : f(L,(n))) +*) + +(* +** {====================================================== +** Generic Buffer manipulation +** ======================================================= +*) + +type + luaL_Buffer = packed record + p : PChar; (* current position in buffer *) + lvl : Integer; (* number of strings in the stack (level) *) + L : Plua_State; + buffer : array [0..LUAL_BUFFERSIZE-1] of Char; + end; + PluaL_Buffer = ^luaL_Buffer; + +procedure luaL_addchar(B : PluaL_Buffer; c : Char); + +(* compatibility only *) +procedure luaL_putchar(B : PluaL_Buffer; c : Char); + +procedure luaL_addsize(B : PluaL_Buffer; n : Integer); + +procedure luaL_buffinit(L : Plua_State; B : PluaL_Buffer); + cdecl; external LuaDLL; +function luaL_prepbuffer(B : PluaL_Buffer) : PChar; + cdecl; external LuaDLL; +procedure luaL_addlstring(B : PluaL_Buffer; const s : PChar; ls : size_t); + cdecl; external LuaDLL; +procedure luaL_addstring(B : PluaL_Buffer; const s : PChar); + cdecl; external LuaDLL; +procedure luaL_addvalue(B : PluaL_Buffer); + cdecl; external LuaDLL; +procedure luaL_pushresult(B : PluaL_Buffer); + cdecl; external LuaDLL; + +(* ====================================================== *) + + +(* compatibility with ref system *) + +(* pre-defined references *) +const + LUA_NOREF = -2; + LUA_REFNIL = -1; + +function lua_ref(L : Plua_State; lock : Boolean) : Integer; + +procedure lua_unref(L : Plua_State; ref : Integer); + +procedure lua_getref(L : Plua_State; ref : Integer); + + +(******************************************************************************) +(******************************************************************************) +(******************************************************************************) + +implementation + +uses + SysUtils; + +(*****************************************************************************) +(* luaconfig.h *) +(*****************************************************************************) + +function lua_readline(L : Plua_State; var b : PChar; p : PChar): Boolean; +var + s : AnsiString; +begin + Write(p); // show prompt + ReadLn(s); // get line + b := PChar(s); // and return it + lua_readline := (b[0] <> #4); // test for ctrl-D +end; + +procedure lua_saveline(L : Plua_State; idx : Integer); +begin +end; + +procedure lua_freeline(L : Plua_State; b : PChar); +begin +end; + + +(*****************************************************************************) +(* lua.h *) +(*****************************************************************************) + +function lua_upvalueindex(idx : Integer) : Integer; +begin + lua_upvalueindex := LUA_GLOBALSINDEX - idx; +end; + +procedure lua_pop(L : Plua_State; n : Integer); +begin + lua_settop(L, -n - 1); +end; + +procedure lua_newtable(L : Plua_State); +begin + lua_createtable(L, 0, 0); +end; + +procedure lua_register(L : Plua_State; n : PChar; f : lua_CFunction); +begin + lua_pushcfunction(L, f); + lua_setglobal(L, n); +end; + +procedure lua_pushcfunction(L : Plua_State; f : lua_CFunction); +begin + lua_pushcclosure(L, f, 0); +end; + +function lua_strlen(L : Plua_State; idx : Integer) : Integer; +begin + lua_strlen := lua_objlen(L, idx); +end; + +function lua_isfunction(L : Plua_State; n : Integer) : Boolean; +begin + lua_isfunction := lua_type(L, n) = LUA_TFUNCTION; +end; + +function lua_istable(L : Plua_State; n : Integer) : Boolean; +begin + lua_istable := lua_type(L, n) = LUA_TTABLE; +end; + +function lua_islightuserdata(L : Plua_State; n : Integer) : Boolean; +begin + lua_islightuserdata := lua_type(L, n) = LUA_TLIGHTUSERDATA; +end; + +function lua_isnil(L : Plua_State; n : Integer) : Boolean; +begin + lua_isnil := lua_type(L, n) = LUA_TNIL; +end; + +function lua_isboolean(L : Plua_State; n : Integer) : Boolean; +begin + lua_isboolean := lua_type(L, n) = LUA_TBOOLEAN; +end; + +function lua_isthread(L : Plua_State; n : Integer) : Boolean; +begin + lua_isthread := lua_type(L, n) = LUA_TTHREAD; +end; + +function lua_isnone(L : Plua_State; n : Integer) : Boolean; +begin + lua_isnone := lua_type(L, n) = LUA_TNONE; +end; + +function lua_isnoneornil(L : Plua_State; n : Integer) : Boolean; +begin + lua_isnoneornil := lua_type(L, n) <= 0; +end; + +procedure lua_pushliteral(L : Plua_State; s : PChar); +begin + lua_pushlstring(L, s, StrLen(s)); +end; + +procedure lua_setglobal(L : Plua_State; s : PChar); +begin + lua_setfield(L, LUA_GLOBALSINDEX, s); +end; + +procedure lua_getglobal(L: Plua_State; s: PChar); +begin + lua_getfield(L, LUA_GLOBALSINDEX, s); +end; + +function lua_tostring(L : Plua_State; idx : Integer) : PChar; +begin + lua_tostring := lua_tolstring(L, idx, nil); +end; + +function lua_open : Plua_State; +begin + lua_open := luaL_newstate; +end; + +procedure lua_getregistry(L : Plua_State); +begin + lua_pushvalue(L, LUA_REGISTRYINDEX); +end; + +function lua_getgccount(L : Plua_State) : Integer; +begin + lua_getgccount := lua_gc(L, LUA_GCCOUNT, 0); +end; + + +(*****************************************************************************) +(* lualib.h *) +(*****************************************************************************) + +procedure lua_assert(x : Boolean); +begin +end; + + +(*****************************************************************************) +(* lauxlib.h n *) +(*****************************************************************************) + +function luaL_getn(L : Plua_State; idx : Integer) : Integer; +begin + luaL_getn := lua_objlen(L, idx); +end; + +procedure luaL_setn(L : plua_State; i, j : Integer); +begin + (* no op *) +end; + +function luaL_argcheck(L : Plua_State; cond : Boolean; numarg : Integer; + extramsg : PChar): Integer; +begin + if not cond then + luaL_argcheck := luaL_argerror(L, numarg, extramsg) + else + luaL_argcheck := 0; +end; + +function luaL_checkstring(L : Plua_State; n : Integer) : PChar; +begin + luaL_checkstring := luaL_checklstring(L, n, nil); +end; + +function luaL_optstring(L : Plua_State; n : Integer; d : PChar) : PChar; +begin + luaL_optstring := luaL_optlstring(L, n, d, nil); +end; + +function luaL_checkint(L : Plua_State; n : Integer) : Integer; +begin + luaL_checkint := luaL_checkinteger(L, n); +end; + +function luaL_optint(L : Plua_State; n, d : Integer): Integer; +begin + luaL_optint := luaL_optinteger(L, n, d); +end; + +function luaL_checklong(L : Plua_State; n : LongInt) : LongInt; +begin + luaL_checklong := luaL_checkinteger(L, n); +end; + +function luaL_optlong(L : Plua_State; n : Integer; d : LongInt) : LongInt; +begin + luaL_optlong := luaL_optinteger(L, n, d); +end; + +function luaL_typename(L : Plua_State; idx : Integer) : PChar; +begin + luaL_typename := lua_typename( L, lua_type(L, idx) ); +end; + +function luaL_dofile(L : Plua_State; fn : PChar) : Integer; +Var + Res : Integer; +begin + // WC 2007\03\22 - Updated for Delphi + Res := luaL_loadfile(L, fn); + if Res = 0 then + Res := lua_pcall(L, 0, LUA_MULTRET, 0); + Result := Res; +end; + +function luaL_dostring(L : Plua_State; s : PChar) : Integer; +Var + Res : Integer; +begin + // WC 2007\03\22 - Updated for Delphi + Res := luaL_loadstring(L, s); + if Res = 0 then + Res := lua_pcall(L, 0, LUA_MULTRET, 0); + Result := Res; +end; + +procedure luaL_getmetatable(L : Plua_State; n : PChar); +begin + lua_getfield(L, LUA_REGISTRYINDEX, n); +end; + +procedure luaL_addchar(B : PluaL_Buffer; c : Char); +begin + if not(B^.p < B^.buffer + LUAL_BUFFERSIZE) then + luaL_prepbuffer(B); + B^.p^ := c; + Inc(B^.p); +end; + +procedure luaL_putchar(B : PluaL_Buffer; c : Char); +begin + luaL_addchar(B, c); +end; + +procedure luaL_addsize(B : PluaL_Buffer; n : Integer); +begin + Inc(B^.p, n); +end; + +function lua_ref(L : Plua_State; lock : Boolean) : Integer; +begin + if lock then + lua_ref := luaL_ref(L, LUA_REGISTRYINDEX) + else begin + lua_pushstring(L, 'unlocked references are obsolete'); + lua_error(L); + lua_ref := 0; + end; +end; + +procedure lua_unref(L : Plua_State; ref : Integer); +begin + luaL_unref(L, LUA_REGISTRYINDEX, ref); +end; + +procedure lua_getref(L : Plua_State; ref : Integer); +begin + lua_rawgeti(L, LUA_REGISTRYINDEX, ref); +end; + + +(****************************************************************************** +* Original copyright for the lua source and headers: +* 1994-2004 Tecgraf, PUC-Rio. +* www.lua.org. +* +* +* Permission is hereby granted, free of charge, to any person obtaining +* a copy of this software and associated documentation files (the +* "Software"), to deal in the Software without restriction, including +* without limitation the rights to use, copy, modify, merge, publish, +* distribute, sublicense, and/or sell copies of the Software, and to +* permit persons to whom the Software is furnished to do so, subject to +* the following conditions: +* +* The above copyright notice and this permission notice shall be +* included in all copies or substantial portions of the Software. +* +* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +* IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +* CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +* TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +* SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +******************************************************************************) + +end. + diff --git a/cmake/src/lib/SQLite/SQLite3.pas b/cmake/src/lib/SQLite/SQLite3.pas index 9537606c..7b7207c4 100644 --- a/cmake/src/lib/SQLite/SQLite3.pas +++ b/cmake/src/lib/SQLite/SQLite3.pas @@ -10,7 +10,7 @@ unit SQLite3; {$IFDEF FPC} {$MODE DELPHI} - {$H+} (* use AnsiString *) + {$H+} (* use long strings *) {$PACKENUM 4} (* use 4-byte enums *) {$PACKRECORDS C} (* C/C++-compatible record packing *) {$ELSE} diff --git a/cmake/src/lib/SQLite/SQLiteTable3.pas b/cmake/src/lib/SQLite/SQLiteTable3.pas index 7df76363..3aed54a4 100644 --- a/cmake/src/lib/SQLite/SQLiteTable3.pas +++ b/cmake/src/lib/SQLite/SQLiteTable3.pas @@ -139,6 +139,7 @@ type procedure Commit; procedure Rollback; function TableExists(TableName: string): boolean; + function ContainsColumn(Table: String; Column: String) : boolean; function GetLastInsertRowID: int64; function GetLastChangedRows: int64; procedure SetTimeout(Value: integer); @@ -759,6 +760,26 @@ begin end; end; +function TSQLiteDatabase.ContainsColumn(Table: String; Column: String) : boolean; +var + sql: string; + ds: TSqliteTable; + i : integer; +begin + sql := 'PRAGMA TABLE_INFO('+Table+');'; + ds := self.GetTable(sql); + try + Result := false; + while (ds.Next() and not Result and not ds.EOF) do + begin + if ds.FieldAsString(1) = Column then + Result := true; + end; + finally + ds.Free; + end; +end; + procedure TSQLiteDatabase.SetTimeout(Value: integer); begin SQLite3_BusyTimeout(self.fDB, Value); diff --git a/cmake/src/lib/TntUnicodeControls/License.txt b/cmake/src/lib/TntUnicodeControls/License.txt new file mode 100644 index 00000000..8ac7f75b --- /dev/null +++ b/cmake/src/lib/TntUnicodeControls/License.txt @@ -0,0 +1,11 @@ +TntWare Delphi Unicode Controls + http://www.tntware.com/delphicontrols/unicode/ + +Copyright (c) 2002-2007, Troy Wolbrink (www.tntware.com) + +License +Redistribution and use in binary forms, with or without modification, are permitted. Redistribution and use in source forms, with or without modification, are permitted provided that the redistributions of source code retain the above copyright. + +Disclaimer +This software is provided by the author "as is" and any express or implied warranties, including, but not limited to, the implied warranties of merchantability and fitness for a particular purpose are disclaimed. In no event shall the author be liable for any direct, indirect, incidental, special, exemplary, or consequential damages (including, but not limited to, procurement of substitute goods or services; loss of use, data, or profits; or business interruption) however caused and on any theory of liability, whether in contract, strict liability, or tort (including negligence or otherwise) arising in any way out of the use of this software, even if advised of the possibility of such damage. + diff --git a/cmake/src/lib/TntUnicodeControls/Readme.txt b/cmake/src/lib/TntUnicodeControls/Readme.txt new file mode 100644 index 00000000..a2d8f799 --- /dev/null +++ b/cmake/src/lib/TntUnicodeControls/Readme.txt @@ -0,0 +1,53 @@ + ** Tnt Delphi UNICODE Controls Project ** + +Website: http://tnt.ccci.org/delphi_unicode_controls/ +Email: troy.wolbrink@ccci.org + +These controls are provided as-is, with no implied warranty. They are freely available for you to use in your own projects. Please let me know if you have found them helpful. Also, please let me know if you find any bugs or other areas of needed improvement. + + +---Delphi Installation-------------------------- + +The most simple way to install these components is by opening the appropriate design package in Delphi and clicking on the big "Install" button. For instance, Delphi 5's design package is TntUnicodeVcl_D50.dpk. + +For BCB 2006 and newer, open the appropriate design package in the packages\bcbx\ folder using the Delphi personality. After compiling and installing, you should be able to use the components in both the Delphi and BCB personality. Remember to set the library path in menu "Tools->Options" for both the C++ Builder and the Delphi. + + +---A note on fonts---------------------- + +The default TFont uses "MS Sans Serif" which doesn't work well with most non-ANSI characters. I'd recommend using a TrueType font such as "Tahoma" if it is installed on the machine. To make TFont use a different font like "Tahoma" add this to the first line in the project: + + Graphics.DefFontData.Name := 'Tahoma'; + +You might have to include "Graphics" in the file's uses clauses. Furthermore, adding this line of code to the project will cause the changed setting to only be applied at runtime, not at design time. To make a designtime change, you'd have to add this line to the initialization section of a unit in a design package. + +Regarding the IDE, I use GExperts to change the font of the Object Inspector. The Wide String List editor uses the font used by the object inspector. + +Also keep in mind that the font used by certain message boxes come from that set by Windows' Display properties. + + +---Background---------------------------- + +Designing software for an international audience, I've always wanted to write a full UNICODE application. My approach so far, has been to write Unicode on the inside, and MBCS on the outside. This has always been frustrating, because (even on Windows NT/2000/XP which provide native Unicode window controls) the WideStrings inside my application and databases were always confined to an ANSI VCL. And, since the VCL was designed to wrap the low-level Windows details, why shouldn't the VCL hide the fact that sometimes native Unicode controls are not possible on the given version of Windows. I believe the VCL should be written with a Unicode interface, even if it must (at times) deal with an ANSI operating system. For example, TEdit should expose Text as a WideString, even if it has to convert the WideString to an AnsiString on the Windows 9X platform. + +In the past, the ANSI VCL may have made a little sense, considering that there were many more users of Windows 9X, than Windows NT. There would have been some performance penalty to use WideStrings on the Windows 9X platform. But with the faster computers of today, and with more people using platforms such as Windows 2000 and Windows XP, the ANSI VCL just doesn't make sense anymore. In fact, having to use the the ANSI VCL on Windows NT/2000/XP is slower because of the constant conversion to and from UNICODE inside Windows. + +My coding signature is Tnt. I will use this to denote my classes from others. + +For more information about me: <http://home.ccci.org/wolbrink/> +Some of my software projects (all written in Delphi). + TntMPD (contact manager for missionaries) + <http://www.tntmpd.com/> + Jesus Film Screen Saver + <http://home.ccci.org/wolbrink/screensaver.htm> + ActiveX SCR control + <http://tnt.ccci.org/download/activex_scr/ActiveXSCR.exe> + +---Design Goals---------------------------- + +I want the controls to work on Windows 95, 98, ME, NT, 2000, XP, etc. I want a single EXE for all platforms. Of course, full UNICODE support is only truly available on NT/2000/XP. In other words, the controls should automatically scale to take advantage of native Unicode support when possible. + +I want the controls to inherit from the Delphi VCL. I want to reuse as much code as possible. For the most part this makes sense. The only sticky part is where text messages get passed around. But I believe I've gotten past this through strategic subclassing at various points in the message flow chain. To give a rough comparison of why this is so important, check out the following chart which compares the lines of code in the VCL for a given control (4,397 in all), and the lines of code required in my descendent controls (655 in all). Besides saving lines of code, I get the advantage of automatically inheriting new features as new versions of Delphi come out. One such example is the AlphaBlending feature in the Delphi 6 TForm. Even though I use Delphi 5 now, I won't have to add any code to get this new feature. + +---More Interesting Information---------------------------- +Case Study: Porting an MFC Application to Unicode: It looks like the FrontPage 2002 team did the roughly the same thing to MFC as what I'm doing to the VCL. They did this with the same goal in mind: to support Unicode as much as possible depending on the support offered by Windows. Another goal was "Don’t abandon MFC; don’t rewrite app". Because they still want to support Windows 9X using the same worldwide EXE used everywhere. They couldn't just compile with the _UNICODE directive. They had to start with the ANSI MFC, strategically subclassing window procedures at just the right places. Hmmm... sounds familiar.
\ No newline at end of file diff --git a/cmake/src/lib/TntUnicodeControls/TntClasses.pas b/cmake/src/lib/TntUnicodeControls/TntClasses.pas new file mode 100644 index 00000000..f0ebd14c --- /dev/null +++ b/cmake/src/lib/TntUnicodeControls/TntClasses.pas @@ -0,0 +1,1806 @@ +
+{*****************************************************************************}
+{ }
+{ Tnt Delphi Unicode Controls }
+{ http://www.tntware.com/delphicontrols/unicode/ }
+{ Version: 2.3.0 }
+{ }
+{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) }
+{ }
+{*****************************************************************************}
+
+unit TntClasses;
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+{$ENDIF}
+
+{$INCLUDE TntCompilers.inc}
+
+interface
+
+{ TODO: Consider: TTntRegIniFile, TTntMemIniFile (consider if UTF8 fits into this solution). }
+
+{***********************************************}
+{ WideChar-streaming implemented by Maël Hörz }
+{***********************************************}
+
+uses
+ Classes, SysUtils, Windows,
+ {$IFNDEF COMPILER_10_UP}
+ TntWideStrings,
+ {$ELSE}
+ WideStrings,
+ {$ENDIF}
+ ActiveX, Contnrs;
+
+// ......... introduced .........
+type
+ TTntStreamCharSet = (csAnsi, csUnicode, csUnicodeSwapped, csUtf8);
+
+function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet;
+
+//---------------------------------------------------------------------------------------------
+// Tnt - Classes
+//---------------------------------------------------------------------------------------------
+
+{TNT-WARN ExtractStrings}
+{TNT-WARN LineStart}
+{TNT-WARN TStringStream} // TODO: Implement a TWideStringStream
+
+// A potential implementation of TWideStringStream can be found at:
+// http://kdsxml.cvs.sourceforge.net/kdsxml/Global/KDSClasses.pas?revision=1.10&view=markup
+
+procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent);
+
+type
+{TNT-WARN TFileStream}
+ TTntFileStream = class(THandleStream)
+ public
+ constructor Create(const FileName: WideString; Mode: Word);
+ destructor Destroy; override;
+ end;
+
+{TNT-WARN TMemoryStream}
+ TTntMemoryStream = class(TMemoryStream{TNT-ALLOW TMemoryStream})
+ public
+ procedure LoadFromFile(const FileName: WideString);
+ procedure SaveToFile(const FileName: WideString);
+ end;
+
+{TNT-WARN TResourceStream}
+ TTntResourceStream = class(TCustomMemoryStream)
+ private
+ HResInfo: HRSRC;
+ HGlobal: THandle;
+ procedure Initialize(Instance: THandle; Name, ResType: PWideChar);
+ public
+ constructor Create(Instance: THandle; const ResName: WideString; ResType: PWideChar);
+ constructor CreateFromID(Instance: THandle; ResID: Word; ResType: PWideChar);
+ destructor Destroy; override;
+ function Write(const Buffer; Count: Longint): Longint; override;
+ procedure SaveToFile(const FileName: WideString);
+ end;
+
+ TTntStrings = class;
+
+{TNT-WARN TAnsiStrings}
+ TAnsiStrings{TNT-ALLOW TAnsiStrings} = class(TStrings{TNT-ALLOW TStrings})
+ public
+ procedure LoadFromFile(const FileName: WideString); reintroduce;
+ procedure SaveToFile(const FileName: WideString); reintroduce;
+ procedure LoadFromFileEx(const FileName: WideString; CodePage: Cardinal);
+ procedure SaveToFileEx(const FileName: WideString; CodePage: Cardinal);
+ procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract;
+ procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract;
+ end;
+
+ TAnsiStringsForWideStringsAdapter = class(TAnsiStrings{TNT-ALLOW TAnsiStrings})
+ private
+ FWideStrings: TTntStrings;
+ FAdapterCodePage: Cardinal;
+ protected
+ function Get(Index: Integer): AnsiString; override;
+ procedure Put(Index: Integer; const S: AnsiString); override;
+ function GetCount: Integer; override;
+ function GetObject(Index: Integer): TObject; override;
+ procedure PutObject(Index: Integer; AObject: TObject); override;
+ procedure SetUpdateState(Updating: Boolean); override;
+ function AdapterCodePage: Cardinal; dynamic;
+ public
+ constructor Create(AWideStrings: TTntStrings; _AdapterCodePage: Cardinal = 0);
+ procedure Clear; override;
+ procedure Delete(Index: Integer); override;
+ procedure Insert(Index: Integer; const S: AnsiString); override;
+ procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); override;
+ procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); override;
+ end;
+
+{TNT-WARN TStrings}
+ TTntStrings = class(TWideStrings)
+ private
+ FLastFileCharSet: TTntStreamCharSet;
+ FAnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings};
+ procedure SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings});
+ procedure ReadData(Reader: TReader);
+ procedure ReadDataUTF7(Reader: TReader);
+ procedure ReadDataUTF8(Reader: TReader);
+ procedure WriteDataUTF7(Writer: TWriter);
+ protected
+ procedure DefineProperties(Filer: TFiler); override;
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ procedure LoadFromFile(const FileName: WideString); override;
+ procedure LoadFromStream(Stream: TStream); override;
+ procedure LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); virtual;
+
+ procedure SaveToFile(const FileName: WideString); override;
+ procedure SaveToStream(Stream: TStream); override;
+ procedure SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); virtual;
+
+ property LastFileCharSet: TTntStreamCharSet read FLastFileCharSet;
+ published
+ property AnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings} read FAnsiStrings write SetAnsiStrings stored False;
+ end;
+
+{ TTntStringList class }
+
+ TTntStringList = class;
+ TWideStringListSortCompare = function(List: TTntStringList; Index1, Index2: Integer): Integer;
+
+{TNT-WARN TStringList}
+ TTntStringList = class(TTntStrings)
+ private
+ FUpdating: Boolean;
+ FList: PWideStringItemList;
+ FCount: Integer;
+ FCapacity: Integer;
+ FSorted: Boolean;
+ FDuplicates: TDuplicates;
+ FCaseSensitive: Boolean;
+ FOnChange: TNotifyEvent;
+ FOnChanging: TNotifyEvent;
+ procedure ExchangeItems(Index1, Index2: Integer);
+ procedure Grow;
+ procedure QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare);
+ procedure SetSorted(Value: Boolean);
+ procedure SetCaseSensitive(const Value: Boolean);
+ protected
+ procedure Changed; virtual;
+ procedure Changing; virtual;
+ function Get(Index: Integer): WideString; override;
+ function GetCapacity: Integer; override;
+ function GetCount: Integer; override;
+ function GetObject(Index: Integer): TObject; override;
+ procedure Put(Index: Integer; const S: WideString); override;
+ procedure PutObject(Index: Integer; AObject: TObject); override;
+ procedure SetCapacity(NewCapacity: Integer); override;
+ procedure SetUpdateState(Updating: Boolean); override;
+ function CompareStrings(const S1, S2: WideString): Integer; override;
+ procedure InsertItem(Index: Integer; const S: WideString; AObject: TObject); virtual;
+ public
+ destructor Destroy; override;
+ function Add(const S: WideString): Integer; override;
+ function AddObject(const S: WideString; AObject: TObject): Integer; override;
+ procedure Clear; override;
+ procedure Delete(Index: Integer); override;
+ procedure Exchange(Index1, Index2: Integer); override;
+ function Find(const S: WideString; var Index: Integer): Boolean; virtual;
+ function IndexOf(const S: WideString): Integer; override;
+ function IndexOfName(const Name: WideString): Integer; override;
+ procedure Insert(Index: Integer; const S: WideString); override;
+ procedure InsertObject(Index: Integer; const S: WideString;
+ AObject: TObject); override;
+ procedure Sort; virtual;
+ procedure CustomSort(Compare: TWideStringListSortCompare); virtual;
+ property Duplicates: TDuplicates read FDuplicates write FDuplicates;
+ property Sorted: Boolean read FSorted write SetSorted;
+ property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive;
+ property OnChange: TNotifyEvent read FOnChange write FOnChange;
+ property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
+ end;
+
+// ......... introduced .........
+type
+ TListTargetCompare = function (Item, Target: Pointer): Integer;
+
+function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare;
+ Target: Pointer; var Index: Integer): Boolean;
+
+function ClassIsRegistered(const clsid: TCLSID): Boolean;
+
+var
+ RuntimeUTFStreaming: Boolean;
+
+type
+ TBufferedAnsiString = class(TObject)
+ private
+ FStringBuffer: AnsiString;
+ LastWriteIndex: Integer;
+ public
+ procedure Clear;
+ procedure AddChar(const wc: AnsiChar);
+ procedure AddString(const s: AnsiString);
+ procedure AddBuffer(Buff: PAnsiChar; Chars: Integer);
+ function Value: AnsiString;
+ function BuffPtr: PAnsiChar;
+ end;
+
+ TBufferedWideString = class(TObject)
+ private
+ FStringBuffer: WideString;
+ LastWriteIndex: Integer;
+ public
+ procedure Clear;
+ procedure AddChar(const wc: WideChar);
+ procedure AddString(const s: WideString);
+ procedure AddBuffer(Buff: PWideChar; Chars: Integer);
+ function Value: WideString;
+ function BuffPtr: PWideChar;
+ end;
+
+ TBufferedStreamReader = class(TStream)
+ private
+ FStream: TStream;
+ FStreamSize: Integer;
+ FBuffer: array of Byte;
+ FBufferSize: Integer;
+ FBufferStartPosition: Integer;
+ FVirtualPosition: Integer;
+ procedure UpdateBufferFromPosition(StartPos: Integer);
+ public
+ constructor Create(Stream: TStream; BufferSize: Integer = 1024);
+ function Read(var Buffer; Count: Longint): Longint; override;
+ function Write(const Buffer; Count: Longint): Longint; override;
+ function Seek(Offset: Longint; Origin: Word): Longint; override;
+ end;
+
+// "synced" wide string
+type TSetAnsiStrEvent = procedure(const Value: AnsiString) of object;
+function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString;
+procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString;
+ const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent);
+
+type
+ TWideComponentHelper = class(TComponent)
+ private
+ FComponent: TComponent;
+ protected
+ procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ constructor CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList);
+ end;
+
+function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper;
+
+implementation
+
+uses
+ RTLConsts, ComObj, Math,
+ Registry, TypInfo, TntSystem, TntSysUtils;
+
+{ TntPersistent }
+
+//===========================================================================
+// The Delphi 5 Classes.pas never supported the streaming of WideStrings.
+// The Delphi 6 Classes.pas supports WideString streaming. But it's too bad that
+// the Delphi 6 IDE doesn't use the updated Classes.pas. Switching between Form/Text
+// mode corrupts extended characters in WideStrings even under Delphi 6.
+// Delphi 7 seems to finally get right. But let's keep the UTF7 support at design time
+// to enable sharing source code with previous versions of Delphi.
+//
+// The purpose of this solution is to store WideString properties which contain
+// non-ASCII chars in the form of UTF7 under the old property name + '_UTF7'.
+//
+// Special thanks go to Francisco Leong for helping to develop this solution.
+//
+
+{ TTntWideStringPropertyFiler }
+type
+ TTntWideStringPropertyFiler = class
+ private
+ FInstance: TPersistent;
+ FPropInfo: PPropInfo;
+ procedure ReadDataUTF8(Reader: TReader);
+ procedure ReadDataUTF7(Reader: TReader);
+ procedure WriteDataUTF7(Writer: TWriter);
+ public
+ procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString);
+ end;
+
+function ReaderNeedsUtfHelp(Reader: TReader): Boolean;
+begin
+ if Reader.Owner = nil then
+ Result := False { designtime - visual form inheritance ancestor }
+ else if csDesigning in Reader.Owner.ComponentState then
+ {$IFDEF COMPILER_7_UP}
+ Result := False { Delphi 7+: designtime - doesn't need UTF help. }
+ {$ELSE}
+ Result := True { Delphi 6: designtime - always needs UTF help. }
+ {$ENDIF}
+ else
+ Result := RuntimeUTFStreaming; { runtime }
+end;
+
+procedure TTntWideStringPropertyFiler.ReadDataUTF8(Reader: TReader);
+begin
+ if ReaderNeedsUtfHelp(Reader) then
+ SetWideStrProp(FInstance, FPropInfo, UTF8ToWideString(Reader.ReadString))
+ else
+ Reader.ReadString; { do nothing with Result }
+end;
+
+procedure TTntWideStringPropertyFiler.ReadDataUTF7(Reader: TReader);
+begin
+ if ReaderNeedsUtfHelp(Reader) then
+ SetWideStrProp(FInstance, FPropInfo, UTF7ToWideString(Reader.ReadString))
+ else
+ Reader.ReadString; { do nothing with Result }
+end;
+
+procedure TTntWideStringPropertyFiler.WriteDataUTF7(Writer: TWriter);
+begin
+ Writer.WriteString(WideStringToUTF7(GetWideStrProp(FInstance, FPropInfo)));
+end;
+
+procedure TTntWideStringPropertyFiler.DefineProperties(Filer: TFiler; Instance: TPersistent;
+ PropName: AnsiString);
+
+ {$IFNDEF COMPILER_7_UP}
+ function HasData: Boolean;
+ var
+ CurrPropValue: WideString;
+ begin
+ // must be stored
+ Result := IsStoredProp(Instance, FPropInfo);
+ if Result
+ and (Filer.Ancestor <> nil)
+ and (GetPropInfo(Filer.Ancestor, PropName, [tkWString]) <> nil) then
+ begin
+ // must be different than ancestor
+ CurrPropValue := GetWideStrProp(Instance, FPropInfo);
+ Result := CurrPropValue <> GetWideStrProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName));
+ end;
+ if Result then begin
+ // must be non-blank and different than UTF8 (implies all ASCII <= 127)
+ CurrPropValue := GetWideStrProp(Instance, FPropInfo);
+ Result := (CurrPropValue <> '') and (WideStringToUTF8(CurrPropValue) <> CurrPropValue);
+ end;
+ end;
+ {$ENDIF}
+
+begin
+ FInstance := Instance;
+ FPropInfo := GetPropInfo(Instance, PropName, [tkWString]);
+ if FPropInfo <> nil then begin
+ // must be published (and of type WideString)
+ Filer.DefineProperty(PropName + 'W', ReadDataUTF8, nil, False);
+ {$IFDEF COMPILER_7_UP}
+ Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, False);
+ {$ELSE}
+ Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, HasData);
+ {$ENDIF}
+ end;
+ FInstance := nil;
+ FPropInfo := nil;
+end;
+
+{ TTntWideCharPropertyFiler }
+type
+ TTntWideCharPropertyFiler = class
+ private
+ FInstance: TPersistent;
+ FPropInfo: PPropInfo;
+ {$IFNDEF COMPILER_9_UP}
+ FWriter: TWriter;
+ procedure GetLookupInfo(var Ancestor: TPersistent;
+ var Root, LookupRoot, RootAncestor: TComponent);
+ {$ENDIF}
+ procedure ReadData_W(Reader: TReader);
+ procedure ReadDataUTF7(Reader: TReader);
+ procedure WriteData_W(Writer: TWriter);
+ function ReadChar(Reader: TReader): WideChar;
+ public
+ procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString);
+ end;
+
+{$IFNDEF COMPILER_9_UP}
+type
+ TGetLookupInfoEvent = procedure(var Ancestor: TPersistent;
+ var Root, LookupRoot, RootAncestor: TComponent) of object;
+
+function AncestorIsValid(Ancestor: TPersistent; Root, RootAncestor: TComponent): Boolean;
+begin
+ Result := (Ancestor <> nil) and (RootAncestor <> nil) and
+ Root.InheritsFrom(RootAncestor.ClassType);
+end;
+
+function IsDefaultOrdPropertyValue(Instance: TObject; PropInfo: PPropInfo;
+ OnGetLookupInfo: TGetLookupInfoEvent): Boolean;
+var
+ Ancestor: TPersistent;
+ LookupRoot: TComponent;
+ RootAncestor: TComponent;
+ Root: TComponent;
+ AncestorValid: Boolean;
+ Value: Longint;
+ Default: LongInt;
+begin
+ Ancestor := nil;
+ Root := nil;
+ LookupRoot := nil;
+ RootAncestor := nil;
+
+ if Assigned(OnGetLookupInfo) then
+ OnGetLookupInfo(Ancestor, Root, LookupRoot, RootAncestor);
+
+ AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor);
+
+ Result := True;
+ if (PropInfo^.GetProc <> nil) and (PropInfo^.SetProc <> nil) then
+ begin
+ Value := GetOrdProp(Instance, PropInfo);
+ if AncestorValid then
+ Result := Value = GetOrdProp(Ancestor, PropInfo)
+ else
+ begin
+ Default := PPropInfo(PropInfo)^.Default;
+ Result := (Default <> LongInt($80000000)) and (Value = Default);
+ end;
+ end;
+end;
+
+procedure TTntWideCharPropertyFiler.GetLookupInfo(var Ancestor: TPersistent;
+ var Root, LookupRoot, RootAncestor: TComponent);
+begin
+ Ancestor := FWriter.Ancestor;
+ Root := FWriter.Root;
+ LookupRoot := FWriter.LookupRoot;
+ RootAncestor := FWriter.RootAncestor;
+end;
+{$ENDIF}
+
+function TTntWideCharPropertyFiler.ReadChar(Reader: TReader): WideChar;
+var
+ Temp: WideString;
+begin
+ case Reader.NextValue of
+ vaWString:
+ Temp := Reader.ReadWideString;
+ vaString:
+ Temp := Reader.ReadString;
+ else
+ raise EReadError.Create(SInvalidPropertyValue);
+ end;
+
+ if Length(Temp) > 1 then
+ raise EReadError.Create(SInvalidPropertyValue);
+ Result := Temp[1];
+end;
+
+procedure TTntWideCharPropertyFiler.ReadData_W(Reader: TReader);
+begin
+ SetOrdProp(FInstance, FPropInfo, Ord(ReadChar(Reader)));
+end;
+
+procedure TTntWideCharPropertyFiler.ReadDataUTF7(Reader: TReader);
+var
+ S: WideString;
+begin
+ S := UTF7ToWideString(Reader.ReadString);
+ if S = '' then
+ SetOrdProp(FInstance, FPropInfo, 0)
+ else
+ SetOrdProp(FInstance, FPropInfo, Ord(S[1]))
+end;
+
+type TAccessWriter = class(TWriter);
+
+procedure TTntWideCharPropertyFiler.WriteData_W(Writer: TWriter);
+var
+ L: Integer;
+ Temp: WideString;
+{$IFDEF FPC}
+// Workaround: the Buffer parameter of TWriter.Write() must be of a fixed size
+// type for FPC >= 2.4.0. The values vaWString, Ord(vaWString) or Integer(vaWString)
+// are not allowed anymore.
+const
+ vaWStringInt: integer = Ord(vaWString);
+{$ENDIF}
+begin
+ Temp := WideChar(GetOrdProp(FInstance, FPropInfo));
+
+ {$IFNDEF FPC}
+ TAccessWriter(Writer).WriteValue(vaWString);
+ {$ELSE}
+ TAccessWriter(Writer).Write(vaWStringInt, SizeOf(vaWString));
+ {$ENDIF}
+ L := Length(Temp);
+ Writer.Write(L, SizeOf(Integer));
+ Writer.Write(Pointer(@Temp[1])^, L * 2);
+end;
+
+procedure TTntWideCharPropertyFiler.DefineProperties(Filer: TFiler;
+ Instance: TPersistent; PropName: AnsiString);
+
+ {$IFNDEF COMPILER_9_UP}
+ function HasData: Boolean;
+ var
+ CurrPropValue: Integer;
+ begin
+ // must be stored
+ Result := IsStoredProp(Instance, FPropInfo);
+ if Result and (Filer.Ancestor <> nil) and
+ (GetPropInfo(Filer.Ancestor, PropName, [tkWChar]) <> nil) then
+ begin
+ // must be different than ancestor
+ CurrPropValue := GetOrdProp(Instance, FPropInfo);
+ Result := CurrPropValue <> GetOrdProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName));
+ end;
+ if Result and (Filer is TWriter) then
+ begin
+ FWriter := TWriter(Filer);
+ Result := not IsDefaultOrdPropertyValue(Instance, FPropInfo, GetLookupInfo);
+ end;
+ end;
+ {$ENDIF}
+
+begin
+ FInstance := Instance;
+ FPropInfo := GetPropInfo(Instance, PropName, [tkWChar]);
+ if FPropInfo <> nil then
+ begin
+ // must be published (and of type WideChar)
+ {$IFDEF COMPILER_9_UP}
+ Filer.DefineProperty(PropName + 'W', ReadData_W, WriteData_W, False);
+ {$ELSE}
+ Filer.DefineProperty(PropName + 'W', ReadData_W, WriteData_W, HasData);
+ {$ENDIF}
+ Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, nil, False);
+ end;
+ FInstance := nil;
+ FPropInfo := nil;
+end;
+
+procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent);
+var
+ I, Count: Integer;
+ PropInfo: PPropInfo;
+ PropList: PPropList;
+ WideStringFiler: TTntWideStringPropertyFiler;
+ WideCharFiler: TTntWideCharPropertyFiler;
+begin
+ Count := GetTypeData(Instance.ClassInfo)^.PropCount;
+ if Count > 0 then
+ begin
+ WideStringFiler := TTntWideStringPropertyFiler.Create;
+ try
+ WideCharFiler := TTntWideCharPropertyFiler.Create;
+ try
+ GetMem(PropList, Count * SizeOf(Pointer));
+ try
+ GetPropInfos(Instance.ClassInfo, PropList);
+ for I := 0 to Count - 1 do
+ begin
+ PropInfo := PropList^[I];
+ if (PropInfo = nil) then
+ break;
+ if (PropInfo.PropType^.Kind = tkWString) then
+ WideStringFiler.DefineProperties(Filer, Instance, PropInfo.Name)
+ else if (PropInfo.PropType^.Kind = tkWChar) then
+ WideCharFiler.DefineProperties(Filer, Instance, PropInfo.Name)
+ end;
+ finally
+ FreeMem(PropList, Count * SizeOf(Pointer));
+ end;
+ finally
+ WideCharFiler.Free;
+ end;
+ finally
+ WideStringFiler.Free;
+ end;
+ end;
+end;
+
+{ TTntFileStream }
+
+{$IFDEF FPC}
+ {$DEFINE HAS_SFCREATEERROREX}
+{$ENDIF}
+{$IFDEF DELPHI_7_UP}
+ {$DEFINE HAS_SFCREATEERROREX}
+{$ENDIF}
+
+constructor TTntFileStream.Create(const FileName: WideString; Mode: Word);
+var
+ CreateHandle: Integer;
+ {$IFDEF HAS_SFCREATEERROREX}
+ ErrorMessage: WideString;
+ {$ENDIF}
+begin
+ if Mode = fmCreate then
+ begin
+ CreateHandle := WideFileCreate(FileName);
+ if CreateHandle < 0 then begin
+ {$IFDEF HAS_SFCREATEERROREX}
+ ErrorMessage := WideSysErrorMessage(GetLastError);
+ raise EFCreateError.CreateFmt(SFCreateErrorEx, [WideExpandFileName(FileName), ErrorMessage]);
+ {$ELSE}
+ raise EFCreateError.CreateFmt(SFCreateError, [WideExpandFileName(FileName)]);
+ {$ENDIF}
+ end;
+ end else
+ begin
+ CreateHandle := WideFileOpen(FileName, Mode);
+ if CreateHandle < 0 then begin
+ {$IFDEF HAS_SFCREATEERROREX}
+ ErrorMessage := WideSysErrorMessage(GetLastError);
+ raise EFOpenError.CreateFmt(SFOpenErrorEx, [WideExpandFileName(FileName), ErrorMessage]);
+ {$ELSE}
+ raise EFOpenError.CreateFmt(SFOpenError, [WideExpandFileName(FileName)]);
+ {$ENDIF}
+ end;
+ end;
+ inherited Create(CreateHandle);
+end;
+
+destructor TTntFileStream.Destroy;
+begin
+ if Handle >= 0 then FileClose(Handle);
+end;
+
+{ TTntMemoryStream }
+
+procedure TTntMemoryStream.LoadFromFile(const FileName: WideString);
+var
+ Stream: TStream;
+begin
+ Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
+ try
+ LoadFromStream(Stream);
+ finally
+ Stream.Free;
+ end;
+end;
+
+procedure TTntMemoryStream.SaveToFile(const FileName: WideString);
+var
+ Stream: TStream;
+begin
+ Stream := TTntFileStream.Create(FileName, fmCreate);
+ try
+ SaveToStream(Stream);
+ finally
+ Stream.Free;
+ end;
+end;
+
+{ TTntResourceStream }
+
+constructor TTntResourceStream.Create(Instance: THandle; const ResName: WideString;
+ ResType: PWideChar);
+begin
+ inherited Create;
+ Initialize(Instance, PWideChar(ResName), ResType);
+end;
+
+constructor TTntResourceStream.CreateFromID(Instance: THandle; ResID: Word;
+ ResType: PWideChar);
+begin
+ inherited Create;
+ Initialize(Instance, PWideChar(ResID), ResType);
+end;
+
+procedure TTntResourceStream.Initialize(Instance: THandle; Name, ResType: PWideChar);
+
+ procedure Error;
+ begin
+ raise EResNotFound.CreateFmt(SResNotFound, [Name]);
+ end;
+
+begin
+ HResInfo := FindResourceW(Instance, Name, ResType);
+ if HResInfo = 0 then Error;
+ HGlobal := LoadResource(Instance, HResInfo);
+ if HGlobal = 0 then Error;
+ SetPointer(LockResource(HGlobal), SizeOfResource(Instance, HResInfo));
+end;
+
+destructor TTntResourceStream.Destroy;
+begin
+ UnlockResource(HGlobal);
+ FreeResource(HGlobal); { Technically this is not necessary (MS KB #193678) }
+ inherited Destroy;
+end;
+
+function TTntResourceStream.Write(const Buffer; Count: Longint): Longint;
+begin
+ raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError));
+end;
+
+procedure TTntResourceStream.SaveToFile(const FileName: WideString);
+var
+ Stream: TStream;
+begin
+ Stream := TTntFileStream.Create(FileName, fmCreate);
+ try
+ SaveToStream(Stream);
+ finally
+ Stream.Free;
+ end;
+end;
+
+{ TAnsiStrings }
+
+procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.LoadFromFile(const FileName: WideString);
+var
+ Stream: TStream;
+begin
+ Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
+ try
+ LoadFromStream(Stream);
+ finally
+ Stream.Free;
+ end;
+end;
+
+procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.SaveToFile(const FileName: WideString);
+var
+ Stream: TStream;
+begin
+ Stream := TTntFileStream.Create(FileName, fmCreate);
+ try
+ SaveToStream(Stream);
+ finally
+ Stream.Free;
+ end;
+end;
+
+procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.LoadFromFileEx(const FileName: WideString; CodePage: Cardinal);
+var
+ Stream: TStream;
+begin
+ Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
+ try
+ LoadFromStreamEx(Stream, CodePage);
+ finally
+ Stream.Free;
+ end;
+end;
+
+procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.SaveToFileEx(const FileName: WideString; CodePage: Cardinal);
+var
+ Stream: TStream;
+ Utf8BomPtr: PAnsiChar;
+begin
+ Stream := TTntFileStream.Create(FileName, fmCreate);
+ try
+ if (CodePage = CP_UTF8) then
+ begin
+ Utf8BomPtr := PAnsiChar(UTF8_BOM);
+ Stream.WriteBuffer(Utf8BomPtr^, Length(UTF8_BOM));
+ end;
+ SaveToStreamEx(Stream, CodePage);
+ finally
+ Stream.Free;
+ end;
+end;
+
+{ TAnsiStringsForWideStringsAdapter }
+
+constructor TAnsiStringsForWideStringsAdapter.Create(AWideStrings: TTntStrings; _AdapterCodePage: Cardinal);
+begin
+ inherited Create;
+ FWideStrings := AWideStrings;
+ FAdapterCodePage := _AdapterCodePage;
+end;
+
+function TAnsiStringsForWideStringsAdapter.AdapterCodePage: Cardinal;
+begin
+ if FAdapterCodePage = 0 then
+ Result := TntSystem.DefaultSystemCodePage
+ else
+ Result := FAdapterCodePage;
+end;
+
+procedure TAnsiStringsForWideStringsAdapter.Clear;
+begin
+ FWideStrings.Clear;
+end;
+
+procedure TAnsiStringsForWideStringsAdapter.Delete(Index: Integer);
+begin
+ FWideStrings.Delete(Index);
+end;
+
+function TAnsiStringsForWideStringsAdapter.Get(Index: Integer): AnsiString;
+begin
+ Result := WideStringToStringEx(FWideStrings.Get(Index), AdapterCodePage);
+end;
+
+procedure TAnsiStringsForWideStringsAdapter.Put(Index: Integer; const S: AnsiString);
+begin
+ FWideStrings.Put(Index, StringToWideStringEx(S, AdapterCodePage));
+end;
+
+function TAnsiStringsForWideStringsAdapter.GetCount: Integer;
+begin
+ Result := FWideStrings.GetCount;
+end;
+
+procedure TAnsiStringsForWideStringsAdapter.Insert(Index: Integer; const S: AnsiString);
+begin
+ FWideStrings.Insert(Index, StringToWideStringEx(S, AdapterCodePage));
+end;
+
+function TAnsiStringsForWideStringsAdapter.GetObject(Index: Integer): TObject;
+begin
+ Result := FWideStrings.GetObject(Index);
+end;
+
+procedure TAnsiStringsForWideStringsAdapter.PutObject(Index: Integer; AObject: TObject);
+begin
+ FWideStrings.PutObject(Index, AObject);
+end;
+
+procedure TAnsiStringsForWideStringsAdapter.SetUpdateState(Updating: Boolean);
+begin
+ FWideStrings.SetUpdateState(Updating);
+end;
+
+procedure TAnsiStringsForWideStringsAdapter.LoadFromStreamEx(Stream: TStream; CodePage: Cardinal);
+var
+ Size: Integer;
+ S: AnsiString;
+begin
+ BeginUpdate;
+ try
+ Size := Stream.Size - Stream.Position;
+ SetString(S, nil, Size);
+ Stream.Read(Pointer(S)^, Size);
+ FWideStrings.SetTextStr(StringToWideStringEx(S, CodePage));
+ finally
+ EndUpdate;
+ end;
+end;
+
+procedure TAnsiStringsForWideStringsAdapter.SaveToStreamEx(Stream: TStream; CodePage: Cardinal);
+var
+ S: AnsiString;
+begin
+ S := WideStringToStringEx(FWideStrings.GetTextStr, CodePage);
+ Stream.WriteBuffer(Pointer(S)^, Length(S));
+end;
+
+{ TTntStrings }
+
+constructor TTntStrings.Create;
+begin
+ inherited;
+ FAnsiStrings := TAnsiStringsForWideStringsAdapter.Create(Self);
+ FLastFileCharSet := csUnicode;
+end;
+
+destructor TTntStrings.Destroy;
+begin
+ FreeAndNil(FAnsiStrings);
+ inherited;
+end;
+
+procedure TTntStrings.SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings});
+begin
+ FAnsiStrings.Assign(Value);
+end;
+
+procedure TTntStrings.DefineProperties(Filer: TFiler);
+
+ {$IFNDEF COMPILER_7_UP}
+ function DoWrite: Boolean;
+ begin
+ if Filer.Ancestor <> nil then
+ begin
+ Result := True;
+ if Filer.Ancestor is TWideStrings then
+ Result := not Equals(TWideStrings(Filer.Ancestor))
+ end
+ else Result := Count > 0;
+ end;
+
+ function DoWriteAsUTF7: Boolean;
+ var
+ i: integer;
+ begin
+ Result := False;
+ for i := 0 to Count - 1 do begin
+ if (Strings[i] <> '') and (WideStringToUTF8(Strings[i]) <> Strings[i]) then begin
+ Result := True;
+ break; { found a string with non-ASCII chars (> 127) }
+ end;
+ end;
+ end;
+ {$ENDIF}
+
+begin
+ inherited DefineProperties(Filer); { Handles main 'Strings' property.' }
+ Filer.DefineProperty('WideStrings', ReadData, nil, False);
+ Filer.DefineProperty('WideStringsW', ReadDataUTF8, nil, False);
+ {$IFDEF COMPILER_7_UP}
+ Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, False);
+ {$ELSE}
+ Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, DoWrite and DoWriteAsUTF7);
+ {$ENDIF}
+end;
+
+procedure TTntStrings.LoadFromFile(const FileName: WideString);
+var
+ Stream: TStream;
+begin
+ Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
+ try
+ FLastFileCharSet := AutoDetectCharacterSet(Stream);
+ Stream.Position := 0;
+ LoadFromStream(Stream);
+ finally
+ Stream.Free;
+ end;
+end;
+
+procedure TTntStrings.LoadFromStream(Stream: TStream);
+begin
+ LoadFromStream_BOM(Stream, True);
+end;
+
+procedure TTntStrings.LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean);
+var
+ DataLeft: Integer;
+ StreamCharSet: TTntStreamCharSet;
+ SW: WideString;
+ SA: AnsiString;
+begin
+ BeginUpdate;
+ try
+ if WithBOM then
+ StreamCharSet := AutoDetectCharacterSet(Stream)
+ else
+ StreamCharSet := csUnicode;
+ DataLeft := Stream.Size - Stream.Position;
+ if (StreamCharSet in [csUnicode, csUnicodeSwapped]) then
+ begin
+ // BOM indicates Unicode text stream
+ if DataLeft < SizeOf(WideChar) then
+ SW := ''
+ else begin
+ SetLength(SW, DataLeft div SizeOf(WideChar));
+ Stream.Read(PWideChar(SW)^, DataLeft);
+ if StreamCharSet = csUnicodeSwapped then
+ StrSwapByteOrder(PWideChar(SW));
+ end;
+ SetTextStr(SW);
+ end
+ else if StreamCharSet = csUtf8 then
+ begin
+ // BOM indicates UTF-8 text stream
+ SetLength(SA, DataLeft div SizeOf(AnsiChar));
+ Stream.Read(PAnsiChar(SA)^, DataLeft);
+ SetTextStr(UTF8ToWideString(SA));
+ end
+ else
+ begin
+ // without byte order mark it is assumed that we are loading ANSI text
+ SetLength(SA, DataLeft div SizeOf(AnsiChar));
+ Stream.Read(PAnsiChar(SA)^, DataLeft);
+ SetTextStr(SA);
+ end;
+ finally
+ EndUpdate;
+ end;
+end;
+
+procedure TTntStrings.ReadData(Reader: TReader);
+begin
+ if Reader.NextValue in [vaString, vaLString] then
+ SetTextStr(Reader.ReadString) {JCL compatiblity}
+ else if Reader.NextValue = vaWString then
+ SetTextStr(Reader.ReadWideString) {JCL compatiblity}
+ else begin
+ BeginUpdate;
+ try
+ Clear;
+ Reader.ReadListBegin;
+ while not Reader.EndOfList do
+ if Reader.NextValue in [vaString, vaLString] then
+ Add(Reader.ReadString) {TStrings compatiblity}
+ else
+ Add(Reader.ReadWideString);
+ Reader.ReadListEnd;
+ finally
+ EndUpdate;
+ end;
+ end;
+end;
+
+procedure TTntStrings.ReadDataUTF7(Reader: TReader);
+begin
+ Reader.ReadListBegin;
+ if ReaderNeedsUtfHelp(Reader) then
+ begin
+ BeginUpdate;
+ try
+ Clear;
+ while not Reader.EndOfList do
+ Add(UTF7ToWideString(Reader.ReadString))
+ finally
+ EndUpdate;
+ end;
+ end else begin
+ while not Reader.EndOfList do
+ Reader.ReadString; { do nothing with Result }
+ end;
+ Reader.ReadListEnd;
+end;
+
+procedure TTntStrings.ReadDataUTF8(Reader: TReader);
+begin
+ Reader.ReadListBegin;
+ if ReaderNeedsUtfHelp(Reader)
+ or (Count = 0){ Legacy support where 'WideStrings' was never written in lieu of WideStringsW }
+ then begin
+ BeginUpdate;
+ try
+ Clear;
+ while not Reader.EndOfList do
+ Add(UTF8ToWideString(Reader.ReadString))
+ finally
+ EndUpdate;
+ end;
+ end else begin
+ while not Reader.EndOfList do
+ Reader.ReadString; { do nothing with Result }
+ end;
+ Reader.ReadListEnd;
+end;
+
+procedure TTntStrings.SaveToFile(const FileName: WideString);
+var
+ Stream: TStream;
+begin
+ Stream := TTntFileStream.Create(FileName, fmCreate);
+ try
+ SaveToStream(Stream);
+ finally
+ Stream.Free;
+ end;
+end;
+
+procedure TTntStrings.SaveToStream(Stream: TStream);
+begin
+ SaveToStream_BOM(Stream, True);
+end;
+
+procedure TTntStrings.SaveToStream_BOM(Stream: TStream; WithBOM: Boolean);
+// Saves the currently loaded text into the given stream.
+// WithBOM determines whether to write a byte order mark or not.
+var
+ SW: WideString;
+ BOM: WideChar;
+begin
+ if WithBOM then begin
+ BOM := UNICODE_BOM;
+ Stream.WriteBuffer(BOM, SizeOf(WideChar));
+ end;
+ SW := GetTextStr;
+ Stream.WriteBuffer(PWideChar(SW)^, Length(SW) * SizeOf(WideChar));
+end;
+
+procedure TTntStrings.WriteDataUTF7(Writer: TWriter);
+var
+ I: Integer;
+begin
+ Writer.WriteListBegin;
+ for I := 0 to Count-1 do
+ Writer.WriteString(WideStringToUTF7(Get(I)));
+ Writer.WriteListEnd;
+end;
+
+{ TTntStringList }
+
+destructor TTntStringList.Destroy;
+begin
+ FOnChange := nil;
+ FOnChanging := nil;
+ inherited Destroy;
+ if FCount <> 0 then Finalize(FList^[0], FCount);
+ FCount := 0;
+ SetCapacity(0);
+end;
+
+function TTntStringList.Add(const S: WideString): Integer;
+begin
+ Result := AddObject(S, nil);
+end;
+
+function TTntStringList.AddObject(const S: WideString; AObject: TObject): Integer;
+begin
+ if not Sorted then
+ Result := FCount
+ else
+ if Find(S, Result) then
+ case Duplicates of
+ dupIgnore: Exit;
+ dupError: Error(PResStringRec(@SDuplicateString), 0);
+ end;
+ InsertItem(Result, S, AObject);
+end;
+
+procedure TTntStringList.Changed;
+begin
+ if (not FUpdating) and Assigned(FOnChange) then
+ FOnChange(Self);
+end;
+
+procedure TTntStringList.Changing;
+begin
+ if (not FUpdating) and Assigned(FOnChanging) then
+ FOnChanging(Self);
+end;
+
+procedure TTntStringList.Clear;
+begin
+ if FCount <> 0 then
+ begin
+ Changing;
+ Finalize(FList^[0], FCount);
+ FCount := 0;
+ SetCapacity(0);
+ Changed;
+ end;
+end;
+
+procedure TTntStringList.Delete(Index: Integer);
+begin
+ if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index);
+ Changing;
+ Finalize(FList^[Index]);
+ Dec(FCount);
+ if Index < FCount then
+ System.Move(FList^[Index + 1], FList^[Index],
+ (FCount - Index) * SizeOf(TWideStringItem));
+ Changed;
+end;
+
+procedure TTntStringList.Exchange(Index1, Index2: Integer);
+begin
+ if (Index1 < 0) or (Index1 >= FCount) then Error(PResStringRec(@SListIndexError), Index1);
+ if (Index2 < 0) or (Index2 >= FCount) then Error(PResStringRec(@SListIndexError), Index2);
+ Changing;
+ ExchangeItems(Index1, Index2);
+ Changed;
+end;
+
+procedure TTntStringList.ExchangeItems(Index1, Index2: Integer);
+var
+ Temp: Integer;
+ Item1, Item2: PWideStringItem;
+begin
+ Item1 := @FList^[Index1];
+ Item2 := @FList^[Index2];
+ Temp := Integer(Item1^.FString);
+ Integer(Item1^.FString) := Integer(Item2^.FString);
+ Integer(Item2^.FString) := Temp;
+ Temp := Integer(Item1^.FObject);
+ Integer(Item1^.FObject) := Integer(Item2^.FObject);
+ Integer(Item2^.FObject) := Temp;
+end;
+
+function TTntStringList.Find(const S: WideString; var Index: Integer): Boolean;
+var
+ L, H, I, C: Integer;
+begin
+ Result := False;
+ L := 0;
+ H := FCount - 1;
+ while L <= H do
+ begin
+ I := (L + H) shr 1;
+ C := CompareStrings(FList^[I].FString, S);
+ if C < 0 then L := I + 1 else
+ begin
+ H := I - 1;
+ if C = 0 then
+ begin
+ Result := True;
+ if Duplicates <> dupAccept then L := I;
+ end;
+ end;
+ end;
+ Index := L;
+end;
+
+function TTntStringList.Get(Index: Integer): WideString;
+begin
+ if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index);
+ Result := FList^[Index].FString;
+end;
+
+function TTntStringList.GetCapacity: Integer;
+begin
+ Result := FCapacity;
+end;
+
+function TTntStringList.GetCount: Integer;
+begin
+ Result := FCount;
+end;
+
+function TTntStringList.GetObject(Index: Integer): TObject;
+begin
+ if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index);
+ Result := FList^[Index].FObject;
+end;
+
+procedure TTntStringList.Grow;
+var
+ Delta: Integer;
+begin
+ if FCapacity > 64 then Delta := FCapacity div 4 else
+ if FCapacity > 8 then Delta := 16 else
+ Delta := 4;
+ SetCapacity(FCapacity + Delta);
+end;
+
+function TTntStringList.IndexOf(const S: WideString): Integer;
+begin
+ if not Sorted then Result := inherited IndexOf(S) else
+ if not Find(S, Result) then Result := -1;
+end;
+
+function TTntStringList.IndexOfName(const Name: WideString): Integer;
+var
+ NameKey: WideString;
+begin
+ if not Sorted then
+ Result := inherited IndexOfName(Name)
+ else begin
+ // use sort to find index more quickly
+ NameKey := Name + NameValueSeparator;
+ Find(NameKey, Result);
+ if (Result < 0) or (Result > Count - 1) then
+ Result := -1
+ else if CompareStrings(NameKey, Copy(Strings[Result], 1, Length(NameKey))) <> 0 then
+ Result := -1
+ end;
+end;
+
+procedure TTntStringList.Insert(Index: Integer; const S: WideString);
+begin
+ InsertObject(Index, S, nil);
+end;
+
+procedure TTntStringList.InsertObject(Index: Integer; const S: WideString;
+ AObject: TObject);
+begin
+ if Sorted then Error(PResStringRec(@SSortedListError), 0);
+ if (Index < 0) or (Index > FCount) then Error(PResStringRec(@SListIndexError), Index);
+ InsertItem(Index, S, AObject);
+end;
+
+procedure TTntStringList.InsertItem(Index: Integer; const S: WideString; AObject: TObject);
+begin
+ Changing;
+ if FCount = FCapacity then Grow;
+ if Index < FCount then
+ System.Move(FList^[Index], FList^[Index + 1],
+ (FCount - Index) * SizeOf(TWideStringItem));
+ with FList^[Index] do
+ begin
+ Pointer(FString) := nil;
+ FObject := AObject;
+ FString := S;
+ end;
+ Inc(FCount);
+ Changed;
+end;
+
+procedure TTntStringList.Put(Index: Integer; const S: WideString);
+begin
+ if Sorted then Error(PResStringRec(@SSortedListError), 0);
+ if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index);
+ Changing;
+ FList^[Index].FString := S;
+ Changed;
+end;
+
+procedure TTntStringList.PutObject(Index: Integer; AObject: TObject);
+begin
+ if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index);
+ Changing;
+ FList^[Index].FObject := AObject;
+ Changed;
+end;
+
+procedure TTntStringList.QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare);
+var
+ I, J, P: Integer;
+begin
+ repeat
+ I := L;
+ J := R;
+ P := (L + R) shr 1;
+ repeat
+ while SCompare(Self, I, P) < 0 do Inc(I);
+ while SCompare(Self, J, P) > 0 do Dec(J);
+ if I <= J then
+ begin
+ ExchangeItems(I, J);
+ if P = I then
+ P := J
+ else if P = J then
+ P := I;
+ Inc(I);
+ Dec(J);
+ end;
+ until I > J;
+ if L < J then QuickSort(L, J, SCompare);
+ L := I;
+ until I >= R;
+end;
+
+procedure TTntStringList.SetCapacity(NewCapacity: Integer);
+begin
+ ReallocMem(FList, NewCapacity * SizeOf(TWideStringItem));
+ FCapacity := NewCapacity;
+end;
+
+procedure TTntStringList.SetSorted(Value: Boolean);
+begin
+ if FSorted <> Value then
+ begin
+ if Value then Sort;
+ FSorted := Value;
+ end;
+end;
+
+procedure TTntStringList.SetUpdateState(Updating: Boolean);
+begin
+ FUpdating := Updating;
+ if Updating then Changing else Changed;
+end;
+
+function WideStringListCompareStrings(List: TTntStringList; Index1, Index2: Integer): Integer;
+begin
+ Result := List.CompareStrings(List.FList^[Index1].FString,
+ List.FList^[Index2].FString);
+end;
+
+procedure TTntStringList.Sort;
+begin
+ CustomSort(WideStringListCompareStrings);
+end;
+
+procedure TTntStringList.CustomSort(Compare: TWideStringListSortCompare);
+begin
+ if not Sorted and (FCount > 1) then
+ begin
+ Changing;
+ QuickSort(0, FCount - 1, Compare);
+ Changed;
+ end;
+end;
+
+function TTntStringList.CompareStrings(const S1, S2: WideString): Integer;
+begin
+ if CaseSensitive then
+ Result := WideCompareStr(S1, S2)
+ else
+ Result := WideCompareText(S1, S2);
+end;
+
+procedure TTntStringList.SetCaseSensitive(const Value: Boolean);
+begin
+ if Value <> FCaseSensitive then
+ begin
+ FCaseSensitive := Value;
+ if Sorted then Sort;
+ end;
+end;
+
+//------------------------- TntClasses introduced procs ----------------------------------
+
+function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet;
+var
+ ByteOrderMark: WideChar;
+ BytesRead: Integer;
+ Utf8Test: array[0..2] of AnsiChar;
+begin
+ // Byte Order Mark
+ ByteOrderMark := #0;
+ if (Stream.Size - Stream.Position) >= SizeOf(ByteOrderMark) then begin
+ BytesRead := Stream.Read(ByteOrderMark, SizeOf(ByteOrderMark));
+ if (ByteOrderMark <> UNICODE_BOM) and (ByteOrderMark <> UNICODE_BOM_SWAPPED) then begin
+ ByteOrderMark := #0;
+ Stream.Seek(-BytesRead, soFromCurrent);
+ if (Stream.Size - Stream.Position) >= Length(Utf8Test) * SizeOf(AnsiChar) then begin
+ BytesRead := Stream.Read(Utf8Test[0], Length(Utf8Test) * SizeOf(AnsiChar));
+ if Utf8Test <> UTF8_BOM then
+ Stream.Seek(-BytesRead, soFromCurrent);
+ end;
+ end;
+ end;
+ // Test Byte Order Mark
+ if ByteOrderMark = UNICODE_BOM then
+ Result := csUnicode
+ else if ByteOrderMark = UNICODE_BOM_SWAPPED then
+ Result := csUnicodeSwapped
+ else if Utf8Test = UTF8_BOM then
+ Result := csUtf8
+ else
+ Result := csAnsi;
+end;
+
+function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare;
+ Target: Pointer; var Index: Integer): Boolean;
+var
+ L, H, I, C: Integer;
+begin
+ Result := False;
+ L := 0;
+ H := List.Count - 1;
+ while L <= H do
+ begin
+ I := (L + H) shr 1;
+ C := TargetCompare(List[i], Target);
+ if C < 0 then L := I + 1 else
+ begin
+ H := I - 1;
+ if C = 0 then
+ begin
+ Result := True;
+ L := I;
+ end;
+ end;
+ end;
+ Index := L;
+end;
+
+function ClassIsRegistered(const clsid: TCLSID): Boolean;
+var
+ OleStr: POleStr;
+ Reg: TRegIniFile;
+ Key, Filename: WideString;
+begin
+ // First, check to see if there is a ProgID. This will tell if the
+ // control is registered on the machine. No ProgID, control won't run
+ Result := ProgIDFromCLSID(clsid, OleStr) = S_OK;
+ if not Result then Exit; //Bail as soon as anything goes wrong.
+
+ // Next, make sure that the file is actually there by rooting it out
+ // of the registry
+ Key := WideFormat('\SOFTWARE\Classes\CLSID\%s', [GUIDToString(clsid)]);
+ Reg := TRegIniFile.Create;
+ try
+ Reg.RootKey := HKEY_LOCAL_MACHINE;
+ Result := Reg.OpenKeyReadOnly(Key);
+ if not Result then Exit; // Bail as soon as anything goes wrong.
+
+ FileName := Reg.ReadString('InProcServer32', '', EmptyStr);
+ if (Filename = EmptyStr) then // try another key for the file name
+ begin
+ FileName := Reg.ReadString('InProcServer', '', EmptyStr);
+ end;
+ Result := Filename <> EmptyStr;
+ if not Result then Exit;
+ Result := WideFileExists(Filename);
+ finally
+ Reg.Free;
+ end;
+end;
+
+{ TBufferedAnsiString }
+
+procedure TBufferedAnsiString.Clear;
+begin
+ LastWriteIndex := 0;
+ if Length(FStringBuffer) > 0 then
+ FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(AnsiChar), 0);
+end;
+
+procedure TBufferedAnsiString.AddChar(const wc: AnsiChar);
+const
+ MIN_GROW_SIZE = 32;
+ MAX_GROW_SIZE = 256;
+var
+ GrowSize: Integer;
+begin
+ Inc(LastWriteIndex);
+ if LastWriteIndex > Length(FStringBuffer) then begin
+ GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer));
+ GrowSize := Min(GrowSize, MAX_GROW_SIZE);
+ SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize);
+ FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(AnsiChar), 0);
+ end;
+ FStringBuffer[LastWriteIndex] := wc;
+end;
+
+procedure TBufferedAnsiString.AddString(const s: AnsiString);
+var
+ LenS: Integer;
+ BlockSize: Integer;
+ AllocSize: Integer;
+begin
+ LenS := Length(s);
+ if LenS > 0 then begin
+ Inc(LastWriteIndex);
+ if LastWriteIndex + LenS - 1 > Length(FStringBuffer) then begin
+ // determine optimum new allocation size
+ BlockSize := Length(FStringBuffer) div 2;
+ if BlockSize < 8 then
+ BlockSize := 8;
+ AllocSize := ((LenS div BlockSize) + 1) * BlockSize;
+ // realloc buffer
+ SetLength(FStringBuffer, Length(FStringBuffer) + AllocSize);
+ FillChar(FStringBuffer[Length(FStringBuffer) - AllocSize + 1], AllocSize * SizeOf(AnsiChar), 0);
+ end;
+ CopyMemory(@FStringBuffer[LastWriteIndex], @s[1], LenS * SizeOf(AnsiChar));
+ Inc(LastWriteIndex, LenS - 1);
+ end;
+end;
+
+procedure TBufferedAnsiString.AddBuffer(Buff: PAnsiChar; Chars: Integer);
+var
+ i: integer;
+begin
+ for i := 1 to Chars do begin
+ if Buff^ = #0 then
+ break;
+ AddChar(Buff^);
+ Inc(Buff);
+ end;
+end;
+
+function TBufferedAnsiString.Value: AnsiString;
+begin
+ Result := PAnsiChar(FStringBuffer);
+end;
+
+function TBufferedAnsiString.BuffPtr: PAnsiChar;
+begin
+ Result := PAnsiChar(FStringBuffer);
+end;
+
+{ TBufferedWideString }
+
+procedure TBufferedWideString.Clear;
+begin
+ LastWriteIndex := 0;
+ if Length(FStringBuffer) > 0 then
+ FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(WideChar), 0);
+end;
+
+procedure TBufferedWideString.AddChar(const wc: WideChar);
+const
+ MIN_GROW_SIZE = 32;
+ MAX_GROW_SIZE = 256;
+var
+ GrowSize: Integer;
+begin
+ Inc(LastWriteIndex);
+ if LastWriteIndex > Length(FStringBuffer) then begin
+ GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer));
+ GrowSize := Min(GrowSize, MAX_GROW_SIZE);
+ SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize);
+ FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(WideChar), 0);
+ end;
+ FStringBuffer[LastWriteIndex] := wc;
+end;
+
+procedure TBufferedWideString.AddString(const s: WideString);
+var
+ i: integer;
+begin
+ for i := 1 to Length(s) do
+ AddChar(s[i]);
+end;
+
+procedure TBufferedWideString.AddBuffer(Buff: PWideChar; Chars: Integer);
+var
+ i: integer;
+begin
+ for i := 1 to Chars do begin
+ if Buff^ = #0 then
+ break;
+ AddChar(Buff^);
+ Inc(Buff);
+ end;
+end;
+
+function TBufferedWideString.Value: WideString;
+begin
+ Result := PWideChar(FStringBuffer);
+end;
+
+function TBufferedWideString.BuffPtr: PWideChar;
+begin
+ Result := PWideChar(FStringBuffer);
+end;
+
+{ TBufferedStreamReader }
+
+constructor TBufferedStreamReader.Create(Stream: TStream; BufferSize: Integer = 1024);
+begin
+ // init stream
+ FStream := Stream;
+ FStreamSize := Stream.Size;
+ // init buffer
+ FBufferSize := BufferSize;
+ SetLength(FBuffer, BufferSize);
+ FBufferStartPosition := -FBufferSize; { out of any useful range }
+ // init virtual position
+ FVirtualPosition := 0;
+end;
+
+function TBufferedStreamReader.Seek(Offset: Integer; Origin: Word): Longint;
+begin
+ case Origin of
+ soFromBeginning: FVirtualPosition := Offset;
+ soFromCurrent: Inc(FVirtualPosition, Offset);
+ soFromEnd: FVirtualPosition := FStreamSize + Offset;
+ end;
+ Result := FVirtualPosition;
+end;
+
+procedure TBufferedStreamReader.UpdateBufferFromPosition(StartPos: Integer);
+begin
+ try
+ FStream.Position := StartPos;
+ FStream.Read(FBuffer[0], FBufferSize);
+ FBufferStartPosition := StartPos;
+ except
+ FBufferStartPosition := -FBufferSize; { out of any useful range }
+ raise;
+ end;
+end;
+
+function TBufferedStreamReader.Read(var Buffer; Count: Integer): Longint;
+var
+ BytesLeft: Integer;
+ FirstBufferRead: Integer;
+ StreamDirectRead: Integer;
+ Buf: PAnsiChar;
+begin
+ if (FVirtualPosition >= 0) and (Count >= 0) then
+ begin
+ Result := FStreamSize - FVirtualPosition;
+ if Result > 0 then
+ begin
+ if Result > Count then
+ Result := Count;
+
+ Buf := @Buffer;
+ BytesLeft := Result;
+
+ // try to read what is left in buffer
+ FirstBufferRead := FBufferStartPosition + FBufferSize - FVirtualPosition;
+ if (FirstBufferRead < 0) or (FirstBufferRead > FBufferSize) then
+ FirstBufferRead := 0;
+ FirstBufferRead := Min(FirstBufferRead, Result);
+ if FirstBufferRead > 0 then begin
+ Move(FBuffer[FVirtualPosition - FBufferStartPosition], Buf[0], FirstBufferRead);
+ Dec(BytesLeft, FirstBufferRead);
+ end;
+
+ if BytesLeft > 0 then begin
+ // The first read in buffer was not enough
+ StreamDirectRead := (BytesLeft div FBufferSize) * FBufferSize;
+ FStream.Position := FVirtualPosition + FirstBufferRead;
+ FStream.Read(Buf[FirstBufferRead], StreamDirectRead);
+ Dec(BytesLeft, StreamDirectRead);
+
+ if BytesLeft > 0 then begin
+ // update buffer, and read what is left
+ UpdateBufferFromPosition(FStream.Position);
+ Move(FBuffer[0], Buf[FirstBufferRead + StreamDirectRead], BytesLeft);
+ end;
+ end;
+
+ Inc(FVirtualPosition, Result);
+ Exit;
+ end;
+ end;
+ Result := 0;
+end;
+
+function TBufferedStreamReader.Write(const Buffer; Count: Integer): Longint;
+begin
+ raise ETntInternalError.Create('Internal Error: class can not write.');
+ Result := 0;
+end;
+
+//-------- synced wide string -----------------
+
+function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString;
+begin
+ if AnsiString(WideStr) <> (AnsiStr) then begin
+ WideStr := AnsiStr; {AnsiStr changed. Keep WideStr in sync.}
+ end;
+ Result := WideStr;
+end;
+
+procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString;
+ const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent);
+begin
+ if Value <> GetSyncedWideString(WideStr, AnsiStr) then
+ begin
+ if (not WideSameStr(Value, AnsiString(Value))) {unicode chars lost in conversion}
+ and (AnsiStr = AnsiString(Value)) {AnsiStr is not going to change}
+ then begin
+ SetAnsiStr(''); {force the change}
+ end;
+ WideStr := Value;
+ SetAnsiStr(Value);
+ end;
+end;
+
+{ TWideComponentHelper }
+
+function CompareComponentHelperToTarget(Item, Target: Pointer): Integer;
+begin
+ if PtrUInt(TWideComponentHelper(Item).FComponent) < PtrUInt(Target) then
+ Result := -1
+ else if PtrUInt(TWideComponentHelper(Item).FComponent) > PtrUInt(Target) then
+ Result := 1
+ else
+ Result := 0;
+end;
+
+function FindWideComponentHelperIndex(ComponentHelperList: TComponentList; Component: TComponent; var Index: Integer): Boolean;
+begin
+ // find Component in sorted wide caption list (list is sorted by TWideComponentHelper.FComponent)
+ Result := FindSortedListByTarget(ComponentHelperList, CompareComponentHelperToTarget, Component, Index);
+end;
+
+constructor TWideComponentHelper.Create(AOwner: TComponent);
+begin
+ raise ETntInternalError.Create('TNT Internal Error: TWideComponentHelper.Create should never be encountered.');
+end;
+
+constructor TWideComponentHelper.CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList);
+var
+ Index: Integer;
+begin
+ // don't use direct ownership for memory management
+ inherited Create(nil);
+ FComponent := AOwner;
+ FComponent.FreeNotification(Self);
+
+ // insert into list according to sort
+ FindWideComponentHelperIndex(ComponentHelperList, FComponent, Index);
+ ComponentHelperList.Insert(Index, Self);
+end;
+
+procedure TWideComponentHelper.Notification(AComponent: TComponent; Operation: TOperation);
+begin
+ inherited;
+ if (AComponent = FComponent) and (Operation = opRemove) then begin
+ FComponent := nil;
+ Free;
+ end;
+end;
+
+function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper;
+var
+ Index: integer;
+begin
+ if FindWideComponentHelperIndex(ComponentHelperList, Component, Index) then begin
+ Result := TWideComponentHelper(ComponentHelperList[Index]);
+ Assert(Result.FComponent = Component, 'TNT Internal Error: FindWideComponentHelperIndex failed.');
+ end else
+ Result := nil;
+end;
+
+initialization
+ RuntimeUTFStreaming := False; { Delphi 6 and higher don't need UTF help at runtime. }
+
+end.
diff --git a/cmake/src/lib/TntUnicodeControls/TntCompilers.inc b/cmake/src/lib/TntUnicodeControls/TntCompilers.inc new file mode 100644 index 00000000..90b51ef2 --- /dev/null +++ b/cmake/src/lib/TntUnicodeControls/TntCompilers.inc @@ -0,0 +1,378 @@ +//---------------------------------------------------------------------------------------------------------------------- +// Include file to determine which compiler is currently being used to build the project/component. +// This file uses ideas from Brad Stowers DFS.inc file (www.delphifreestuff.com). +// +// Portions created by Mike Lischke are Copyright +// (C) 1999-2002 Dipl. Ing. Mike Lischke. All Rights Reserved. +//---------------------------------------------------------------------------------------------------------------------- +// The following symbols are defined: +// +// COMPILER_1 : Kylix/Delphi/BCB 1.x is the compiler. +// COMPILER_1_UP : Kylix/Delphi/BCB 1.x or higher is the compiler. +// COMPILER_2 : Kylix/Delphi 2.x or BCB 1.x is the compiler. +// COMPILER_2_UP : Kylix/Delphi 2.x or higher, or BCB 1.x or higher is the compiler. +// COMPILER_3 : Kylix/Delphi/BCB 3.x is the compiler. +// COMPILER_3_UP : Kylix/Delphi/BCB 3.x or higher is the compiler. +// COMPILER_4 : Kylix/Delphi/BCB 4.x is the compiler. +// COMPILER_4_UP : Kylix/Delphi/BCB 4.x or higher is the compiler. +// COMPILER_5 : Kylix/Delphi/BCB 5.x is the compiler. +// COMPILER_5_UP : Kylix/Delphi/BCB 5.x or higher is the compiler. +// COMPILER_6 : Kylix/Delphi/BCB 6.x is the compiler. +// COMPILER_6_UP : Kylix/Delphi/BCB 6.x or higher is the compiler. +// COMPILER_7 : Kylix/Delphi/BCB 7.x is the compiler. +// COMPILER_7_UP : Kylix/Delphi/BCB 7.x or higher is the compiler. +// +// Only defined if Windows is the target: +// CPPB : Any version of BCB is being used. +// CPPB_1 : BCB v1.x is being used. +// CPPB_3 : BCB v3.x is being used. +// CPPB_3_UP : BCB v3.x or higher is being used. +// CPPB_4 : BCB v4.x is being used. +// CPPB_4_UP : BCB v4.x or higher is being used. +// CPPB_5 : BCB v5.x is being used. +// CPPB_5_UP : BCB v5.x or higher is being used. +// CPPB_6 : BCB v6.x is being used. +// CPPB_6_UP : BCB v6.x or higher is being used. +// +// Only defined if Windows is the target: +// DELPHI : Any version of Delphi is being used. +// DELPHI_1 : Delphi v1.x is being used. +// DELPHI_2 : Delphi v2.x is being used. +// DELPHI_2_UP : Delphi v2.x or higher is being used. +// DELPHI_3 : Delphi v3.x is being used. +// DELPHI_3_UP : Delphi v3.x or higher is being used. +// DELPHI_4 : Delphi v4.x is being used. +// DELPHI_4_UP : Delphi v4.x or higher is being used. +// DELPHI_5 : Delphi v5.x is being used. +// DELPHI_5_UP : Delphi v5.x or higher is being used. +// DELPHI_6 : Delphi v6.x is being used. +// DELPHI_6_UP : Delphi v6.x or higher is being used. +// DELPHI_7 : Delphi v7.x is being used. +// DELPHI_7_UP : Delphi v7.x or higher is being used. +// +// Only defined if Linux is the target: +// KYLIX : Any version of Kylix is being used. +// KYLIX_1 : Kylix 1.x is being used. +// KYLIX_1_UP : Kylix 1.x or higher is being used. +// KYLIX_2 : Kylix 2.x is being used. +// KYLIX_2_UP : Kylix 2.x or higher is being used. +// KYLIX_3 : Kylix 3.x is being used. +// KYLIX_3_UP : Kylix 3.x or higher is being used. +// +// Only defined if Linux is the target: +// QT_CLX : Trolltech's QT library is being used. +//---------------------------------------------------------------------------------------------------------------------- + +{$ifdef MSWINDOWS} + + {$ifdef VER180} + {$define COMPILER_10} + {$define DELPHI} + {$define DELPHI_10} + {$endif} + + {$ifdef VER170} + {$define COMPILER_9} + {$define DELPHI} + {$define DELPHI_9} + {$endif} + + {$ifdef VER150} + {$define COMPILER_7} + {$define DELPHI} + {$define DELPHI_7} + {$endif} + + {$ifdef VER140} + {$define COMPILER_6} + {$ifdef BCB} + {$define CPPB} + {$define CPPB_6} + {$else} + {$define DELPHI} + {$define DELPHI_6} + {$endif} + {$endif} + + {$ifdef VER130} + {$define COMPILER_5} + {$ifdef BCB} + {$define CPPB} + {$define CPPB_5} + {$else} + {$define DELPHI} + {$define DELPHI_5} + {$endif} + {$endif} + + {$ifdef VER125} + {$define COMPILER_4} + {$define CPPB} + {$define CPPB_4} + {$endif} + + {$ifdef VER120} + {$define COMPILER_4} + {$define DELPHI} + {$define DELPHI_4} + {$endif} + + {$ifdef VER110} + {$define COMPILER_3} + {$define CPPB} + {$define CPPB_3} + {$endif} + + {$ifdef VER100} + {$define COMPILER_3} + {$define DELPHI} + {$define DELPHI_3} + {$endif} + + {$ifdef VER93} + {$define COMPILER_2} // C++ Builder v1 compiler is really v2 + {$define CPPB} + {$define CPPB_1} + {$endif} + + {$ifdef VER90} + {$define COMPILER_2} + {$define DELPHI} + {$define DELPHI_2} + {$endif} + + {$ifdef VER80} + {$define COMPILER_1} + {$define DELPHI} + {$define DELPHI_1} + {$endif} + + {$ifdef FPC} + {.$define DELPHI} + {$endif} + + {$ifdef DELPHI_2} + {$define DELPHI_2_UP} + {$endif} + + {$ifdef DELPHI_3} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$endif} + + {$ifdef DELPHI_4} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$endif} + + {$ifdef DELPHI_5} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$endif} + + {$ifdef DELPHI_6} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$endif} + + {$ifdef DELPHI_7} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$endif} + + {$ifdef DELPHI_9} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$define DELPHI_9_UP} + {$endif} + + {$ifdef DELPHI_10} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$define DELPHI_9_UP} + {$define DELPHI_10_UP} + {$endif} + + {$ifdef CPPB_3} + {$define CPPB_3_UP} + {$endif} + + {$ifdef CPPB_4} + {$define CPPB_3_UP} + {$define CPPB_4_UP} + {$endif} + + {$ifdef CPPB_5} + {$define CPPB_3_UP} + {$define CPPB_4_UP} + {$define CPPB_5_UP} + {$endif} + + {$ifdef CPPB_6} + {$define CPPB_3_UP} + {$define CPPB_4_UP} + {$define CPPB_5_UP} + {$define CPPB_6_UP} + {$endif} + + {$ifdef CPPB_3_UP} + // C++ Builder requires this if you use Delphi components in run-time packages. + {$ObjExportAll On} + {$endif} + +{$else (not Windows)} + // Linux is the target + {$define QT_CLX} + + {$define KYLIX} + {$define KYLIX_1} + {$define KYLIX_1_UP} + + {$ifdef VER150} + {$define COMPILER_7} + {$define KYLIX_3} + {$endif} + + {$ifdef VER140} + {$define COMPILER_6} + {$define KYLIX_2} + {$endif} + + {$ifdef KYLIX_2} + {$define KYLIX_2_UP} + {$endif} + + {$ifdef KYLIX_3} + {$define KYLIX_2_UP} + {$define KYLIX_3_UP} + {$endif} + +{$endif} + +// Compiler defines common to all platforms. +{$ifdef COMPILER_1} + {$define COMPILER_1_UP} +{$endif} + +{$ifdef COMPILER_2} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} +{$endif} + +{$ifdef COMPILER_3} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} +{$endif} + +{$ifdef COMPILER_4} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} +{$endif} + +{$ifdef COMPILER_5} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} +{$endif} + +{$ifdef COMPILER_6} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} +{$endif} + +{$ifdef COMPILER_7} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} + {$define COMPILER_7_UP} +{$endif} + +{$ifdef COMPILER_9} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} + {$define COMPILER_7_UP} + {$define COMPILER_9_UP} +{$endif} + +{$ifdef COMPILER_10} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} + {$define COMPILER_7_UP} + {$define COMPILER_9_UP} + {$define COMPILER_10_UP} +{$endif} + +//---------------------------------------------------------------------------------------------------------------------- + +{$ALIGN ON} +{$BOOLEVAL OFF} + +{$ifdef COMPILER_7_UP} + {$define THEME_7_UP} { Allows experimental theme support on pre-Delphi 7. } +{$endif} + +{$IFDEF COMPILER_6_UP} +{$WARN SYMBOL_PLATFORM OFF} { We are going to use Win32 specific symbols! } +{$ENDIF} + +{$IFDEF COMPILER_7_UP} +{$IFDEF FPC} + {$DEFINE UNSAFE_WARNINGS_OFF} +{$ENDIF} +{$ENDIF} + +{$IFDEF UNSAFE_WARNINGS_OFF} +{$WARN UNSAFE_CODE OFF} { We are not going to be "safe"! } +{$WARN UNSAFE_TYPE OFF} +{$WARN UNSAFE_CAST OFF} +{$ENDIF} + +{$IFDEF FPC} +{$HINTS OFF} +{$ENDIF} + +{$IFNDEF FPC} + // Delphi system function overrides might (not tested) cause problems on + // CPUs with code protection (NX-bit). So disable by default. + {.$DEFINE USE_SYSTEM_OVERRIDES} +{$ENDIF} + + diff --git a/cmake/src/lib/TntUnicodeControls/TntFormatStrUtils.pas b/cmake/src/lib/TntUnicodeControls/TntFormatStrUtils.pas new file mode 100644 index 00000000..80aefd4a --- /dev/null +++ b/cmake/src/lib/TntUnicodeControls/TntFormatStrUtils.pas @@ -0,0 +1,521 @@ +
+{*****************************************************************************}
+{ }
+{ Tnt Delphi Unicode Controls }
+{ http://www.tntware.com/delphicontrols/unicode/ }
+{ Version: 2.3.0 }
+{ }
+{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) }
+{ }
+{*****************************************************************************}
+
+unit TntFormatStrUtils;
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+{$ENDIF}
+
+{$INCLUDE TntCompilers.inc}
+
+interface
+
+// this unit provides functions to work with format strings
+
+uses
+ TntSysUtils;
+
+function GetCanonicalFormatStr(const _FormatString: WideString): WideString;
+
+{$IFNDEF FPC}
+{$IFNDEF COMPILER_9_UP}
+function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString;
+ const Args: array of const
+ {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString;
+{$ENDIF}
+{$ENDIF}
+procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString);
+function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean;
+
+type
+ EFormatSpecError = class(ETntGeneralError);
+
+implementation
+
+uses
+ SysUtils, Math, TntClasses;
+
+resourcestring
+ SInvalidFormatSpecifier = 'Invalid Format Specifier: %s';
+ SMismatchedArgumentTypes = 'Argument types for index %d do not match. (%s <> %s)';
+ SMismatchedArgumentCounts = 'Number of format specifiers do not match.';
+
+type
+ TFormatSpecifierType = (fstInteger, fstFloating, fstPointer, fstString);
+
+function GetFormatSpecifierType(const FormatSpecifier: WideString): TFormatSpecifierType;
+var
+ LastChar: WideChar;
+begin
+ LastChar := TntWideLastChar(FormatSpecifier);
+ case LastChar of
+ 'd', 'D', 'u', 'U', 'x', 'X':
+ result := fstInteger;
+ 'e', 'E', 'f', 'F', 'g', 'G', 'n', 'N', 'm', 'M':
+ result := fstFloating;
+ 'p', 'P':
+ result := fstPointer;
+ 's', 'S':
+ result := fstString
+ else
+ raise ETntInternalError.CreateFmt('Internal Error: Unexpected format type (%s)', [LastChar]);
+ end;
+end;
+
+type
+ TFormatStrParser = class(TObject)
+ private
+ ParsedString: TBufferedWideString;
+ PFormatString: PWideChar;
+ LastIndex: Integer;
+ ExplicitCount: Integer;
+ ImplicitCount: Integer;
+ procedure RaiseInvalidFormatSpecifier;
+ function ParseChar(c: WideChar): Boolean;
+ procedure ForceParseChar(c: WideChar);
+ function ParseDigit: Boolean;
+ function ParseInteger: Boolean;
+ procedure ForceParseType;
+ function PeekDigit: Boolean;
+ function PeekIndexSpecifier(out Index: Integer): Boolean;
+ public
+ constructor Create(const _FormatString: WideString);
+ destructor Destroy; override;
+ function ParseFormatSpecifier: Boolean;
+ end;
+
+constructor TFormatStrParser.Create(const _FormatString: WideString);
+begin
+ inherited Create;
+ PFormatString := PWideChar(_FormatString);
+ ExplicitCount := 0;
+ ImplicitCount := 0;
+ LastIndex := -1;
+ ParsedString := TBufferedWideString.Create;
+end;
+
+destructor TFormatStrParser.Destroy;
+begin
+ FreeAndNil(ParsedString);
+ inherited;
+end;
+
+procedure TFormatStrParser.RaiseInvalidFormatSpecifier;
+begin
+ raise EFormatSpecError.CreateFmt(SInvalidFormatSpecifier, [ParsedString.Value + PFormatString]);
+end;
+
+function TFormatStrParser.ParseChar(c: WideChar): Boolean;
+begin
+ result := False;
+ if PFormatString^ = c then begin
+ result := True;
+ ParsedString.AddChar(c);
+ Inc(PFormatString);
+ end;
+end;
+
+procedure TFormatStrParser.ForceParseChar(c: WideChar);
+begin
+ if not ParseChar(c) then
+ RaiseInvalidFormatSpecifier;
+end;
+
+function TFormatStrParser.PeekDigit: Boolean;
+begin
+ result := False;
+ if (PFormatString^ <> #0)
+ and (PFormatString^ >= '0')
+ and (PFormatString^ <= '9') then
+ result := True;
+end;
+
+function TFormatStrParser.ParseDigit: Boolean;
+begin
+ result := False;
+ if PeekDigit then begin
+ result := True;
+ ForceParseChar(PFormatString^);
+ end;
+end;
+
+function TFormatStrParser.ParseInteger: Boolean;
+const
+ MAX_INT_DIGITS = 6;
+var
+ digitcount: integer;
+begin
+ digitcount := 0;
+ While ParseDigit do begin
+ inc(digitcount);
+ end;
+ result := (digitcount > 0);
+ if digitcount > MAX_INT_DIGITS then
+ RaiseInvalidFormatSpecifier;
+end;
+
+procedure TFormatStrParser.ForceParseType;
+begin
+ if PFormatString^ = #0 then
+ RaiseInvalidFormatSpecifier;
+
+ case PFormatString^ of
+ 'd', 'u', 'x', 'e', 'f', 'g', 'n', 'm', 'p', 's',
+ 'D', 'U', 'X', 'E', 'F', 'G', 'N', 'M', 'P', 'S':
+ begin
+ // do nothing
+ end
+ else
+ RaiseInvalidFormatSpecifier;
+ end;
+ ForceParseChar(PFormatString^);
+end;
+
+function TFormatStrParser.PeekIndexSpecifier(out Index: Integer): Boolean;
+var
+ SaveParsedString: WideString;
+ SaveFormatString: PWideChar;
+begin
+ SaveParsedString := ParsedString.Value;
+ SaveFormatString := PFormatString;
+ try
+ ParsedString.Clear;
+ Result := False;
+ Index := -1;
+ if ParseInteger then begin
+ Index := StrToInt(ParsedString.Value);
+ if ParseChar(':') then
+ Result := True;
+ end;
+ finally
+ ParsedString.Clear;
+ ParsedString.AddString(SaveParsedString);
+ PFormatString := SaveFormatString;
+ end;
+end;
+
+function TFormatStrParser.ParseFormatSpecifier: Boolean;
+var
+ ExplicitIndex: Integer;
+begin
+ Result := False;
+ // Parse entire format specifier
+ ForceParseChar('%');
+ if (PFormatString^ <> #0)
+ and (not ParseChar(' '))
+ and (not ParseChar('%')) then begin
+ if PeekIndexSpecifier(ExplicitIndex) then begin
+ Inc(ExplicitCount);
+ LastIndex := Max(LastIndex, ExplicitIndex);
+ end else begin
+ Inc(ImplicitCount);
+ Inc(LastIndex);
+ ParsedString.AddString(IntToStr(LastIndex));
+ ParsedString.AddChar(':');
+ end;
+ if ParseChar('*') then
+ begin
+ Inc(ImplicitCount);
+ Inc(LastIndex);
+ ParseChar(':');
+ end else if ParseInteger then
+ ParseChar(':');
+ ParseChar('-');
+ if ParseChar('*') then begin
+ Inc(ImplicitCount);
+ Inc(LastIndex);
+ end else
+ ParseInteger;
+ if ParseChar('.') then begin
+ if not ParseChar('*') then
+ ParseInteger;
+ end;
+ ForceParseType;
+ Result := True;
+ end;
+end;
+
+//-----------------------------------
+
+function GetCanonicalFormatStr(const _FormatString: WideString): WideString;
+var
+ PosSpec: Integer;
+begin
+ with TFormatStrParser.Create(_FormatString) do
+ try
+ // loop until no more '%'
+ PosSpec := Pos(WideString('%'), PFormatString);
+ While PosSpec <> 0 do begin
+ try
+ // delete everything up until '%'
+ ParsedString.AddBuffer(PFormatString, PosSpec - 1);
+ Inc(PFormatString, PosSpec - 1);
+ // parse format specifier
+ ParseFormatSpecifier;
+ finally
+ PosSpec := Pos(WideString('%'), PFormatString);
+ end;
+ end;
+ if ((ExplicitCount = 0) and (ImplicitCount = 1)) {simple expression}
+ or ((ExplicitCount > 0) and (ImplicitCount = 0)) {nothing converted} then
+ result := _FormatString {original}
+ else
+ result := ParsedString.Value + PFormatString;
+ finally
+ Free;
+ end;
+end;
+
+{$IFNDEF FPC}
+{$IFNDEF COMPILER_9_UP}
+function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString;
+ const Args: array of const
+ {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString;
+{ This function replaces floating point format specifiers with their actual formatted values.
+ It also adds index specifiers so that the other format specifiers don't lose their place.
+ The reason for this is that WideFormat doesn't correctly format floating point specifiers.
+ See QC#4254. }
+var
+ Parser: TFormatStrParser;
+ PosSpec: Integer;
+ Output: TBufferedWideString;
+begin
+ Output := TBufferedWideString.Create;
+ try
+ Parser := TFormatStrParser.Create(_FormatString);
+ with Parser do
+ try
+ // loop until no more '%'
+ PosSpec := Pos('%', PFormatString);
+ While PosSpec <> 0 do begin
+ try
+ // delete everything up until '%'
+ Output.AddBuffer(PFormatString, PosSpec - 1);
+ Inc(PFormatString, PosSpec - 1);
+ // parse format specifier
+ ParsedString.Clear;
+ if (not ParseFormatSpecifier)
+ or (GetFormatSpecifierType(ParsedString.Value) <> fstFloating) then
+ Output.AddBuffer(ParsedString.BuffPtr, MaxInt)
+ {$IFDEF COMPILER_7_UP}
+ else if Assigned(FormatSettings) then
+ Output.AddString(Format{TNT-ALLOW Format}(ParsedString.Value, Args, FormatSettings^))
+ {$ENDIF}
+ else
+ Output.AddString(Format{TNT-ALLOW Format}(ParsedString.Value, Args));
+ finally
+ PosSpec := Pos('%', PFormatString);
+ end;
+ end;
+ Output.AddString(PFormatString);
+ finally
+ Free;
+ end;
+ Result := Output.Value;
+ finally
+ Output.Free;
+ end;
+end;
+{$ENDIF}
+{$ENDIF}
+
+procedure GetFormatArgs(const _FormatString: WideString; FormatArgs: TTntStrings);
+var
+ PosSpec: Integer;
+begin
+ with TFormatStrParser.Create(_FormatString) do
+ try
+ FormatArgs.Clear;
+ // loop until no more '%'
+ PosSpec := Pos(WideString('%'), PFormatString);
+ While PosSpec <> 0 do begin
+ try
+ // delete everything up until '%'
+ Inc(PFormatString, PosSpec - 1);
+ // add format specifier to list
+ ParsedString.Clear;
+ if ParseFormatSpecifier then
+ FormatArgs.Add(ParsedString.Value);
+ finally
+ PosSpec := Pos(WideString('%'), PFormatString);
+ end;
+ end;
+ finally
+ Free;
+ end;
+end;
+
+function GetExplicitIndex(const FormatSpecifier: WideString): Integer;
+var
+ IndexStr: WideString;
+ PosColon: Integer;
+begin
+ result := -1;
+ PosColon := Pos(':', FormatSpecifier);
+ if PosColon <> 0 then begin
+ IndexStr := Copy(FormatSpecifier, 2, PosColon - 2);
+ result := StrToInt(IndexStr);
+ end;
+end;
+
+function GetMaxIndex(FormatArgs: TTntStrings): Integer;
+var
+ i: integer;
+ RunningIndex: Integer;
+ ExplicitIndex: Integer;
+begin
+ result := -1;
+ RunningIndex := -1;
+ for i := 0 to FormatArgs.Count - 1 do begin
+ ExplicitIndex := GetExplicitIndex(FormatArgs[i]);
+ if ExplicitIndex <> -1 then
+ RunningIndex := ExplicitIndex
+ else
+ inc(RunningIndex);
+ result := Max(result, RunningIndex);
+ end;
+end;
+
+function FormatSpecToObject(SpecType: TFormatSpecifierType): TObject;
+begin
+ {$IFNDEF FPC}
+ Result := TObject(SpecType);
+ {$ELSE}
+ Result := Pointer(SpecType);
+ {$ENDIF}
+end;
+
+procedure UpdateTypeList(FormatArgs, TypeList: TTntStrings);
+var
+ i: integer;
+ f: WideString;
+ SpecType: TFormatSpecifierType;
+ ExplicitIndex: Integer;
+ MaxIndex: Integer;
+ RunningIndex: Integer;
+begin
+ // set count of TypeList to accomodate maximum index
+ MaxIndex := GetMaxIndex(FormatArgs);
+ TypeList.Clear;
+ for i := 0 to MaxIndex do
+ TypeList.Add('');
+
+ // for each arg...
+ RunningIndex := -1;
+ for i := 0 to FormatArgs.Count - 1 do begin
+ f := FormatArgs[i];
+ ExplicitIndex := GetExplicitIndex(f);
+ SpecType := GetFormatSpecifierType(f);
+
+ // determine running arg index
+ if ExplicitIndex <> -1 then
+ RunningIndex := ExplicitIndex
+ else
+ inc(RunningIndex);
+
+ if TypeList[RunningIndex] <> '' then begin
+ // already exists in list, check for compatibility
+ if TypeList.Objects[RunningIndex] <> FormatSpecToObject(SpecType) then
+ raise EFormatSpecError.CreateFmt(SMismatchedArgumentTypes,
+ [RunningIndex, TypeList[RunningIndex], f]);
+ end else begin
+ // not in list so update it
+ TypeList[RunningIndex] := f;
+ TypeList.Objects[RunningIndex] := FormatSpecToObject(SpecType);
+ end;
+ end;
+end;
+
+procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString);
+var
+ ArgList1: TTntStringList;
+ ArgList2: TTntStringList;
+ TypeList1: TTntStringList;
+ TypeList2: TTntStringList;
+ i: integer;
+begin
+ ArgList1 := nil;
+ ArgList2 := nil;
+ TypeList1 := nil;
+ TypeList2 := nil;
+ try
+ ArgList1 := TTntStringList.Create;
+ ArgList2 := TTntStringList.Create;
+ TypeList1 := TTntStringList.Create;
+ TypeList2 := TTntStringList.Create;
+
+ GetFormatArgs(FormatStr1, ArgList1);
+ UpdateTypeList(ArgList1, TypeList1);
+
+ GetFormatArgs(FormatStr2, ArgList2);
+ UpdateTypeList(ArgList2, TypeList2);
+
+ if TypeList1.Count <> TypeList2.Count then
+ raise EFormatSpecError.Create(SMismatchedArgumentCounts + CRLF + CRLF + '> ' + FormatStr1 + CRLF + '> ' + FormatStr2);
+
+ for i := 0 to TypeList1.Count - 1 do begin
+ if TypeList1.Objects[i] <> TypeList2.Objects[i] then begin
+ raise EFormatSpecError.CreateFmt(SMismatchedArgumentTypes,
+ [i, TypeList1[i], TypeList2[i]]);
+ end;
+ end;
+
+ finally
+ ArgList1.Free;
+ ArgList2.Free;
+ TypeList1.Free;
+ TypeList2.Free;
+ end;
+end;
+
+function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean;
+var
+ ArgList1: TTntStringList;
+ ArgList2: TTntStringList;
+ TypeList1: TTntStringList;
+ TypeList2: TTntStringList;
+ i: integer;
+begin
+ ArgList1 := nil;
+ ArgList2 := nil;
+ TypeList1 := nil;
+ TypeList2 := nil;
+ try
+ ArgList1 := TTntStringList.Create;
+ ArgList2 := TTntStringList.Create;
+ TypeList1 := TTntStringList.Create;
+ TypeList2 := TTntStringList.Create;
+
+ GetFormatArgs(FormatStr1, ArgList1);
+ UpdateTypeList(ArgList1, TypeList1);
+
+ GetFormatArgs(FormatStr2, ArgList2);
+ UpdateTypeList(ArgList2, TypeList2);
+
+ Result := (TypeList1.Count = TypeList2.Count);
+ if Result then begin
+ for i := 0 to TypeList1.Count - 1 do begin
+ if TypeList1.Objects[i] <> TypeList2.Objects[i] then begin
+ Result := False;
+ break;
+ end;
+ end;
+ end;
+ finally
+ ArgList1.Free;
+ ArgList2.Free;
+ TypeList1.Free;
+ TypeList2.Free;
+ end;
+end;
+
+end.
diff --git a/cmake/src/lib/TntUnicodeControls/TntSysUtils.pas b/cmake/src/lib/TntUnicodeControls/TntSysUtils.pas new file mode 100644 index 00000000..b7cf2467 --- /dev/null +++ b/cmake/src/lib/TntUnicodeControls/TntSysUtils.pas @@ -0,0 +1,1753 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntSysUtils; + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$INCLUDE TntCompilers.inc} + +interface + +{ TODO: Consider: more filename functions from SysUtils } +{ TODO: Consider: string functions from StrUtils. } + +uses + Types, SysUtils, Windows, TntWindows; + +//--------------------------------------------------------------------------------------------- +// Tnt - Types +//--------------------------------------------------------------------------------------------- + +// ......... introduced ......... +type + // The user of the application did something plainly wrong. + ETntUserError = class(Exception); + // A general error occured. (ie. file didn't exist, server didn't return data, etc.) + ETntGeneralError = class(Exception); + // Like Assert(). An error occured that should never have happened, send me a bug report now! + ETntInternalError = class(Exception); + +{$IFNDEF FPC} +type + PtrInt = LongInt; + PtrUInt = LongWord; +{$ENDIF} + +//--------------------------------------------------------------------------------------------- +// Tnt - SysUtils +//--------------------------------------------------------------------------------------------- + +// ......... SBCS and MBCS functions with WideString replacements in SysUtils.pas ......... + +{TNT-WARN CompareStr} {TNT-WARN AnsiCompareStr} +{TNT-WARN SameStr} {TNT-WARN AnsiSameStr} +{TNT-WARN SameText} {TNT-WARN AnsiSameText} +{TNT-WARN CompareText} {TNT-WARN AnsiCompareText} +{TNT-WARN UpperCase} {TNT-WARN AnsiUpperCase} +{TNT-WARN LowerCase} {TNT-WARN AnsiLowerCase} + +{TNT-WARN AnsiPos} { --> Pos() supports WideString. } +{TNT-WARN FmtStr} +{TNT-WARN Format} +{TNT-WARN FormatBuf} + +// ......... MBCS Byte Type Procs ......... + +{TNT-WARN ByteType} +{TNT-WARN StrByteType} +{TNT-WARN ByteToCharIndex} +{TNT-WARN ByteToCharLen} +{TNT-WARN CharToByteIndex} +{TNT-WARN CharToByteLen} + +// ........ null-terminated string functions ......... + +{TNT-WARN StrEnd} +{TNT-WARN StrLen} +{TNT-WARN StrLCopy} +{TNT-WARN StrCopy} +{TNT-WARN StrECopy} +{TNT-WARN StrPLCopy} +{TNT-WARN StrPCopy} +{TNT-WARN StrLComp} +{TNT-WARN AnsiStrLComp} +{TNT-WARN StrComp} +{TNT-WARN AnsiStrComp} +{TNT-WARN StrLIComp} +{TNT-WARN AnsiStrLIComp} +{TNT-WARN StrIComp} +{TNT-WARN AnsiStrIComp} +{TNT-WARN StrLower} +{TNT-WARN AnsiStrLower} +{TNT-WARN StrUpper} +{TNT-WARN AnsiStrUpper} +{TNT-WARN StrPos} +{TNT-WARN AnsiStrPos} +{TNT-WARN StrScan} +{TNT-WARN AnsiStrScan} +{TNT-WARN StrRScan} +{TNT-WARN AnsiStrRScan} +{TNT-WARN StrLCat} +{TNT-WARN StrCat} +{TNT-WARN StrMove} +{TNT-WARN StrPas} +{TNT-WARN StrAlloc} +{TNT-WARN StrBufSize} +{TNT-WARN StrNew} +{TNT-WARN StrDispose} + +{TNT-WARN AnsiExtractQuotedStr} +{TNT-WARN AnsiLastChar} +{TNT-WARN AnsiStrLastChar} +{TNT-WARN QuotedStr} +{TNT-WARN AnsiQuotedStr} +{TNT-WARN AnsiDequotedStr} + +// ........ string functions ......... + +{$IFNDEF FPC} +{$IFNDEF COMPILER_9_UP} + // + // pre-Delphi 9 issues w/ WideFormatBuf, WideFmtStr and WideFormat + // + + {$IFDEF COMPILER_7_UP} + type + PFormatSettings = ^TFormatSettings; + {$ENDIF} + + // SysUtils.WideFormatBuf doesn't correctly handle numeric specifiers. + function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; + FmtLen: Cardinal; const Args: array of const): Cardinal; {$IFDEF COMPILER_7_UP} overload; {$ENDIF} + + {$IFDEF COMPILER_7_UP} + function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; + FmtLen: Cardinal; const Args: array of const; + const FormatSettings: TFormatSettings): Cardinal; overload; + {$ENDIF} + + // SysUtils.WideFmtStr doesn't handle string lengths > 4096. + procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; + const Args: array of const); {$IFDEF COMPILER_7_UP} overload; {$ENDIF} + + {$IFDEF COMPILER_7_UP} + procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; + const Args: array of const; const FormatSettings: TFormatSettings); overload; + {$ENDIF} + + {---------------------------------------------------------------------------------------- + Without the FormatSettings parameter, Tnt_WideFormat is *NOT* necessary... + TntSystem.InstallTntSystemUpdates([tsFixWideFormat]); + will fix WideFormat as well as WideFmtStr. + ----------------------------------------------------------------------------------------} + function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const): WideString; {$IFDEF COMPILER_7_UP} overload; {$ENDIF} + + {$IFDEF COMPILER_7_UP} + function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const; + const FormatSettings: TFormatSettings): WideString; overload; + {$ENDIF} + +{$ENDIF} +{$ENDIF} + +{TNT-WARN WideUpperCase} // SysUtils.WideUpperCase is broken on Win9x for D6, D7, D9. +function Tnt_WideUpperCase(const S: WideString): WideString; +{TNT-WARN WideLowerCase} // SysUtils.WideLowerCase is broken on Win9x for D6, D7, D9. +function Tnt_WideLowerCase(const S: WideString): WideString; + +function TntWideLastChar(const S: WideString): WideChar; + +{TNT-WARN StringReplace} +{TNT-WARN WideStringReplace} // <-- WideStrUtils.WideStringReplace uses SysUtils.WideUpperCase which is broken on Win9x. +function Tnt_WideStringReplace(const S, OldPattern, NewPattern: WideString; + Flags: TReplaceFlags; WholeWord: Boolean = False): WideString; + +{TNT-WARN AdjustLineBreaks} +type TTntTextLineBreakStyle = (tlbsLF, tlbsCRLF, tlbsCR); +function TntAdjustLineBreaksLength(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): Integer; +function TntAdjustLineBreaks(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): WideString; + +{TNT-WARN WrapText} +function WideWrapText(const Line, BreakStr: WideString; const BreakChars: TSysCharSet; + MaxCol: Integer): WideString; overload; +function WideWrapText(const Line: WideString; MaxCol: Integer): WideString; overload; + +// ........ filename manipulation ......... + +{TNT-WARN SameFileName} // doesn't apply to Unicode filenames, use WideSameText +{TNT-WARN AnsiCompareFileName} // doesn't apply to Unicode filenames, use WideCompareText +{TNT-WARN AnsiLowerCaseFileName} // doesn't apply to Unicode filenames, use WideLowerCase +{TNT-WARN AnsiUpperCaseFileName} // doesn't apply to Unicode filenames, use WideUpperCase + +{TNT-WARN IncludeTrailingBackslash} +function WideIncludeTrailingBackslash(const S: WideString): WideString; +{TNT-WARN IncludeTrailingPathDelimiter} +function WideIncludeTrailingPathDelimiter(const S: WideString): WideString; +{TNT-WARN ExcludeTrailingBackslash} +function WideExcludeTrailingBackslash(const S: WideString): WideString; +{TNT-WARN ExcludeTrailingPathDelimiter} +function WideExcludeTrailingPathDelimiter(const S: WideString): WideString; +{TNT-WARN IsDelimiter} +function WideIsDelimiter(const Delimiters, S: WideString; Index: Integer): Boolean; +{TNT-WARN IsPathDelimiter} +function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean; +{TNT-WARN LastDelimiter} +function WideLastDelimiter(const Delimiters, S: WideString): Integer; +{TNT-WARN ChangeFileExt} +function WideChangeFileExt(const FileName, Extension: WideString): WideString; +{TNT-WARN ExtractFilePath} +function WideExtractFilePath(const FileName: WideString): WideString; +{TNT-WARN ExtractFileDir} +function WideExtractFileDir(const FileName: WideString): WideString; +{TNT-WARN ExtractFileDrive} +function WideExtractFileDrive(const FileName: WideString): WideString; +{TNT-WARN ExtractFileName} +function WideExtractFileName(const FileName: WideString): WideString; +{TNT-WARN ExtractFileExt} +function WideExtractFileExt(const FileName: WideString): WideString; +{TNT-WARN ExtractRelativePath} +function WideExtractRelativePath(const BaseName, DestName: WideString): WideString; + +// ........ file management routines ......... + +{TNT-WARN ExpandFileName} +function WideExpandFileName(const FileName: WideString): WideString; +{TNT-WARN ExtractShortPathName} +function WideExtractShortPathName(const FileName: WideString): WideString; +{TNT-WARN FileCreate} +function WideFileCreate(const FileName: WideString): Integer; +{TNT-WARN FileOpen} +function WideFileOpen(const FileName: WideString; Mode: LongWord): Integer; +{TNT-WARN FileAge} +function WideFileAge(const FileName: WideString): Integer; overload; +function WideFileAge(const FileName: WideString; out FileDateTime: TDateTime): Boolean; overload; +{TNT-WARN DirectoryExists} +function WideDirectoryExists(const Name: WideString): Boolean; +{TNT-WARN FileExists} +function WideFileExists(const Name: WideString): Boolean; +{TNT-WARN FileGetAttr} +function WideFileGetAttr(const FileName: WideString): Cardinal; +{TNT-WARN FileSetAttr} +function WideFileSetAttr(const FileName: WideString; Attr: Integer): Boolean; +{TNT-WARN FileIsReadOnly} +function WideFileIsReadOnly(const FileName: WideString): Boolean; +{TNT-WARN FileSetReadOnly} +function WideFileSetReadOnly(const FileName: WideString; ReadOnly: Boolean): Boolean; +{TNT-WARN ForceDirectories} +function WideForceDirectories(Dir: WideString): Boolean; +{TNT-WARN FileSearch} +function WideFileSearch(const Name, DirList: WideString): WideString; +{TNT-WARN RenameFile} +function WideRenameFile(const OldName, NewName: WideString): Boolean; +{TNT-WARN DeleteFile} +function WideDeleteFile(const FileName: WideString): Boolean; +{TNT-WARN CopyFile} +function WideCopyFile(const FromFile, ToFile: WideString; FailIfExists: Boolean): Boolean; + + +{TNT-WARN TFileName} +type + TWideFileName = type WideString; + +{TNT-WARN TSearchRec} // <-- FindFile - warning on TSearchRec is all that is necessary +type + TSearchRecW = record + Time: Integer; + Size: Int64; + Attr: Integer; + Name: TWideFileName; + ExcludeAttr: Integer; + FindHandle: THandle; + FindData: TWin32FindDataW; + end; +function WideFindFirst(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer; +function WideFindNext(var F: TSearchRecW): Integer; +procedure WideFindClose(var F: TSearchRecW); + +{TNT-WARN CreateDir} +function WideCreateDir(const Dir: WideString): Boolean; +{TNT-WARN RemoveDir} +function WideRemoveDir(const Dir: WideString): Boolean; +{TNT-WARN GetCurrentDir} +function WideGetCurrentDir: WideString; +{TNT-WARN SetCurrentDir} +function WideSetCurrentDir(const Dir: WideString): Boolean; + + +// ........ date/time functions ......... + +{TNT-WARN TryStrToDateTime} +function TntTryStrToDateTime(Str: WideString; out DateTime: TDateTime): Boolean; +{TNT-WARN TryStrToDate} +function TntTryStrToDate(Str: WideString; out DateTime: TDateTime): Boolean; +{TNT-WARN TryStrToTime} +function TntTryStrToTime(Str: WideString; out DateTime: TDateTime): Boolean; + +{ introduced } +function ValidDateTimeStr(Str: WideString): Boolean; +function ValidDateStr(Str: WideString): Boolean; +function ValidTimeStr(Str: WideString): Boolean; + +{TNT-WARN StrToDateTime} +function TntStrToDateTime(Str: WideString): TDateTime; +{TNT-WARN StrToDate} +function TntStrToDate(Str: WideString): TDateTime; +{TNT-WARN StrToTime} +function TntStrToTime(Str: WideString): TDateTime; +{TNT-WARN StrToDateTimeDef} +function TntStrToDateTimeDef(Str: WideString; Default: TDateTime): TDateTime; +{TNT-WARN StrToDateDef} +function TntStrToDateDef(Str: WideString; Default: TDateTime): TDateTime; +{TNT-WARN StrToTimeDef} +function TntStrToTimeDef(Str: WideString; Default: TDateTime): TDateTime; + +{TNT-WARN CurrToStr} +{TNT-WARN CurrToStrF} +function TntCurrToStr(Value: Currency; lpFormat: PCurrencyFmtW = nil): WideString; +{TNT-WARN StrToCurr} +function TntStrToCurr(const S: WideString): Currency; +{TNT-WARN StrToCurrDef} +function ValidCurrencyStr(const S: WideString): Boolean; +function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency; +function GetDefaultCurrencyFmt: TCurrencyFmtW; + +// ........ misc functions ......... + +{TNT-WARN GetLocaleStr} +function WideGetLocaleStr(LocaleID: LCID; LocaleType: Integer; const Default: WideString): WideString; +{TNT-WARN SysErrorMessage} +function WideSysErrorMessage(ErrorCode: Integer): WideString; + +// ......... introduced ......... + +function WideLibraryErrorMessage(const LibName: WideString; Dll: THandle; ErrorCode: Integer): WideString; + +const + CR = WideChar(#13); + LF = WideChar(#10); + CRLF = WideString(#13#10); + WideLineSeparator = WideChar($2028); + +var + Win32PlatformIsUnicode: Boolean; + Win32PlatformIsXP: Boolean; + Win32PlatformIs2003: Boolean; + Win32PlatformIsVista: Boolean; + +{$IFNDEF FPC} +{$IFNDEF COMPILER_7_UP} +function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; +{$ENDIF} +{$ENDIF} +function WinCheckH(RetVal: Cardinal): Cardinal; +function WinCheckFileH(RetVal: Cardinal): Cardinal; +function WinCheckP(RetVal: Pointer): Pointer; + +function WideGetModuleFileName(Instance: HModule): WideString; +function WideSafeLoadLibrary(const Filename: Widestring; + ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE; +{$IFNDEF FPC} +function WideLoadPackage(const Name: Widestring): HMODULE; +{$ENDIF} + +function IsWideCharUpper(WC: WideChar): Boolean; +function IsWideCharLower(WC: WideChar): Boolean; +function IsWideCharDigit(WC: WideChar): Boolean; +function IsWideCharSpace(WC: WideChar): Boolean; +function IsWideCharPunct(WC: WideChar): Boolean; +function IsWideCharCntrl(WC: WideChar): Boolean; +function IsWideCharBlank(WC: WideChar): Boolean; +function IsWideCharXDigit(WC: WideChar): Boolean; +function IsWideCharAlpha(WC: WideChar): Boolean; +function IsWideCharAlphaNumeric(WC: WideChar): Boolean; + +function WideTextPos(const SubStr, S: WideString): Integer; + +function ExtractStringArrayStr(P: PWideChar): WideString; +function ExtractStringFromStringArray(var P: PWideChar; Separator: WideChar = #0): WideString; +function ExtractStringsFromStringArray(P: PWideChar; Separator: WideChar = #0): TWideStringDynArray; + +function IsWideCharMappableToAnsi(const WC: WideChar): Boolean; +function IsWideStringMappableToAnsi(const WS: WideString): Boolean; +function IsRTF(const Value: WideString): Boolean; + +function ENG_US_FloatToStr(Value: Extended): WideString; +function ENG_US_StrToFloat(const S: WideString): Extended; + +//--------------------------------------------------------------------------------------------- +// Tnt - Variants +//--------------------------------------------------------------------------------------------- + +// ........ Variants.pas has WideString versions of these functions ......... +{TNT-WARN VarToStr} +{TNT-WARN VarToStrDef} + +var + _SettingChangeTime: Cardinal; + +implementation + +uses + ActiveX, ComObj, SysConst, + {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils, + TntSystem, TntFormatStrUtils; + +//--------------------------------------------------------------------------------------------- +// Tnt - SysUtils +//--------------------------------------------------------------------------------------------- + +{$IFNDEF FPC} +{$IFNDEF COMPILER_9_UP} + + function _Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; + FmtLen: Cardinal; const Args: array of const + {$IFDEF COMPILER_7_UP}; const FormatSettings: PFormatSettings {$ENDIF}): Cardinal; + var + OldFormat: WideString; + NewFormat: WideString; + begin + SetString(OldFormat, PWideChar(@FormatStr), FmtLen); + { The reason for this is that WideFormat doesn't correctly format floating point specifiers. + See QC#4254. } + NewFormat := ReplaceFloatingArgumentsInFormatString(OldFormat, Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}); + {$IFDEF COMPILER_7_UP} + if FormatSettings <> nil then + Result := WideFormatBuf(Buffer, BufLen, Pointer(NewFormat)^, + Length(NewFormat), Args, FormatSettings^) + else + {$ENDIF} + Result := WideFormatBuf(Buffer, BufLen, Pointer(NewFormat)^, + Length(NewFormat), Args); + end; + + function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; + FmtLen: Cardinal; const Args: array of const): Cardinal; + begin + Result := _Tnt_WideFormatBuf(Buffer, BufLen, FormatStr, FmtLen, Args{$IFDEF COMPILER_7_UP}, nil{$ENDIF}); + end; + + {$IFDEF COMPILER_7_UP} + function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; + FmtLen: Cardinal; const Args: array of const; const FormatSettings: TFormatSettings): Cardinal; + begin + Result := _Tnt_WideFormatBuf(Buffer, BufLen, FormatStr, FmtLen, Args, @FormatSettings); + end; + {$ENDIF} + + procedure _Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; + const Args: array of const{$IFDEF COMPILER_7_UP}; const FormatSettings: PFormatSettings{$ENDIF}); + var + Len, BufLen: Integer; + Buffer: array[0..4095] of WideChar; + begin + BufLen := Length(Buffer); // Fixes buffer overwrite issue. (See QC #4703, #4744) + if Length(FormatStr) < (Length(Buffer) - (Length(Buffer) div 4)) then + Len := _Tnt_WideFormatBuf(Buffer, Length(Buffer) - 1, Pointer(FormatStr)^, + Length(FormatStr), Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}) + else + begin + BufLen := Length(FormatStr); + Len := BufLen; + end; + if Len >= BufLen - 1 then + begin + while Len >= BufLen - 1 do + begin + Inc(BufLen, BufLen); + Result := ''; // prevent copying of existing data, for speed + SetLength(Result, BufLen); + Len := _Tnt_WideFormatBuf(Pointer(Result)^, BufLen - 1, Pointer(FormatStr)^, + Length(FormatStr), Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}); + end; + SetLength(Result, Len); + end + else + SetString(Result, Buffer, Len); + end; + + procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; + const Args: array of const); + begin + _Tnt_WideFmtStr(Result, FormatStr, Args{$IFDEF COMPILER_7_UP}, nil{$ENDIF}); + end; + + {$IFDEF COMPILER_7_UP} + procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; + const Args: array of const; const FormatSettings: TFormatSettings); + begin + _Tnt_WideFmtStr(Result, FormatStr, Args, @FormatSettings); + end; + {$ENDIF} + + {---------------------------------------------------------------------------------------- + Without the FormatSettings parameter, Tnt_WideFormat is *NOT* necessary... + TntSystem.InstallTntSystemUpdates([tsFixWideFormat]); + will fix WideFormat as well as WideFmtStr. + ----------------------------------------------------------------------------------------} + function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const): WideString; + begin + Tnt_WideFmtStr(Result, FormatStr, Args); + end; + + {$IFDEF COMPILER_7_UP} + function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const; + const FormatSettings: TFormatSettings): WideString; + begin + Tnt_WideFmtStr(Result, FormatStr, Args, FormatSettings); + end; + {$ENDIF} + +{$ENDIF} +{$ENDIF FPC} + +function Tnt_WideUpperCase(const S: WideString): WideString; +begin + {$IFNDEF FPC} + {$IFNDEF COMPILER_10_UP} + {$DEFINE WIDEUPPERCASE_BROKEN} + {$ENDIF} + {$ENDIF} + {$IFDEF WIDEUPPERCASE_BROKEN} + { SysUtils.WideUpperCase is broken for Win9x. } + Result := S; + if Length(Result) > 0 then + Tnt_CharUpperBuffW(PWideChar(Result), Length(Result)); + {$ELSE} + Result := SysUtils.WideUpperCase{TNT-ALLOW WideUpperCase}(S); + {$ENDIF} +end; + +function Tnt_WideLowerCase(const S: WideString): WideString; +begin + {$IFNDEF FPC} + {$IFNDEF COMPILER_10_UP} + {$DEFINE WIDELOWERCASE_BROKEN} + {$ENDIF} + {$ENDIF} + {$IFDEF WIDELOWERCASE_BROKEN} + { SysUtils.WideLowerCase is broken for Win9x. } + Result := S; + if Length(Result) > 0 then + Tnt_CharLowerBuffW(PWideChar(Result), Length(Result)); + {$ELSE} + Result := SysUtils.WideLowerCase{TNT-ALLOW WideLowerCase}(S); + {$ENDIF} +end; + +function TntWideLastChar(const S: WideString): WideChar; +var + P: PWideChar; +begin + P := WideLastChar(S); + if P = nil then + Result := #0 + else + Result := P^; +end; + +function Tnt_WideStringReplace(const S, OldPattern, NewPattern: WideString; + Flags: TReplaceFlags; WholeWord: Boolean = False): WideString; + + function IsWordSeparator(WC: WideChar): Boolean; + begin + Result := (WC = WideChar(#0)) + or IsWideCharSpace(WC) + or IsWideCharPunct(WC); + end; + +var + SearchStr, Patt, NewStr: WideString; + Offset: Integer; + PrevChar, NextChar: WideChar; +begin + if rfIgnoreCase in Flags then + begin + SearchStr := Tnt_WideUpperCase(S); + Patt := Tnt_WideUpperCase(OldPattern); + end else + begin + SearchStr := S; + Patt := OldPattern; + end; + NewStr := S; + Result := ''; + while SearchStr <> '' do + begin + Offset := Pos(Patt, SearchStr); + if Offset = 0 then + begin + Result := Result + NewStr; + Break; + end; // done + + if (WholeWord) then + begin + if (Offset = 1) then + PrevChar := TntWideLastChar(Result) + else + PrevChar := NewStr[Offset - 1]; + + if Offset + Length(OldPattern) <= Length(NewStr) then + NextChar := NewStr[Offset + Length(OldPattern)] + else + NextChar := WideChar(#0); + + if (not IsWordSeparator(PrevChar)) + or (not IsWordSeparator(NextChar)) then + begin + Result := Result + Copy(NewStr, 1, Offset + Length(OldPattern) - 1); + NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); + SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt); + continue; + end; + end; + + Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern; + NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); + if not (rfReplaceAll in Flags) then + begin + Result := Result + NewStr; + Break; + end; + SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt); + end; +end; + +function TntAdjustLineBreaksLength(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): Integer; +var + Source, SourceEnd: PWideChar; +begin + Source := Pointer(S); + SourceEnd := Source + Length(S); + Result := Length(S); + while Source < SourceEnd do + begin + case Source^ of + #10, WideLineSeparator: + if Style = tlbsCRLF then + Inc(Result); + #13: + if Style = tlbsCRLF then + if Source[1] = #10 then + Inc(Source) + else + Inc(Result) + else + if Source[1] = #10 then + Dec(Result); + end; + Inc(Source); + end; +end; + +function TntAdjustLineBreaks(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): WideString; +var + Source, SourceEnd, Dest: PWideChar; + DestLen: Integer; +begin + Source := Pointer(S); + SourceEnd := Source + Length(S); + DestLen := TntAdjustLineBreaksLength(S, Style); + SetString(Result, nil, DestLen); + Dest := Pointer(Result); + while Source < SourceEnd do begin + case Source^ of + #10, WideLineSeparator: + begin + if Style in [tlbsCRLF, tlbsCR] then + begin + Dest^ := #13; + Inc(Dest); + end; + if Style in [tlbsCRLF, tlbsLF] then + begin + Dest^ := #10; + Inc(Dest); + end; + Inc(Source); + end; + #13: + begin + if Style in [tlbsCRLF, tlbsCR] then + begin + Dest^ := #13; + Inc(Dest); + end; + if Style in [tlbsCRLF, tlbsLF] then + begin + Dest^ := #10; + Inc(Dest); + end; + Inc(Source); + if Source^ = #10 then Inc(Source); + end; + else + Dest^ := Source^; + Inc(Dest); + Inc(Source); + end; + end; +end; + +function WideWrapText(const Line, BreakStr: WideString; const BreakChars: TSysCharSet; + MaxCol: Integer): WideString; + + function WideCharIn(C: WideChar; SysCharSet: TSysCharSet): Boolean; + begin + Result := (C <= High(AnsiChar)) and (AnsiChar(C) in SysCharSet); + end; + +const + QuoteChars = ['''', '"']; +var + Col, Pos: Integer; + LinePos, LineLen: Integer; + BreakLen, BreakPos: Integer; + QuoteChar, CurChar: WideChar; + ExistingBreak: Boolean; +begin + Col := 1; + Pos := 1; + LinePos := 1; + BreakPos := 0; + QuoteChar := ' '; + ExistingBreak := False; + LineLen := Length(Line); + BreakLen := Length(BreakStr); + Result := ''; + while Pos <= LineLen do + begin + CurChar := Line[Pos]; + if CurChar = BreakStr[1] then + begin + if QuoteChar = ' ' then + begin + ExistingBreak := WideSameText(BreakStr, Copy(Line, Pos, BreakLen)); + if ExistingBreak then + begin + Inc(Pos, BreakLen-1); + BreakPos := Pos; + end; + end + end + else if WideCharIn(CurChar, BreakChars) then + begin + if QuoteChar = ' ' then BreakPos := Pos + end + else if WideCharIn(CurChar, QuoteChars) then + begin + if CurChar = QuoteChar then + QuoteChar := ' ' + else if QuoteChar = ' ' then + QuoteChar := CurChar; + end; + Inc(Pos); + Inc(Col); + if not (WideCharIn(QuoteChar, QuoteChars)) and (ExistingBreak or + ((Col > MaxCol) and (BreakPos > LinePos))) then + begin + Col := Pos - BreakPos; + Result := Result + Copy(Line, LinePos, BreakPos - LinePos + 1); + if not (WideCharIn(CurChar, QuoteChars)) then + while Pos <= LineLen do + begin + if WideCharIn(Line[Pos], BreakChars) then + Inc(Pos) + else if Copy(Line, Pos, Length(sLineBreak)) = sLineBreak then + Inc(Pos, Length(sLineBreak)) + else + break; + end; + if not ExistingBreak and (Pos < LineLen) then + Result := Result + BreakStr; + Inc(BreakPos); + LinePos := BreakPos; + ExistingBreak := False; + end; + end; + Result := Result + Copy(Line, LinePos, MaxInt); +end; + +function WideWrapText(const Line: WideString; MaxCol: Integer): WideString; +begin + Result := WideWrapText(Line, sLineBreak, [' ', '-', #9], MaxCol); { do not localize } +end; + +function WideIncludeTrailingBackslash(const S: WideString): WideString; +begin + Result := WideIncludeTrailingPathDelimiter(S); +end; + +function WideIncludeTrailingPathDelimiter(const S: WideString): WideString; +begin + Result := S; + if not WideIsPathDelimiter(Result, Length(Result)) then Result := Result + PathDelim; +end; + +function WideExcludeTrailingBackslash(const S: WideString): WideString; +begin + Result := WideExcludeTrailingPathDelimiter(S); +end; + +function WideExcludeTrailingPathDelimiter(const S: WideString): WideString; +begin + Result := S; + if WideIsPathDelimiter(Result, Length(Result)) then + SetLength(Result, Length(Result)-1); +end; + +function WideIsDelimiter(const Delimiters, S: WideString; Index: Integer): Boolean; +begin + Result := False; + if (Index <= 0) or (Index > Length(S)) then exit; + Result := WStrScan(PWideChar(Delimiters), S[Index]) <> nil; +end; + +function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean; +begin + Result := (Index > 0) and (Index <= Length(S)) and (S[Index] = PathDelim); +end; + +function WideLastDelimiter(const Delimiters, S: WideString): Integer; +var + P: PWideChar; +begin + Result := Length(S); + P := PWideChar(Delimiters); + while Result > 0 do + begin + if (S[Result] <> #0) and (WStrScan(P, S[Result]) <> nil) then + Exit; + Dec(Result); + end; +end; + +function WideChangeFileExt(const FileName, Extension: WideString): WideString; +var + I: Integer; +begin + I := WideLastDelimiter('.\:',Filename); + if (I = 0) or (FileName[I] <> '.') then I := MaxInt; + Result := Copy(FileName, 1, I - 1) + Extension; +end; + +function WideExtractFilePath(const FileName: WideString): WideString; +var + I: Integer; +begin + I := WideLastDelimiter('\:', FileName); + Result := Copy(FileName, 1, I); +end; + +function WideExtractFileDir(const FileName: WideString): WideString; +var + I: Integer; +begin + I := WideLastDelimiter(DriveDelim + PathDelim,Filename); + if (I > 1) and (FileName[I] = PathDelim) and + (not (FileName[I - 1] in [WideChar(PathDelim), WideChar(DriveDelim)])) then Dec(I); + Result := Copy(FileName, 1, I); +end; + +function WideExtractFileDrive(const FileName: WideString): WideString; +var + I, J: Integer; +begin + if (Length(FileName) >= 2) and (FileName[2] = DriveDelim) then + Result := Copy(FileName, 1, 2) + else if (Length(FileName) >= 2) and (FileName[1] = PathDelim) and + (FileName[2] = PathDelim) then + begin + J := 0; + I := 3; + While (I < Length(FileName)) and (J < 2) do + begin + if FileName[I] = PathDelim then Inc(J); + if J < 2 then Inc(I); + end; + if FileName[I] = PathDelim then Dec(I); + Result := Copy(FileName, 1, I); + end else Result := ''; +end; + +function WideExtractFileName(const FileName: WideString): WideString; +var + I: Integer; +begin + I := WideLastDelimiter('\:', FileName); + Result := Copy(FileName, I + 1, MaxInt); +end; + +function WideExtractFileExt(const FileName: WideString): WideString; +var + I: Integer; +begin + I := WideLastDelimiter('.\:', FileName); + if (I > 0) and (FileName[I] = '.') then + Result := Copy(FileName, I, MaxInt) else + Result := ''; +end; + +function WideExtractRelativePath(const BaseName, DestName: WideString): WideString; +var + BasePath, DestPath: WideString; + BaseLead, DestLead: PWideChar; + BasePtr, DestPtr: PWideChar; + + function WideExtractFilePathNoDrive(const FileName: WideString): WideString; + begin + Result := WideExtractFilePath(FileName); + Delete(Result, 1, Length(WideExtractFileDrive(FileName))); + end; + + function Next(var Lead: PWideChar): PWideChar; + begin + Result := Lead; + if Result = nil then Exit; + Lead := WStrScan(Lead, PathDelim); + if Lead <> nil then + begin + Lead^ := #0; + Inc(Lead); + end; + end; + +begin + if WideSameText(WideExtractFileDrive(BaseName), WideExtractFileDrive(DestName)) then + begin + BasePath := WideExtractFilePathNoDrive(BaseName); + DestPath := WideExtractFilePathNoDrive(DestName); + BaseLead := Pointer(BasePath); + BasePtr := Next(BaseLead); + DestLead := Pointer(DestPath); + DestPtr := Next(DestLead); + while (BasePtr <> nil) and (DestPtr <> nil) and WideSameText(BasePtr, DestPtr) do + begin + BasePtr := Next(BaseLead); + DestPtr := Next(DestLead); + end; + Result := ''; + while BaseLead <> nil do + begin + Result := Result + '..' + PathDelim; { Do not localize } + Next(BaseLead); + end; + if (DestPtr <> nil) and (DestPtr^ <> #0) then + Result := Result + DestPtr + PathDelim; + if DestLead <> nil then + Result := Result + DestLead; // destlead already has a trailing backslash + Result := Result + WideExtractFileName(DestName); + end + else + Result := DestName; +end; + +function WideExpandFileName(const FileName: WideString): WideString; +var + FName: PWideChar; + Buffer: array[0..MAX_PATH - 1] of WideChar; +begin + SetString(Result, Buffer, Tnt_GetFullPathNameW(PWideChar(FileName), MAX_PATH, Buffer, FName)); +end; + +function WideExtractShortPathName(const FileName: WideString): WideString; +var + Buffer: array[0..MAX_PATH - 1] of WideChar; +begin + SetString(Result, Buffer, Tnt_GetShortPathNameW(PWideChar(FileName), Buffer, MAX_PATH)); +end; + +function WideFileCreate(const FileName: WideString): Integer; +begin + Result := Integer(Tnt_CreateFileW(PWideChar(FileName), GENERIC_READ or GENERIC_WRITE, + 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)) +end; + +function WideFileOpen(const FileName: WideString; Mode: LongWord): Integer; +const + AccessMode: array[0..2] of LongWord = ( + GENERIC_READ, + GENERIC_WRITE, + GENERIC_READ or GENERIC_WRITE); + ShareMode: array[0..4] of LongWord = ( + 0, + 0, + FILE_SHARE_READ, + FILE_SHARE_WRITE, + FILE_SHARE_READ or FILE_SHARE_WRITE); +begin + Result := Integer(Tnt_CreateFileW(PWideChar(FileName), AccessMode[Mode and 3], + ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING, + FILE_ATTRIBUTE_NORMAL, 0)); +end; + +function WideFileAge(const FileName: WideString): Integer; +var + Handle: THandle; + FindData: TWin32FindDataW; + LocalFileTime: TFileTime; +begin + Handle := Tnt_FindFirstFileW(PWideChar(FileName), FindData); + if Handle <> INVALID_HANDLE_VALUE then + begin + Windows.FindClose(Handle); + if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then + begin + FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); + if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi, LongRec(Result).Lo) then + Exit + end; + end; + Result := -1; +end; + +function WideFileAge(const FileName: WideString; out FileDateTime: TDateTime): Boolean; +var + Handle: THandle; + FindData: TWin32FindDataW; + LSystemTime: TSystemTime; + LocalFileTime: TFileTime; +begin + Result := False; + Handle := Tnt_FindFirstFileW(PWideChar(FileName), FindData); + if Handle <> INVALID_HANDLE_VALUE then + begin + Windows.FindClose(Handle); + if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then + begin + Result := True; + FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); + FileTimeToSystemTime(LocalFileTime, LSystemTime); + with LSystemTime do + FileDateTime := EncodeDate(wYear, wMonth, wDay) + + EncodeTime(wHour, wMinute, wSecond, wMilliSeconds); + end; + end; +end; + +function WideDirectoryExists(const Name: WideString): Boolean; +var + Code: Cardinal; +begin + Code := WideFileGetAttr(Name); + Result := (Code <> INVALID_FILE_ATTRIBUTES) and ((FILE_ATTRIBUTE_DIRECTORY and Code) <> 0); +end; + +function WideFileExists(const Name: WideString): Boolean; +var + Code: Cardinal; +begin + Code := WideFileGetAttr(Name); + Result := (Code <> INVALID_FILE_ATTRIBUTES) and ((FILE_ATTRIBUTE_DIRECTORY and Code) = 0); +end; + +function WideFileGetAttr(const FileName: WideString): Cardinal; +begin + Result := Tnt_GetFileAttributesW(PWideChar(FileName)); +end; + +function WideFileSetAttr(const FileName: WideString; Attr: Integer): Boolean; +begin + Result := Tnt_SetFileAttributesW(PWideChar(FileName), Attr) +end; + +function WideFileIsReadOnly(const FileName: WideString): Boolean; +begin + Result := (Tnt_GetFileAttributesW(PWideChar(FileName)) and faReadOnly) <> 0; +end; + +function WideFileSetReadOnly(const FileName: WideString; ReadOnly: Boolean): Boolean; +var + Flags: Integer; +begin + Result := False; + Flags := Tnt_GetFileAttributesW(PWideChar(FileName)); + if Flags = -1 then Exit; + if ReadOnly then + Flags := Flags or faReadOnly + else + Flags := Flags and not faReadOnly; + Result := Tnt_SetFileAttributesW(PWideChar(FileName), Flags); +end; + +function WideForceDirectories(Dir: WideString): Boolean; +begin + Result := True; + if Length(Dir) = 0 then + raise ETntGeneralError.Create( + {$IFNDEF FPC} SCannotCreateDir {$ELSE} SCannotCreateEmptyDir {$ENDIF}); + Dir := WideExcludeTrailingBackslash(Dir); + if (Length(Dir) < 3) or WideDirectoryExists(Dir) + or (WideExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem. + Result := WideForceDirectories(WideExtractFilePath(Dir)); + if Result then + Result := Tnt_CreateDirectoryW(PWideChar(Dir), nil) +end; + +function WideFileSearch(const Name, DirList: WideString): WideString; +var + I, P, L: Integer; + C: WideChar; +begin + Result := Name; + P := 1; + L := Length(DirList); + while True do + begin + if WideFileExists(Result) then Exit; + while (P <= L) and (DirList[P] = PathSep) do Inc(P); + if P > L then Break; + I := P; + while (P <= L) and (DirList[P] <> PathSep) do + Inc(P); + Result := Copy(DirList, I, P - I); + C := TntWideLastChar(Result); + if (C <> DriveDelim) and (C <> PathDelim) then + Result := Result + PathDelim; + Result := Result + Name; + end; + Result := ''; +end; + +function WideRenameFile(const OldName, NewName: WideString): Boolean; +begin + Result := Tnt_MoveFileW(PWideChar(OldName), PWideChar(NewName)) +end; + +function WideDeleteFile(const FileName: WideString): Boolean; +begin + Result := Tnt_DeleteFileW(PWideChar(FileName)) +end; + +function WideCopyFile(const FromFile, ToFile: WideString; FailIfExists: Boolean): Boolean; +begin + Result := Tnt_CopyFileW(PWideChar(FromFile), PWideChar(ToFile), FailIfExists) +end; + +function _WideFindMatchingFile(var F: TSearchRecW): Integer; +var + LocalFileTime: TFileTime; +begin + with F do + begin + while FindData.dwFileAttributes and ExcludeAttr <> 0 do + if not Tnt_FindNextFileW(FindHandle, FindData) then + begin + Result := GetLastError; + Exit; + end; + FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); + FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, LongRec(Time).Lo); + Size := (Int64(FindData.nFileSizeHigh) shl 32) + FindData.nFileSizeLow; + Attr := FindData.dwFileAttributes; + Name := FindData.cFileName; + end; + Result := 0; +end; + +function WideFindFirst(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer; +const + faSpecial = faHidden or faSysFile {$IFNDEF COMPILER_9_UP} or faVolumeID {$ENDIF} or faDirectory; +begin + F.ExcludeAttr := not Attr and faSpecial; + F.FindHandle := Tnt_FindFirstFileW(PWideChar(Path), F.FindData); + if F.FindHandle <> INVALID_HANDLE_VALUE then + begin + Result := _WideFindMatchingFile(F); + if Result <> 0 then WideFindClose(F); + end else + Result := GetLastError; +end; + +function WideFindNext(var F: TSearchRecW): Integer; +begin + if Tnt_FindNextFileW(F.FindHandle, F.FindData) then + Result := _WideFindMatchingFile(F) else + Result := GetLastError; +end; + +procedure WideFindClose(var F: TSearchRecW); +begin + if F.FindHandle <> INVALID_HANDLE_VALUE then + begin + Windows.FindClose(F.FindHandle); + F.FindHandle := INVALID_HANDLE_VALUE; + end; +end; + +function WideCreateDir(const Dir: WideString): Boolean; +begin + Result := Tnt_CreateDirectoryW(PWideChar(Dir), nil); +end; + +function WideRemoveDir(const Dir: WideString): Boolean; +begin + Result := Tnt_RemoveDirectoryW(PWideChar(Dir)); +end; + +function WideGetCurrentDir: WideString; +begin + SetLength(Result, MAX_PATH); + Tnt_GetCurrentDirectoryW(MAX_PATH, PWideChar(Result)); + Result := PWideChar(Result); +end; + +function WideSetCurrentDir(const Dir: WideString): Boolean; +begin + Result := Tnt_SetCurrentDirectoryW(PWideChar(Dir)); +end; + +//============================================================================================= +//== DATE/TIME STRING PARSING ================================================================ +//============================================================================================= + +{$IFDEF FPC} +const + VAR_TIMEVALUEONLY = 1; + VAR_DATEVALUEONLY = 2; +{$ENDIF} + +function _IntTryStrToDateTime(Str: WideString; Flags: Integer; out DateTime: TDateTime): HResult; +begin + Result := VarDateFromStr( + {$IFDEF FPC} POLECHAR(Str) {$ELSE} Str {$ENDIF}, + GetThreadLocale, Flags, Double(DateTime)); + if (not Succeeded(Result)) then begin + if (Flags = VAR_TIMEVALUEONLY) + and SysUtils.TryStrToTime{TNT-ALLOW TryStrToTime}(Str, DateTime) then + Result := S_OK // SysUtils seems confident (works for date = "dd.MM.yy" and time = "H.mm.ss") + else if (Flags = VAR_DATEVALUEONLY) + and SysUtils.TryStrToDate{TNT-ALLOW TryStrToDate}(Str, DateTime) then + Result := S_OK // SysUtils seems confident + else if (Flags = 0) + and SysUtils.TryStrToDateTime{TNT-ALLOW TryStrToDateTime}(Str, DateTime) then + Result := S_OK // SysUtils seems confident + end; +end; + +function TntTryStrToDateTime(Str: WideString; out DateTime: TDateTime): Boolean; +begin + Result := Succeeded(_IntTryStrToDateTime(Str, 0, DateTime)); +end; + +function TntTryStrToDate(Str: WideString; out DateTime: TDateTime): Boolean; +begin + Result := Succeeded(_IntTryStrToDateTime(Str, VAR_DATEVALUEONLY, DateTime)); +end; + +function TntTryStrToTime(Str: WideString; out DateTime: TDateTime): Boolean; +begin + Result := Succeeded(_IntTryStrToDateTime(Str, VAR_TIMEVALUEONLY, DateTime)); +end; + +function ValidDateTimeStr(Str: WideString): Boolean; +var + Temp: TDateTime; +begin + Result := Succeeded(_IntTryStrToDateTime(Str, 0, Temp)); +end; + +function ValidDateStr(Str: WideString): Boolean; +var + Temp: TDateTime; +begin + Result := Succeeded(_IntTryStrToDateTime(Str, VAR_DATEVALUEONLY, Temp)); +end; + +function ValidTimeStr(Str: WideString): Boolean; +var + Temp: TDateTime; +begin + Result := Succeeded(_IntTryStrToDateTime(Str, VAR_TIMEVALUEONLY, Temp)); +end; + +function TntStrToDateTimeDef(Str: WideString; Default: TDateTime): TDateTime; +begin + if not TntTryStrToDateTime(Str, Result) then + Result := Default; +end; + +function TntStrToDateDef(Str: WideString; Default: TDateTime): TDateTime; +begin + if not TntTryStrToDate(Str, Result) then + Result := Default; +end; + +function TntStrToTimeDef(Str: WideString; Default: TDateTime): TDateTime; +begin + if not TntTryStrToTime(Str, Result) then + Result := Default; +end; + +function _IntStrToDateTime(Str: WideString; Flags: Integer; ErrorFormatStr: WideString): TDateTime; +begin + try + OleCheck(_IntTryStrToDateTime(Str, Flags, Result)); + except + on E: Exception do begin + E.Message := E.Message + CRLF + WideFormat(ErrorFormatStr, [Str]); + raise EConvertError.Create(E.Message); + end; + end; +end; + +function TntStrToDateTime(Str: WideString): TDateTime; +begin + Result := _IntStrToDateTime(Str, 0, SInvalidDateTime); +end; + +function TntStrToDate(Str: WideString): TDateTime; +begin + Result := _IntStrToDateTime(Str, VAR_DATEVALUEONLY, + {$IFNDEF FPC} SInvalidDate {$ELSE} SInvalidDateTime {$ENDIF}); +end; + +function TntStrToTime(Str: WideString): TDateTime; +begin + Result := _IntStrToDateTime(Str, VAR_TIMEVALUEONLY, + {$IFNDEF FPC} SInvalidTime {$ELSE} SInvalidDateTime {$ENDIF}); +end; + +//============================================================================================= +//== CURRENCY STRING PARSING ================================================================= +//============================================================================================= + +function TntCurrToStr(Value: Currency; lpFormat: PCurrencyFmtW = nil): WideString; +const + MAX_BUFF_SIZE = 64; // can a currency string actually be larger? +var + ValueStr: WideString; +begin + // format lpValue using ENG-US settings + ValueStr := ENG_US_FloatToStr(Value); + // get currency format + SetLength(Result, MAX_BUFF_SIZE); + if 0 = Tnt_GetCurrencyFormatW(GetThreadLocale, 0, PWideChar(ValueStr), + lpFormat, PWideChar(Result), Length(Result)) + then begin + RaiseLastOSError; + end; + Result := PWideChar(Result); +end; + +function TntStrToCurr(const S: WideString): Currency; +begin + try + OleCheck(VarCyFromStr( + {$IFDEF FPC} POLECHAR(S) {$ELSE} S {$ENDIF}, + GetThreadLocale, 0, Result)); + except + on E: Exception do begin + E.Message := E.Message + CRLF + WideFormat(SInvalidCurrency, [S]); + raise EConvertError.Create(E.Message); + end; + end; +end; + +function ValidCurrencyStr(const S: WideString): Boolean; +var + Dummy: Currency; +begin + Result := Succeeded(VarCyFromStr( + {$IFDEF FPC} POLECHAR(S) {$ELSE} S {$ENDIF}, + GetThreadLocale, 0, Dummy)); +end; + +function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency; +begin + if not Succeeded(VarCyFromStr( + {$IFDEF FPC} POLECHAR(S) {$ELSE} S {$ENDIF}, + GetThreadLocale, 0, Result)) then + Result := Default; +end; + +threadvar + Currency_DecimalSep: WideString; + Currency_ThousandSep: WideString; + Currency_CurrencySymbol: WideString; + +function GetDefaultCurrencyFmt: TCurrencyFmtW; +begin + ZeroMemory(@Result, SizeOf(Result)); + Result.NumDigits := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ICURRDIGITS, '2'), 2); + Result.LeadingZero := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ILZERO, '1'), 1); + Result.Grouping := StrToIntDef(Copy(WideGetLocaleStr(GetThreadLocale, LOCALE_SMONGROUPING, '3;0'), 1, 1), 3); + Currency_DecimalSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONDECIMALSEP, '.'); + Result.lpDecimalSep := {$IFNDEF FPC} PWideChar(Currency_DecimalSep) + {$ELSE} LPTSTR(PWideChar(Currency_DecimalSep)) {$ENDIF}; + Currency_ThousandSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONTHOUSANDSEP, ','); + Result.lpThousandSep := {$IFNDEF FPC} PWideChar(Currency_ThousandSep) + {$ELSE} LPTSTR(PWideChar(Currency_ThousandSep)) {$ENDIF}; + Result.NegativeOrder := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_INEGCURR, '0'), 0); + Result.PositiveOrder := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ICURRENCY, '0'), 0); + Currency_CurrencySymbol := WideGetLocaleStr(GetThreadLocale, LOCALE_SCURRENCY, ''); + Result.lpCurrencySymbol := {$IFNDEF FPC} PWideChar(Currency_CurrencySymbol) + {$ELSE} LPTSTR(PWideChar(Currency_CurrencySymbol)) {$ENDIF}; +end; + +//============================================================================================= + +{$IFDEF FPC} +function GetLocaleStr(Locale, LocaleType: Integer; const Default: string): string; +var + L: Integer; + Buffer: array[0..255] of Char; +begin + L := GetLocaleInfo(Locale, LocaleType, Buffer, SizeOf(Buffer)); + if L > 0 then SetString(Result, Buffer, L - 1) else Result := Default; +end; +{$ENDIF} + +function WideGetLocaleStr(LocaleID: LCID; LocaleType: Integer; const Default: WideString): WideString; +var + L: Integer; +begin + if (not Win32PlatformIsUnicode) then + Result := GetLocaleStr{TNT-ALLOW GetLocaleStr}(LocaleID, LocaleType, Default) + else begin + SetLength(Result, 255); + L := GetLocaleInfoW(LocaleID, LocaleType, PWideChar(Result), Length(Result)); + if L > 0 then + SetLength(Result, L - 1) + else + Result := Default; + end; +end; + +function WideSysErrorMessage(ErrorCode: Integer): WideString; +begin + Result := WideLibraryErrorMessage('system', 0, ErrorCode); +end; + +function WideLibraryErrorMessage(const LibName: WideString; Dll: THandle; ErrorCode: Integer): WideString; +var + Len: Integer; + AnsiResult: AnsiString; + Flags: Cardinal; +begin + Flags := FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY; + if Dll <> 0 then + Flags := Flags or FORMAT_MESSAGE_FROM_HMODULE; + if Win32PlatformIsUnicode then begin + SetLength(Result, 256); + Len := FormatMessageW(Flags, Pointer(Dll), ErrorCode, 0, PWideChar(Result), Length(Result), nil); + SetLength(Result, Len); + end else begin + SetLength(AnsiResult, 256); + Len := FormatMessageA(Flags, Pointer(Dll), ErrorCode, 0, PAnsiChar(AnsiResult), Length(AnsiResult), nil); + SetLength(AnsiResult, Len); + Result := AnsiResult; + end; + if Trim(Result) = '' then + Result := WideFormat('Unspecified error (%d) from %s.', [ErrorCode, LibName]); +end; + +{$IFNDEF COMPILER_7_UP} +function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; +begin + Result := (Win32MajorVersion > AMajor) or + ((Win32MajorVersion = AMajor) and + (Win32MinorVersion >= AMinor)); +end; +{$ENDIF} + +function WinCheckH(RetVal: Cardinal): Cardinal; +begin + if RetVal = 0 then RaiseLastOSError; + Result := RetVal; +end; + +function WinCheckFileH(RetVal: Cardinal): Cardinal; +begin + if RetVal = INVALID_HANDLE_VALUE then RaiseLastOSError; + Result := RetVal; +end; + +function WinCheckP(RetVal: Pointer): Pointer; +begin + if RetVal = nil then RaiseLastOSError; + Result := RetVal; +end; + +function WideGetModuleFileName(Instance: HModule): WideString; +begin + SetLength(Result, MAX_PATH); + WinCheckH(Tnt_GetModuleFileNameW(Instance, PWideChar(Result), Length(Result))); + Result := PWideChar(Result) +end; + +function WideSafeLoadLibrary(const Filename: Widestring; ErrorMode: UINT): HMODULE; +var + OldMode: UINT; + FPUControlWord: Word; +begin + OldMode := SetErrorMode(ErrorMode); + try + asm + FNSTCW FPUControlWord + end; + try + Result := Tnt_LoadLibraryW(PWideChar(Filename)); + finally + asm + FNCLEX + FLDCW FPUControlWord + end; + end; + finally + SetErrorMode(OldMode); + end; +end; + +{$IFNDEF FPC} +function WideLoadPackage(const Name: Widestring): HMODULE; +begin + Result := WideSafeLoadLibrary(Name); + if Result = 0 then + begin + raise EPackageError.CreateFmt(sErrorLoadingPackage, [Name, WideSysErrorMessage(GetLastError)]); + end; + try + InitializePackage(Result); + except + FreeLibrary(Result); + raise; + end; +end; +{$ENDIF} + +function _WideCharType(WC: WideChar; dwInfoType: Cardinal): Word; +begin + Win32Check(Tnt_GetStringTypeExW(GetThreadLocale, dwInfoType, PWideChar(@WC), 1, Result)) +end; + +function IsWideCharUpper(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_UPPER) <> 0; +end; + +function IsWideCharLower(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_LOWER) <> 0; +end; + +function IsWideCharDigit(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_DIGIT) <> 0; +end; + +function IsWideCharSpace(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_SPACE) <> 0; +end; + +function IsWideCharPunct(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_PUNCT) <> 0; +end; + +function IsWideCharCntrl(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_CNTRL) <> 0; +end; + +function IsWideCharBlank(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_BLANK) <> 0; +end; + +function IsWideCharXDigit(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_XDIGIT) <> 0; +end; + +function IsWideCharAlpha(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_ALPHA) <> 0; +end; + +function IsWideCharAlphaNumeric(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and (C1_ALPHA + C1_DIGIT)) <> 0; +end; + +function WideTextPos(const SubStr, S: WideString): Integer; +begin + Result := Pos(Tnt_WideUpperCase(SubStr), Tnt_WideUpperCase(S)); +end; + +function FindDoubleTerminator(P: PWideChar): PWideChar; +begin + Result := P; + while True do begin + Result := WStrScan(Result, #0); + Inc(Result); + if Result^ = #0 then begin + Dec(Result); + break; + end; + end; +end; + +function ExtractStringArrayStr(P: PWideChar): WideString; +var + PEnd: PWideChar; +begin + PEnd := FindDoubleTerminator(P); + Inc(PEnd, 2); // move past #0#0 + SetString(Result, P, PEnd - P); +end; + +function ExtractStringFromStringArray(var P: PWideChar; Separator: WideChar = #0): WideString; +var + Start: PWideChar; +begin + Start := P; + P := WStrScan(Start, Separator); + if P = nil then begin + Result := Start; + P := WStrEnd(Start); + end else begin + SetString(Result, Start, P - Start); + Inc(P); + end; +end; + +function ExtractStringsFromStringArray(P: PWideChar; Separator: WideChar = #0): TWideStringDynArray; +const + GROW_COUNT = 256; +var + Count: Integer; + Item: WideString; +begin + Count := 0; + SetLength(Result, GROW_COUNT); + Item := ExtractStringFromStringArray(P, Separator); + While Item <> '' do begin + if Count > High(Result) then + SetLength(Result, Length(Result) + GROW_COUNT); + Result[Count] := Item; + Inc(Count); + Item := ExtractStringFromStringArray(P, Separator); + end; + SetLength(Result, Count); +end; + +function IsWideCharMappableToAnsi(const WC: WideChar): Boolean; +var + UsedDefaultChar: BOOL; +begin + WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(@WC), 1, nil, 0, nil, @UsedDefaultChar); + Result := not UsedDefaultChar; +end; + +function IsWideStringMappableToAnsi(const WS: WideString): Boolean; +var + UsedDefaultChar: BOOL; +begin + WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(WS), Length(WS), nil, 0, nil, @UsedDefaultChar); + Result := not UsedDefaultChar; +end; + +function IsRTF(const Value: WideString): Boolean; +const + RTF_BEGIN_1 = WideString('{\RTF'); + RTF_BEGIN_2 = WideString('{URTF'); +begin + Result := (WideTextPos(RTF_BEGIN_1, Value) = 1) + or (WideTextPos(RTF_BEGIN_2, Value) = 1); +end; + +{$IFDEF COMPILER_7_UP} +var + Cached_ENG_US_FormatSettings: TFormatSettings; + Cached_ENG_US_FormatSettings_Time: Cardinal; + +function ENG_US_FormatSettings: TFormatSettings; +begin + if Cached_ENG_US_FormatSettings_Time = _SettingChangeTime then + Result := Cached_ENG_US_FormatSettings + else begin + GetLocaleFormatSettings(MAKELCID(MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_US)), Result); + Result.DecimalSeparator := '.'; // ignore overrides + Cached_ENG_US_FormatSettings := Result; + Cached_ENG_US_FormatSettings_Time := _SettingChangeTime; + end; + end; + +function ENG_US_FloatToStr(Value: Extended): WideString; +begin + Result := FloatToStr(Value, ENG_US_FormatSettings); +end; + +function ENG_US_StrToFloat(const S: WideString): Extended; +begin + if not TextToFloat(PAnsiChar(AnsiString(S)), Result, fvExtended, ENG_US_FormatSettings) then + Result := StrToFloat(S); // try using native format +end; + +{$ELSE} + +function ENG_US_FloatToStr(Value: Extended): WideString; +var + SaveDecimalSep: AnsiChar; +begin + SaveDecimalSep := SysUtils.DecimalSeparator; + try + SysUtils.DecimalSeparator := '.'; + Result := FloatToStr(Value); + finally + SysUtils.DecimalSeparator := SaveDecimalSep; + end; +end; + +function ENG_US_StrToFloat(const S: WideString): Extended; +var + SaveDecimalSep: AnsiChar; +begin + try + SaveDecimalSep := SysUtils.DecimalSeparator; + try + SysUtils.DecimalSeparator := '.'; + Result := StrToFloat(S); + finally + SysUtils.DecimalSeparator := SaveDecimalSep; + end; + except + if SysUtils.DecimalSeparator <> '.' then + Result := StrToFloat(S) // try using native format + else + raise; + end; +end; +{$ENDIF} + +//--------------------------------------------------------------------------------------------- +// Tnt - Variants +//--------------------------------------------------------------------------------------------- + +initialization + Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT); + Win32PlatformIsXP := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) + or (Win32MajorVersion > 5); + Win32PlatformIs2003 := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 2)) + or (Win32MajorVersion > 5); + Win32PlatformIsVista := (Win32MajorVersion >= 6); + +finalization + Currency_DecimalSep := ''; {make memory sleuth happy} + Currency_ThousandSep := ''; {make memory sleuth happy} + Currency_CurrencySymbol := ''; {make memory sleuth happy} + +end. diff --git a/cmake/src/lib/TntUnicodeControls/TntSystem.pas b/cmake/src/lib/TntUnicodeControls/TntSystem.pas new file mode 100644 index 00000000..e613ce0c --- /dev/null +++ b/cmake/src/lib/TntUnicodeControls/TntSystem.pas @@ -0,0 +1,1427 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntSystem; + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$INCLUDE TntCompilers.inc} + +{*****************************************************************************} +{ Special thanks go to Francisco Leong for originating the design for } +{ WideString-enabled resourcestrings. } +{*****************************************************************************} + +interface + +uses + Windows; + +// These functions should not be used by Delphi code since conversions are implicit. +{TNT-WARN WideCharToString} +{TNT-WARN WideCharLenToString} +{TNT-WARN WideCharToStrVar} +{TNT-WARN WideCharLenToStrVar} +{TNT-WARN StringToWideChar} + +// ................ ANSI TYPES ................ +{TNT-WARN Char} +{TNT-WARN PChar} +{TNT-WARN String} + +{TNT-WARN CP_ACP} // <-- use DefaultSystemCodePage +function DefaultSystemCodePage: Cardinal; // implicitly used when converting AnsiString <--> WideString. + +{$IFNDEF FPC} +var + WideCustomLoadResString: function(ResStringRec: PResStringRec; var Value: WideString): Boolean; +{$ENDIF} + +{TNT-WARN LoadResString} +function WideLoadResString(ResStringRec: PResStringRec): WideString; +{TNT-WARN ParamCount} +function WideParamCount: Integer; +{TNT-WARN ParamStr} +function WideParamStr(Index: Integer): WideString; + +// ......... introduced ......... + +const + { Each Unicode stream should begin with the code U+FEFF, } + { which the standard defines as the *byte order mark*. } + UNICODE_BOM = WideChar($FEFF); + UNICODE_BOM_SWAPPED = WideChar($FFFE); + UTF8_BOM = AnsiString(#$EF#$BB#$BF); + +function WideStringToUTF8(const S: WideString): AnsiString; +function UTF8ToWideString(const S: AnsiString): WideString; + +function WideStringToUTF7(const W: WideString): AnsiString; +function UTF7ToWideString(const S: AnsiString): WideString; + +function StringToWideStringEx(const S: AnsiString; CodePage: Cardinal): WideString; +function WideStringToStringEx(const WS: WideString; CodePage: Cardinal): AnsiString; + +function UCS2ToWideString(const Value: AnsiString): WideString; +function WideStringToUCS2(const Value: WideString): AnsiString; + +function CharSetToCodePage(ciCharset: UINT): Cardinal; +function LCIDToCodePage(ALcid: LCID): Cardinal; +function KeyboardCodePage: Cardinal; +function KeyUnicode(CharCode: Word): WideChar; + +procedure StrSwapByteOrder(Str: PWideChar); + +{$IFDEF USE_SYSTEM_OVERRIDES} + +type + TTntSystemUpdate = + (tsWideResourceStrings + {$IFNDEF COMPILER_9_UP}, tsFixImplicitCodePage, tsFixWideStrConcat, tsFixWideFormat {$ENDIF} + ); + TTntSystemUpdateSet = set of TTntSystemUpdate; + +const + AllTntSystemUpdates = [Low(TTntSystemUpdate)..High(TTntSystemUpdate)]; + +procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates); + +{$ENDIF USE_SYSTEM_OVERRIDES} + +implementation + +uses + SysUtils, Variants, TntWindows, TntSysUtils; + +var + GDefaultSystemCodePage: Cardinal; + +function DefaultSystemCodePage: Cardinal; +begin + Result := GDefaultSystemCodePage; +end; + +{$IFDEF USE_SYSTEM_OVERRIDES} +var + IsDebugging: Boolean; +{$ENDIF USE_SYSTEM_OVERRIDES} + +function WideLoadResStringDetect(ResStringRec: PResStringRec): WideString; +var + PCustom: PAnsiChar; +begin + // custom string pointer + PCustom := PAnsiChar(ResStringRec); { I would like to use PWideChar, but this would break legacy code. } + if (StrLen{TNT-ALLOW StrLen}(PCustom) > Cardinal(Length(UTF8_BOM))) + and CompareMem(PCustom, PAnsiChar(UTF8_BOM), Length(UTF8_BOM)) then + // detected UTF8 + Result := UTF8ToWideString(PAnsiChar(PCustom + Length(UTF8_BOM))) + else + // normal + Result := PCustom; +end; + +{$IFNDEF FPC} + +function WideLoadResString(ResStringRec: PResStringRec): WideString; +const + MAX_RES_STRING_SIZE = 4097; { MSDN documents this as the maximum size of a string in table. } +var + Buffer: array [0..MAX_RES_STRING_SIZE] of WideChar; { Buffer leaves room for null terminator. } +begin + if Assigned(WideCustomLoadResString) and WideCustomLoadResString(ResStringRec, Result) then + exit; { a custom resourcestring has been loaded. } + + if ResStringRec = nil then + Result := '' + else if ResStringRec.Identifier < 64*1024 then + SetString(Result, Buffer, + Tnt_LoadStringW(FindResourceHInstance(ResStringRec.Module^), + ResStringRec.Identifier, Buffer, MAX_RES_STRING_SIZE)) + else begin + Result := WideLoadResStringDetect(ResStringRec); + end; +end; + +{$ELSE} + +function WideLoadResString(ResStringRec: PResStringRec): WideString; +begin + Result := WideLoadResStringDetect(ResStringRec); +end; + +{$ENDIF} + +function WideGetParamStr(P: PWideChar; var Param: WideString): PWideChar; +var + i, Len: Integer; + Start, S, Q: PWideChar; +begin + while True do + begin + while (P[0] <> #0) and (P[0] <= ' ') do + Inc(P); + if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break; + end; + Len := 0; + Start := P; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + Inc(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := P + 1; + Inc(Len, Q - P); + P := Q; + end; + if P[0] <> #0 then + Inc(P); + end + else + begin + Q := P + 1; + Inc(Len, Q - P); + P := Q; + end; + end; + + SetLength(Param, Len); + + P := Start; + S := PWideChar(Param); + i := 0; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + Inc(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := P + 1; + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + if P[0] <> #0 then Inc(P); + end + else + begin + Q := P + 1; + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + end; + + Result := P; +end; + +function WideParamCount: Integer; +var + P: PWideChar; + S: WideString; +begin + P := WideGetParamStr(GetCommandLineW, S); + Result := 0; + while True do + begin + P := WideGetParamStr(P, S); + if S = '' then Break; + Inc(Result); + end; +end; + +function WideParamStr(Index: Integer): WideString; +var + P: PWideChar; +begin + if Index = 0 then + Result := WideGetModuleFileName(0) + else + begin + P := GetCommandLineW; + while True do + begin + P := WideGetParamStr(P, Result); + if (Index = 0) or (Result = '') then Break; + Dec(Index); + end; + end; +end; + +function WideStringToUTF8(const S: WideString): AnsiString; +begin + Result := UTF8Encode(S); +end; + +function UTF8ToWideString(const S: AnsiString): WideString; +begin + Result := UTF8Decode(S); +end; + + { ======================================================================= } + { Original File: ConvertUTF7.c } + { Author: David B. Goldsmith } + { Copyright (C) 1994, 1996 Taligent, Inc. All rights reserved. } + { } + { This code is copyrighted. Under the copyright laws, this code may not } + { be copied, in whole or part, without prior written consent of Taligent. } + { } + { Taligent grants the right to use this code as long as this ENTIRE } + { copyright notice is reproduced in the code. The code is provided } + { AS-IS, AND TALIGENT DISCLAIMS ALL WARRANTIES, EITHER EXPRESS OR } + { IMPLIED, INCLUDING, BUT NOT LIMITED TO IMPLIED WARRANTIES OF } + { MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT } + { WILL TALIGENT BE LIABLE FOR ANY DAMAGES WHATSOEVER (INCLUDING, } + { WITHOUT LIMITATION, DAMAGES FOR LOSS OF BUSINESS PROFITS, BUSINESS } + { INTERRUPTION, LOSS OF BUSINESS INFORMATION, OR OTHER PECUNIARY } + { LOSS) ARISING OUT OF THE USE OR INABILITY TO USE THIS CODE, EVEN } + { IF TALIGENT HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. } + { BECAUSE SOME STATES DO NOT ALLOW THE EXCLUSION OR LIMITATION OF } + { LIABILITY FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES, THE ABOVE } + { LIMITATION MAY NOT APPLY TO YOU. } + { } + { RESTRICTED RIGHTS LEGEND: Use, duplication, or disclosure by the } + { government is subject to restrictions as set forth in subparagraph } + { (c)(l)(ii) of the Rights in Technical Data and Computer Software } + { clause at DFARS 252.227-7013 and FAR 52.227-19. } + { } + { This code may be protected by one or more U.S. and International } + { Patents. } + { } + { TRADEMARKS: Taligent and the Taligent Design Mark are registered } + { trademarks of Taligent, Inc. } + { ======================================================================= } + +type UCS2 = Word; + +const + _base64: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; + _direct: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789''(),-./:?'; + _optional: AnsiString = '!"#$%&*;<=>@[]^_`{|}'; + _spaces: AnsiString = #9#13#10#32; + +var + base64: PAnsiChar; + invbase64: array[0..127] of SmallInt; + direct: PAnsiChar; + optional: PAnsiChar; + spaces: PAnsiChar; + mustshiftsafe: array[0..127] of AnsiChar; + mustshiftopt: array[0..127] of AnsiChar; + +var + needtables: Boolean = True; + +procedure Initialize_UTF7_Data; +begin + base64 := PAnsiChar(_base64); + direct := PAnsiChar(_direct); + optional := PAnsiChar(_optional); + spaces := PAnsiChar(_spaces); +end; + +procedure tabinit; +var + i: Integer; + limit: Integer; +begin + i := 0; + while (i < 128) do + begin + mustshiftopt[i] := #1; + mustshiftsafe[i] := #1; + invbase64[i] := -1; + Inc(i); + end { For }; + limit := Length(_Direct); + i := 0; + while (i < limit) do + begin + mustshiftopt[Integer(direct[i])] := #0; + mustshiftsafe[Integer(direct[i])] := #0; + Inc(i); + end { For }; + limit := Length(_Spaces); + i := 0; + while (i < limit) do + begin + mustshiftopt[Integer(spaces[i])] := #0; + mustshiftsafe[Integer(spaces[i])] := #0; + Inc(i); + end { For }; + limit := Length(_Optional); + i := 0; + while (i < limit) do + begin + mustshiftopt[Integer(optional[i])] := #0; + Inc(i); + end { For }; + limit := Length(_Base64); + i := 0; + while (i < limit) do + begin + invbase64[Integer(base64[i])] := i; + Inc(i); + end { For }; + needtables := False; +end; { tabinit } + +function WRITE_N_BITS(x: UCS2; n: Integer; var BITbuffer: Cardinal; var bufferbits: Integer): Integer; +begin + BITbuffer := BITbuffer or (x and (not (-1 shl n))) shl (32 - n - bufferbits); + bufferbits := bufferbits + n; + Result := bufferbits; +end; { WRITE_N_BITS } + +function READ_N_BITS(n: Integer; var BITbuffer: Cardinal; var bufferbits: Integer): UCS2; +var + buffertemp: Cardinal; +begin + buffertemp := BITbuffer shr (32 - n); + BITbuffer := BITbuffer shl n; + bufferbits := bufferbits - n; + Result := UCS2(buffertemp); +end; { READ_N_BITS } + +function ConvertUCS2toUTF7(var sourceStart: PWideChar; sourceEnd: PWideChar; + var targetStart: PAnsiChar; targetEnd: PAnsiChar; optional: Boolean; + verbose: Boolean): Integer; +var + r: UCS2; + target: PAnsiChar; + source: PWideChar; + BITbuffer: Cardinal; + bufferbits: Integer; + shifted: Boolean; + needshift: Boolean; + done: Boolean; + mustshift: PAnsiChar; +begin + Initialize_UTF7_Data; + Result := 0; + BITbuffer := 0; + bufferbits := 0; + shifted := False; + source := sourceStart; + target := targetStart; + r := 0; + if needtables then + tabinit; + if optional then + mustshift := @mustshiftopt[0] + else + mustshift := @mustshiftsafe[0]; + repeat + done := source >= sourceEnd; + if not Done then + begin + r := Word(source^); + Inc(Source); + end { If }; + needshift := (not done) and ((r > $7F) or (mustshift[r] <> #0)); + if needshift and (not shifted) then + begin + if (Target >= TargetEnd) then + begin + Result := 2; + break; + end { If }; + target^ := '+'; + Inc(target); + { Special case handling of the SHIFT_IN character } + if (r = UCS2('+')) then + begin + if (target >= targetEnd) then + begin + Result := 2; + break; + end; + target^ := '-'; + Inc(target); + end + else + shifted := True; + end { If }; + if shifted then + begin + { Either write the character to the bit buffer, or pad } + { the bit buffer out to a full base64 character. } + { } + if needshift then + WRITE_N_BITS(r, 16, BITbuffer, bufferbits) + else + WRITE_N_BITS(0, (6 - (bufferbits mod 6)) mod 6, BITbuffer, + bufferbits); + { Flush out as many full base64 characters as possible } + { from the bit buffer. } + { } + while (target < targetEnd) and (bufferbits >= 6) do + begin + Target^ := base64[READ_N_BITS(6, BITbuffer, bufferbits)]; + Inc(Target); + end { While }; + if (bufferbits >= 6) then + begin + if (target >= targetEnd) then + begin + Result := 2; + break; + end { If }; + end { If }; + if (not needshift) then + begin + { Write the explicit shift out character if } + { 1) The caller has requested we always do it, or } + { 2) The directly encoded character is in the } + { base64 set, or } + { 3) The directly encoded character is SHIFT_OUT. } + { } + if verbose or ((not done) and ((invbase64[r] >= 0) or (r = + Integer('-')))) then + begin + if (target >= targetEnd) then + begin + Result := 2; + Break; + end { If }; + Target^ := '-'; + Inc(Target); + end { If }; + shifted := False; + end { If }; + { The character can be directly encoded as ASCII. } + end { If }; + if (not needshift) and (not done) then + begin + if (target >= targetEnd) then + begin + Result := 2; + break; + end { If }; + Target^ := AnsiChar(r); + Inc(Target); + end { If }; + until (done); + sourceStart := source; + targetStart := target; +end; { ConvertUCS2toUTF7 } + +function ConvertUTF7toUCS2(var sourceStart: PAnsiChar; sourceEnd: PAnsiChar; + var targetStart: PWideChar; targetEnd: PWideChar): Integer; +var + target: PWideChar { Register }; + source: PAnsiChar { Register }; + BITbuffer: Cardinal { & "Address Of" Used }; + bufferbits: Integer { & "Address Of" Used }; + shifted: Boolean { Used In Boolean Context }; + first: Boolean { Used In Boolean Context }; + wroteone: Boolean; + base64EOF: Boolean; + base64value: Integer; + done: Boolean; + c: UCS2; + prevc: UCS2; + junk: UCS2 { Used In Boolean Context }; +begin + Initialize_UTF7_Data; + Result := 0; + BITbuffer := 0; + bufferbits := 0; + shifted := False; + first := False; + wroteone := False; + source := sourceStart; + target := targetStart; + c := 0; + if needtables then + tabinit; + repeat + { read an ASCII character c } + done := Source >= SourceEnd; + if (not done) then + begin + c := Word(Source^); + Inc(Source); + end { If }; + if shifted then + begin + { We're done with a base64 string if we hit EOF, it's not a valid } + { ASCII character, or it's not in the base64 set. } + { } + base64value := invbase64[c]; + base64EOF := (done or (c > $7F)) or (base64value < 0); + if base64EOF then + begin + shifted := False; + { If the character causing us to drop out was SHIFT_IN or } + { SHIFT_OUT, it may be a special escape for SHIFT_IN. The } + { test for SHIFT_IN is not necessary, but allows an alternate } + { form of UTF-7 where SHIFT_IN is escaped by SHIFT_IN. This } + { only works for some values of SHIFT_IN. } + { } + if ((not done) and ((c = Integer('+')) or (c = Integer('-')))) then + begin + { get another character c } + prevc := c; + Done := Source >= SourceEnd; + if (not Done) then + begin + c := Word(Source^); + Inc(Source); + { If no base64 characters were encountered, and the } + { character terminating the shift sequence was } + { SHIFT_OUT, then it's a special escape for SHIFT_IN. } + { } + end; + if first and (prevc = Integer('-')) then + begin + { write SHIFT_IN unicode } + if (target >= targetEnd) then + begin + Result := 2; + break; + end { If }; + Target^ := WideChar('+'); + Inc(Target); + end + else + begin + if (not wroteone) then + begin + Result := 1; + end { If }; + end { Else }; + ; + end { If } + else + begin + if (not wroteone) then + begin + Result := 1; + end { If }; + end { Else }; + end { If } + else + begin + { Add another 6 bits of base64 to the bit buffer. } + WRITE_N_BITS(base64value, 6, BITbuffer, + bufferbits); + first := False; + end { Else }; + { Extract as many full 16 bit characters as possible from the } + { bit buffer. } + { } + while (bufferbits >= 16) and (target < targetEnd) do + begin + { write a unicode } + Target^ := WideChar(READ_N_BITS(16, BITbuffer, bufferbits)); + Inc(Target); + wroteone := True; + end { While }; + if (bufferbits >= 16) then + begin + if (target >= targetEnd) then + begin + Result := 2; + Break; + end; + end { If }; + if (base64EOF) then + begin + junk := READ_N_BITS(bufferbits, BITbuffer, bufferbits); + if (junk <> 0) then + begin + Result := 1; + end { If }; + end { If }; + end { If }; + if (not shifted) and (not done) then + begin + if (c = Integer('+')) then + begin + shifted := True; + first := True; + wroteone := False; + end { If } + else + begin + { It must be a directly encoded character. } + if (c > $7F) then + begin + Result := 1; + end { If }; + if (target >= targetEnd) then + begin + Result := 2; + break; + end { If }; + Target^ := WideChar(c); + Inc(Target); + end { Else }; + end { If }; + until (done); + sourceStart := source; + targetStart := target; +end; { ConvertUTF7toUCS2 } + + {*****************************************************************************} + { Thanks to Francisco Leong for providing the Pascal conversion of } + { ConvertUTF7.c (by David B. Goldsmith) } + {*****************************************************************************} + +resourcestring + SBufferOverflow = 'Buffer overflow'; + SInvalidUTF7 = 'Invalid UTF7'; + +function WideStringToUTF7(const W: WideString): AnsiString; +var + SourceStart, SourceEnd: PWideChar; + TargetStart, TargetEnd: PAnsiChar; +begin + if W = '' then + Result := '' + else + begin + SetLength(Result, Length(W) * 7); // Assume worst case + SourceStart := PWideChar(@W[1]); + SourceEnd := PWideChar(@W[Length(W)]) + 1; + TargetStart := PAnsiChar(@Result[1]); + TargetEnd := PAnsiChar(@Result[Length(Result)]) + 1; + if ConvertUCS2toUTF7(SourceStart, SourceEnd, TargetStart, + TargetEnd, True, False) <> 0 + then + raise ETntInternalError.Create(SBufferOverflow); + SetLength(Result, TargetStart - PAnsiChar(@Result[1])); + end; +end; + +function UTF7ToWideString(const S: AnsiString): WideString; +var + SourceStart, SourceEnd: PAnsiChar; + TargetStart, TargetEnd: PWideChar; +begin + if (S = '') then + Result := '' + else + begin + SetLength(Result, Length(S)); // Assume Worst case + SourceStart := PAnsiChar(@S[1]); + SourceEnd := PAnsiChar(@S[Length(S)]) + 1; + TargetStart := PWideChar(@Result[1]); + TargetEnd := PWideChar(@Result[Length(Result)]) + 1; + case ConvertUTF7toUCS2(SourceStart, SourceEnd, TargetStart, + TargetEnd) of + 1: raise ETntGeneralError.Create(SInvalidUTF7); + 2: raise ETntInternalError.Create(SBufferOverflow); + end; + SetLength(Result, TargetStart - PWideChar(@Result[1])); + end; +end; + +function StringToWideStringEx(const S: AnsiString; CodePage: Cardinal): WideString; +var + InputLength, + OutputLength: Integer; +begin + if CodePage = CP_UTF7 then + Result := UTF7ToWideString(S) // CP_UTF7 not supported on Windows 95 + else if CodePage = CP_UTF8 then + Result := UTF8ToWideString(S) // CP_UTF8 not supported on Windows 95 + else begin + InputLength := Length(S); + OutputLength := MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, nil, 0); + SetLength(Result, OutputLength); + MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, PWideChar(Result), OutputLength); + end; +end; + +function WideStringToStringEx(const WS: WideString; CodePage: Cardinal): AnsiString; +var + InputLength, + OutputLength: Integer; +begin + if CodePage = CP_UTF7 then + Result := WideStringToUTF7(WS) // CP_UTF7 not supported on Windows 95 + else if CodePage = CP_UTF8 then + Result := WideStringToUTF8(WS) // CP_UTF8 not supported on Windows 95 + else begin + InputLength := Length(WS); + OutputLength := WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, nil, 0, nil, nil); + SetLength(Result, OutputLength); + WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, PAnsiChar(Result), OutputLength, nil, nil); + end; +end; + +function UCS2ToWideString(const Value: AnsiString): WideString; +begin + if Length(Value) = 0 then + Result := '' + else + SetString(Result, PWideChar(@Value[1]), Length(Value) div SizeOf(WideChar)) +end; + +function WideStringToUCS2(const Value: WideString): AnsiString; +begin + if Length(Value) = 0 then + Result := '' + else + SetString(Result, PAnsiChar(@Value[1]), Length(Value) * SizeOf(WideChar)) +end; + +{ Windows.pas doesn't declare TranslateCharsetInfo() correctly. } +function TranslateCharsetInfo(lpSrc: PDWORD; var lpCs: TCharsetInfo; dwFlags: DWORD): BOOL; stdcall; external gdi32 name 'TranslateCharsetInfo'; + +function CharSetToCodePage(ciCharset: UINT): Cardinal; +var + C: TCharsetInfo; +begin + Win32Check(TranslateCharsetInfo(PDWORD(ciCharset), C, TCI_SRCCHARSET)); + Result := C.ciACP +end; + +function LCIDToCodePage(ALcid: LCID): Cardinal; +var + Buf: array[0..6] of AnsiChar; +begin + GetLocaleInfo(ALcid, LOCALE_IDefaultAnsiCodePage, Buf, 6); + Result := StrToIntDef(Buf, GetACP); +end; + +function KeyboardCodePage: Cardinal; +begin + Result := LCIDToCodePage(GetKeyboardLayout(0) and $FFFF); +end; + +function KeyUnicode(CharCode: Word): WideChar; +var + AChar: AnsiChar; +begin + // converts the given character (as it comes with a WM_CHAR message) into its + // corresponding Unicode character depending on the active keyboard layout + if CharCode <= Word(High(AnsiChar)) then begin + AChar := AnsiChar(CharCode); + MultiByteToWideChar(KeyboardCodePage, MB_USEGLYPHCHARS, @AChar, 1, @Result, 1); + end else + Result := WideChar(CharCode); +end; + +procedure StrSwapByteOrder(Str: PWideChar); +var + P: PWord; +begin + P := PWord(Str); + While (P^ <> 0) do begin + P^ := MakeWord(HiByte(P^), LoByte(P^)); + Inc(P); + end; +end; + +{$IFDEF USE_SYSTEM_OVERRIDES} + +//-------------------------------------------------------------------- +// LoadResString() +// +// This system function is used to retrieve a resourcestring and +// return the result as an AnsiString. If we believe that the result +// is only a temporary value, and that it will be immediately +// assigned to a WideString or a Variant, then we will save the +// Unicode result as well as a reference to the original Ansi string. +// WStrFromPCharLen() or VarFromLStr() will return this saved +// Unicode string if it appears to receive the most recent result +// of LoadResString. +//-------------------------------------------------------------------- + + + //=========================================================================================== + // + // function CodeMatchesPatternForUnicode(...); + // + // GIVEN: SomeWideString := SSomeResString; { WideString := resourcestring } + // + // Delphi will compile this statement into the following: + // ------------------------------------------------- + // TempAnsiString := LoadResString(@SSomeResString); + // LINE 1: lea edx,[SomeTempAnsiString] + // LINE 2: mov eax,[@SomeResString] + // LINE 3: call LoadResString + // + // WStrFromLStr(SomeWideString, TempAnsiString); { SomeWideString := TempAnsiString } + // LINE 4: mov edx,[SomeTempAnsiString] + // LINE 5: mov/lea eax [@SomeWideString] + // LINE 6: call @WStrFromLStr + // ------------------------------------------------- + // + // The order in which the parameters are prepared for WStrFromLStr (ie LINE 4 & 5) is + // reversed when assigning a non-temporary AnsiString to a WideString. + // + // This code, for example, results in LINE 4 and LINE 5 being swapped. + // + // SomeAnsiString := SSomeResString; + // SomeWideString := SomeAnsiString; + // + // Since we know the "signature" used by the compiler, we can detect this pattern. + // If we believe it is only temporary, we can save the Unicode results for later + // retrieval from WStrFromLStr. + // + // One final note: When assigning a resourcestring to a Variant, the same patterns exist. + //=========================================================================================== + +function CodeMatchesPatternForUnicode(PLine4: PAnsiChar): Boolean; +const + SIZEOF_OPCODE = 1 {byte}; + MOV_16_OPCODE = AnsiChar($8B); { we'll assume operand size is 16 bits } + MOV_32_OPCODE = AnsiChar($B8); { we'll assume operand size is 32 bits } + LEA_OPCODE = AnsiChar($8D); { operand size can be 16 or 40 bits } + CALL_OPCODE = AnsiChar($E8); { assumed operand size is 32 bits } + BREAK_OPCODE = AnsiChar($CC); {in a breakpoint} +var + PLine1: PAnsiChar; + PLine2: PAnsiChar; + PLine3: PAnsiChar; + DataSize: Integer; // bytes in first LEA operand +begin + Result := False; + + PLine3 := PLine4 - SizeOf(CALL_OPCODE) - 4; + PLine2 := PLine3 - SizeOf(MOV_32_OPCODE) - 4; + + // figure PLine1 and operand size + DataSize := 2; { try 16 bit operand for line 1 } + PLine1 := PLine2 - DataSize - SizeOf(LEA_OPCODE); + if (PLine1^ <> LEA_OPCODE) and (not (IsDebugging and (PLine1^ = BREAK_OPCODE))) then + begin + DataSize := 5; { try 40 bit operand for line 1 } + PLine1 := PLine2 - DataSize - SizeOf(LEA_OPCODE); + end; + if (PLine1^ = LEA_OPCODE) or (IsDebugging and (PLine1^ = BREAK_OPCODE)) then + begin + if CompareMem(PLine1 + SIZEOF_OPCODE, PLine4 + SIZEOF_OPCODE, DataSize) then + begin + // After this check, it seems to match the WideString <- (temp) AnsiString pattern + Result := True; // It is probably OK. (The side effects of being wrong aren't very bad.) + end; + end; +end; + +threadvar + PLastResString: PAnsiChar; + LastResStringValue: AnsiString; + LastWideResString: WideString; + +procedure FreeTntSystemThreadVars; +begin + LastResStringValue := ''; + LastWideResString := ''; +end; + +procedure Custom_System_EndThread(ExitCode: Integer); +begin + FreeTntSystemThreadVars; + {$IFDEF COMPILER_10_UP} + if Assigned(SystemThreadEndProc) then + SystemThreadEndProc(ExitCode); + {$ENDIF} + ExitThread(ExitCode); +end; + +function Custom_System_LoadResString(ResStringRec: PResStringRec): AnsiString; +var + ReturnAddr: Pointer; +begin + // get return address + asm + PUSH ECX + MOV ECX, [EBP + 4] + MOV ReturnAddr, ECX + POP ECX + end; + // check calling code pattern + if CodeMatchesPatternForUnicode(ReturnAddr) then begin + // result will probably be assigned to an intermediate AnsiString + // on its way to either a WideString or Variant. + LastWideResString := WideLoadResString(ResStringRec); + Result := LastWideResString; + LastResStringValue := Result; + if Result = '' then + PLastResString := nil + else + PLastResString := PAnsiChar(Result); + end else begin + // result will probably be assigned to an actual AnsiString variable. + PLastResString := nil; + Result := WideLoadResString(ResStringRec); + end; +end; + +//-------------------------------------------------------------------- +// WStrFromPCharLen() +// +// This system function is used to assign an AnsiString to a WideString. +// It has been modified to assign Unicode results from LoadResString. +// Another purpose of this function is to specify the code page. +//-------------------------------------------------------------------- + +procedure Custom_System_WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..2047] of WideChar; + Local_PLastResString: Pointer; +begin + Local_PLastResString := PLastResString; + if (Local_PLastResString <> nil) + and (Local_PLastResString = Source) + and (System.Length(LastResStringValue) = Length) + and (LastResStringValue = Source) then begin + // use last unicode resource string + PLastResString := nil; { clear for further use } + Dest := LastWideResString; + end else begin + if Local_PLastResString <> nil then + PLastResString := nil; { clear for further use } + if Length <= 0 then + begin + Dest := ''; + Exit; + end; + if Length + 1 < High(Buffer) then + begin + DestLen := MultiByteToWideChar(DefaultSystemCodePage, 0, Source, Length, Buffer, + High(Buffer)); + if DestLen > 0 then + begin + SetLength(Dest, DestLen); + Move(Pointer(@Buffer[0])^, Pointer(Dest)^, DestLen * SizeOf(WideChar)); + Exit; + end; + end; + DestLen := (Length + 1); + SetLength(Dest, DestLen); // overallocate, trim later + DestLen := MultiByteToWideChar(DefaultSystemCodePage, 0, Source, Length, Pointer(Dest), + DestLen); + if DestLen < 0 then + DestLen := 0; + SetLength(Dest, DestLen); + end; +end; + +{$IFNDEF COMPILER_9_UP} + +//-------------------------------------------------------------------- +// LStrFromPWCharLen() +// +// This system function is used to assign an WideString to an AnsiString. +// It has not been modified from its original purpose other than to specify the code page. +//-------------------------------------------------------------------- + +procedure Custom_System_LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..4095] of AnsiChar; +begin + if Length <= 0 then + begin + Dest := ''; + Exit; + end; + if Length + 1 < (High(Buffer) div sizeof(WideChar)) then + begin + DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Source, + Length, Buffer, High(Buffer), + nil, nil); + if DestLen >= 0 then + begin + SetLength(Dest, DestLen); + Move(Pointer(@Buffer[0])^, PAnsiChar(Dest)^, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1) * sizeof(WideChar); + SetLength(Dest, DestLen); // overallocate, trim later + DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Source, Length, Pointer(Dest), DestLen, + nil, nil); + if DestLen < 0 then + DestLen := 0; + SetLength(Dest, DestLen); +end; + +//-------------------------------------------------------------------- +// WStrToString() +// +// This system function is used to assign an WideString to an short string. +// It has not been modified from its original purpose other than to specify the code page. +//-------------------------------------------------------------------- + +procedure Custom_System_WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer); +var + SourceLen, DestLen: Integer; + Buffer: array[0..511] of AnsiChar; +begin + if MaxLen > 255 then MaxLen := 255; + SourceLen := Length(Source); + if SourceLen >= MaxLen then SourceLen := MaxLen; + if SourceLen = 0 then + DestLen := 0 + else begin + DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Pointer(Source), SourceLen, + Buffer, SizeOf(Buffer), nil, nil); + if DestLen > MaxLen then DestLen := MaxLen; + end; + Dest^[0] := Chr(DestLen); + if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); +end; + +{$ENDIF} + +//-------------------------------------------------------------------- +// VarFromLStr() +// +// This system function is used to assign an AnsiString to a Variant. +// It has been modified to assign Unicode results from LoadResString. +//-------------------------------------------------------------------- + +procedure Custom_System_VarFromLStr(var V: TVarData; const Value: AnsiString); +const + varDeepData = $BFE8; +var + Local_PLastResString: Pointer; +begin + if (V.VType and varDeepData) <> 0 then + VarClear(PVariant(@V)^); + + Local_PLastResString := PLastResString; + if (Local_PLastResString <> nil) + and (Local_PLastResString = PAnsiChar(Value)) + and (LastResStringValue = Value) then begin + // use last unicode resource string + PLastResString := nil; { clear for further use } + V.VOleStr := nil; + V.VType := varOleStr; + WideString(Pointer(V.VOleStr)) := Copy(LastWideResString, 1, MaxInt); + end else begin + if Local_PLastResString <> nil then + PLastResString := nil; { clear for further use } + V.VString := nil; + V.VType := varString; + AnsiString(V.VString) := Value; + end; +end; + +{$IFNDEF COMPILER_9_UP} + +//-------------------------------------------------------------------- +// WStrCat3() A := B + C; +// +// This system function is used to concatenate two strings into one result. +// This function is added because A := '' + '' doesn't necessarily result in A = ''; +//-------------------------------------------------------------------- + +procedure Custom_System_WStrCat3(var Dest: WideString; const Source1, Source2: WideString); + + function NewWideString(CharLength: Longint): Pointer; + var + _NewWideString: function(CharLength: Longint): Pointer; + begin + asm + PUSH ECX + MOV ECX, offset System.@NewWideString; + MOV _NewWideString, ECX + POP ECX + end; + Result := _NewWideString(CharLength); + end; + + procedure WStrSet(var S: WideString; P: PWideChar); + var + Temp: Pointer; + begin + Temp := Pointer(InterlockedExchange(Integer(S), Integer(P))); + if Temp <> nil then + WideString(Temp) := ''; + end; + +var + Source1Len, Source2Len: Integer; + NewStr: PWideChar; +begin + Source1Len := Length(Source1); + Source2Len := Length(Source2); + if (Source1Len <> 0) or (Source2Len <> 0) then + begin + NewStr := NewWideString(Source1Len + Source2Len); + Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * sizeof(WideChar)); + Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end else + Dest := ''; +end; + +{$ENDIF} + +//-------------------------------------------------------------------- +// System proc replacements +//-------------------------------------------------------------------- + +type + POverwrittenData = ^TOverwrittenData; + TOverwrittenData = record + Location: Pointer; + OldCode: array[0..6] of Byte; + end; + +procedure OverwriteProcedure(OldProcedure, NewProcedure: pointer; Data: POverwrittenData = nil); +{ OverwriteProcedure originally from Igor Siticov } +{ Modified by Jacques Garcia Vazquez } +var + x: PAnsiChar; + y: integer; + ov2, ov: cardinal; + p: pointer; +begin + if Assigned(Data) and (Data.Location <> nil) then + exit; { procedure already overwritten } + + // need six bytes in place of 5 + x := PAnsiChar(OldProcedure); + if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov) then + RaiseLastOSError; + + // if a jump is present then a redirect is found + // $FF25 = jmp dword ptr [xxx] + // This redirect is normally present in bpl files, but not in exe files + p := OldProcedure; + + if Word(p^) = $25FF then + begin + Inc(Integer(p), 2); // skip the jump + // get the jump address p^ and dereference it p^^ + p := Pointer(Pointer(p^)^); + + // release the memory + if not VirtualProtect(Pointer(x), 6, ov, @ov2) then + RaiseLastOSError; + + // re protect the correct one + x := PAnsiChar(p); + if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov) then + RaiseLastOSError; + end; + + if Assigned(Data) then + begin + Move(x^, Data.OldCode, 6); + { Assign Location last so that Location <> nil only if OldCode is properly initialized. } + Data.Location := x; + end; + + x[0] := AnsiChar($E9); + y := integer(NewProcedure) - integer(p) - 5; + x[1] := AnsiChar(y and 255); + x[2] := AnsiChar((y shr 8) and 255); + x[3] := AnsiChar((y shr 16) and 255); + x[4] := AnsiChar((y shr 24) and 255); + + if not VirtualProtect(Pointer(x), 6, ov, @ov2) then + RaiseLastOSError; +end; + +procedure RestoreProcedure(OriginalProc: Pointer; Data: TOverwrittenData); +var + ov, ov2: Cardinal; +begin + if Data.Location <> nil then begin + if not VirtualProtect(Data.Location, 6, PAGE_EXECUTE_READWRITE, @ov) then + RaiseLastOSError; + Move(Data.OldCode, Data.Location^, 6); + if not VirtualProtect(Data.Location, 6, ov, @ov2) then + RaiseLastOSError; + end; +end; + +function Addr_System_EndThread: Pointer; +begin + Result := @System.EndThread; +end; + +function Addr_System_LoadResString: Pointer; +begin + Result := @System.LoadResString{TNT-ALLOW LoadResString}; +end; + +function Addr_System_WStrFromPCharLen: Pointer; +asm + mov eax, offset System.@WStrFromPCharLen; +end; + +{$IFNDEF COMPILER_9_UP} +function Addr_System_LStrFromPWCharLen: Pointer; +asm + mov eax, offset System.@LStrFromPWCharLen; +end; + +function Addr_System_WStrToString: Pointer; +asm + mov eax, offset System.@WStrToString; +end; +{$ENDIF} + +function Addr_System_VarFromLStr: Pointer; +asm + mov eax, offset System.@VarFromLStr; +end; + +function Addr_System_WStrCat3: Pointer; +asm + mov eax, offset System.@WStrCat3; +end; + +var + System_EndThread_Code, + System_LoadResString_Code, + System_WStrFromPCharLen_Code, + {$IFNDEF COMPILER_9_UP} + System_LStrFromPWCharLen_Code, + System_WStrToString_Code, + {$ENDIF} + System_VarFromLStr_Code + {$IFNDEF COMPILER_9_UP} + , + System_WStrCat3_Code, + SysUtils_WideFmtStr_Code + {$ENDIF} + : TOverwrittenData; + +procedure InstallEndThreadOverride; +begin + OverwriteProcedure(Addr_System_EndThread, @Custom_System_EndThread, @System_EndThread_Code); +end; + +procedure InstallStringConversionOverrides; +begin + OverwriteProcedure(Addr_System_WStrFromPCharLen, @Custom_System_WStrFromPCharLen, @System_WStrFromPCharLen_Code); + {$IFNDEF COMPILER_9_UP} + OverwriteProcedure(Addr_System_LStrFromPWCharLen, @Custom_System_LStrFromPWCharLen, @System_LStrFromPWCharLen_Code); + OverwriteProcedure(Addr_System_WStrToString, @Custom_System_WStrToString, @System_WStrToString_Code); + {$ENDIF} +end; + +procedure InstallWideResourceStrings; +begin + OverwriteProcedure(Addr_System_LoadResString, @Custom_System_LoadResString, @System_LoadResString_Code); + OverwriteProcedure(Addr_System_VarFromLStr, @Custom_System_VarFromLStr, @System_VarFromLStr_Code); +end; + +{$IFNDEF COMPILER_9_UP} +procedure InstallWideStringConcatenationFix; +begin + OverwriteProcedure(Addr_System_WStrCat3, @Custom_System_WStrCat3, @System_WStrCat3_Code); +end; + +procedure InstallWideFormatFixes; +begin + OverwriteProcedure(@SysUtils.WideFmtStr, @TntSysUtils.Tnt_WideFmtStr, @SysUtils_WideFmtStr_Code); +end; +{$ENDIF} + +procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates); +begin + InstallEndThreadOverride; + if tsWideResourceStrings in Updates then begin + InstallStringConversionOverrides; + InstallWideResourceStrings; + end; + {$IFNDEF COMPILER_9_UP} + if tsFixImplicitCodePage in Updates then begin + InstallStringConversionOverrides; + { CP_ACP is the code page used by the non-Unicode Windows API. } + GDefaultSystemCodePage := CP_ACP{TNT-ALLOW CP_ACP}; + end; + if tsFixWideStrConcat in Updates then begin + InstallWideStringConcatenationFix; + end; + if tsFixWideFormat in Updates then begin + InstallWideFormatFixes; + end; + {$ENDIF} +end; + +{$IFNDEF COMPILER_9_UP} +var + StartupDefaultUserCodePage: Cardinal; +{$ENDIF} + +procedure UninstallSystemOverrides; +begin + RestoreProcedure(Addr_System_EndThread, System_EndThread_Code); + // String Conversion + RestoreProcedure(Addr_System_WStrFromPCharLen, System_WStrFromPCharLen_Code); + {$IFNDEF COMPILER_9_UP} + RestoreProcedure(Addr_System_LStrFromPWCharLen, System_LStrFromPWCharLen_Code); + RestoreProcedure(Addr_System_WStrToString, System_WStrToString_Code); + GDefaultSystemCodePage := StartupDefaultUserCodePage; + {$ENDIF} + // Wide resourcestring + RestoreProcedure(Addr_System_LoadResString, System_LoadResString_Code); + RestoreProcedure(Addr_System_VarFromLStr, System_VarFromLStr_Code); + {$IFNDEF COMPILER_9_UP} + // WideString concat fix + RestoreProcedure(Addr_System_WStrCat3, System_WStrCat3_Code); + // WideFormat fixes + RestoreProcedure(@SysUtils.WideFmtStr, SysUtils_WideFmtStr_Code); + {$ENDIF} +end; + +{$ENDIF USE_SYSTEM_OVERRIDES} + +initialization + {$IFDEF COMPILER_9_UP} + {$DEFINE USE_GETACP} + {$ENDIF} + {$IFDEF FPC} + {$DEFINE USE_GETACP} + {$ENDIF} + {$IFDEF USE_GETACP} + GDefaultSystemCodePage := GetACP; + {$ELSE} + {$IFDEF COMPILER_7_UP} + if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5) then + GDefaultSystemCodePage := CP_THREAD_ACP // Win 2K/XP/... + else + GDefaultSystemCodePage := LCIDToCodePage(GetThreadLocale); // Win NT4/95/98/ME + {$ELSE} + GDefaultSystemCodePage := CP_ACP{TNT-ALLOW CP_ACP}; + {$ENDIF} + {$ENDIF} + {$IFDEF USE_SYSTEM_OVERRIDES} + {$IFNDEF COMPILER_9_UP} + StartupDefaultUserCodePage := DefaultSystemCodePage; + {$ENDIF} + IsDebugging := DebugHook > 0; + {$ENDIF USE_SYSTEM_OVERRIDES} + +finalization + {$IFDEF USE_SYSTEM_OVERRIDES} + UninstallSystemOverrides; + FreeTntSystemThreadVars; { Make MemorySleuth happy. } + {$ENDIF USE_SYSTEM_OVERRIDES} + +end. diff --git a/cmake/src/lib/TntUnicodeControls/TntWideStrUtils.pas b/cmake/src/lib/TntUnicodeControls/TntWideStrUtils.pas new file mode 100644 index 00000000..99f63aea --- /dev/null +++ b/cmake/src/lib/TntUnicodeControls/TntWideStrUtils.pas @@ -0,0 +1,455 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntWideStrUtils; + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$INCLUDE TntCompilers.inc} + +interface + +{ Wide string manipulation functions } + +{$IFNDEF COMPILER_9_UP} +function WStrAlloc(Size: Cardinal): PWideChar; +function WStrBufSize(const Str: PWideChar): Cardinal; +{$ENDIF} +{$IFNDEF COMPILER_10_UP} +function WStrMove(Dest: PWideChar; const Source: PWideChar; Count: Cardinal): PWideChar; +{$ENDIF} +{$IFNDEF COMPILER_9_UP} +function WStrNew(const Str: PWideChar): PWideChar; +procedure WStrDispose(Str: PWideChar); +{$ENDIF} +//--------------------------------------------------------------------------------------------- +{$IFNDEF COMPILER_9_UP} +function WStrLen(Str: PWideChar): Cardinal; +function WStrEnd(Str: PWideChar): PWideChar; +{$ENDIF} +{$IFNDEF COMPILER_10_UP} +function WStrCat(Dest: PWideChar; const Source: PWideChar): PWideChar; +{$ENDIF} +{$IFNDEF COMPILER_9_UP} +function WStrCopy(Dest, Source: PWideChar): PWideChar; +function WStrLCopy(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar; +function WStrPCopy(Dest: PWideChar; const Source: WideString): PWideChar; +function WStrPLCopy(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar; +{$ENDIF} +{$IFNDEF COMPILER_10_UP} +function WStrScan(const Str: PWideChar; Chr: WideChar): PWideChar; +// WStrComp and WStrPos were introduced as broken in Delphi 2006, but fixed in Delphi 2006 Update 2 +function WStrComp(Str1, Str2: PWideChar): Integer; +function WStrPos(Str, SubStr: PWideChar): PWideChar; +{$ENDIF} +function Tnt_WStrComp(Str1, Str2: PWideChar): Integer; deprecated; +function Tnt_WStrPos(Str, SubStr: PWideChar): PWideChar; deprecated; + +{ ------------ introduced --------------- } +function WStrECopy(Dest, Source: PWideChar): PWideChar; +function WStrLComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; +function WStrLIComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; +function WStrIComp(Str1, Str2: PWideChar): Integer; +function WStrLower(Str: PWideChar): PWideChar; +function WStrUpper(Str: PWideChar): PWideChar; +function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar; +function WStrLCat(Dest: PWideChar; const Source: PWideChar; MaxLen: Cardinal): PWideChar; +function WStrPas(const Str: PWideChar): WideString; + +{ SysUtils.pas } //------------------------------------------------------------------------- + +{$IFNDEF COMPILER_10_UP} +function WideLastChar(const S: WideString): PWideChar; +function WideQuotedStr(const S: WideString; Quote: WideChar): WideString; +{$ENDIF} +{$IFNDEF COMPILER_9_UP} +function WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): Widestring; +{$ENDIF} +{$IFNDEF COMPILER_10_UP} +function WideDequotedStr(const S: WideString; AQuote: WideChar): WideString; +{$ENDIF} + +implementation + +uses + {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} Math, Windows, TntWindows; + +{$IFNDEF COMPILER_9_UP} +function WStrAlloc(Size: Cardinal): PWideChar; +begin + Size := SizeOf(Cardinal) + (Size * SizeOf(WideChar)); + GetMem(Result, Size); + PCardinal(Result)^ := Size; + Inc(PAnsiChar(Result), SizeOf(Cardinal)); +end; + +function WStrBufSize(const Str: PWideChar): Cardinal; +var + P: PWideChar; +begin + P := Str; + Dec(PAnsiChar(P), SizeOf(Cardinal)); + Result := PCardinal(P)^ - SizeOf(Cardinal); + Result := Result div SizeOf(WideChar); +end; +{$ENDIF} + +{$IFNDEF COMPILER_10_UP} +function WStrMove(Dest: PWideChar; const Source: PWideChar; Count: Cardinal): PWideChar; +var + Length: Integer; +begin + Result := Dest; + Length := Count * SizeOf(WideChar); + Move(Source^, Dest^, Length); +end; +{$ENDIF} + +{$IFNDEF COMPILER_9_UP} +function WStrNew(const Str: PWideChar): PWideChar; +var + Size: Cardinal; +begin + if Str = nil then Result := nil else + begin + Size := WStrLen(Str) + 1; + Result := WStrMove(WStrAlloc(Size), Str, Size); + end; +end; + +procedure WStrDispose(Str: PWideChar); +begin + if Str <> nil then + begin + Dec(PAnsiChar(Str), SizeOf(Cardinal)); + FreeMem(Str, Cardinal(Pointer(Str)^)); + end; +end; +{$ENDIF} + +//--------------------------------------------------------------------------------------------- + +{$IFNDEF COMPILER_9_UP} +function WStrLen(Str: PWideChar): Cardinal; +begin + Result := WStrEnd(Str) - Str; +end; + +function WStrEnd(Str: PWideChar): PWideChar; +begin + // returns a pointer to the end of a null terminated string + Result := Str; + While Result^ <> #0 do + Inc(Result); +end; +{$ENDIF} + +{$IFNDEF COMPILER_10_UP} +function WStrCat(Dest: PWideChar; const Source: PWideChar): PWideChar; +begin + Result := Dest; + WStrCopy(WStrEnd(Dest), Source); +end; +{$ENDIF} + +{$IFNDEF COMPILER_9_UP} +function WStrCopy(Dest, Source: PWideChar): PWideChar; +begin + Result := WStrLCopy(Dest, Source, MaxInt); +end; + +function WStrLCopy(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar; +var + Count: Cardinal; +begin + // copies a specified maximum number of characters from Source to Dest + Result := Dest; + Count := 0; + While (Count < MaxLen) and (Source^ <> #0) do begin + Dest^ := Source^; + Inc(Source); + Inc(Dest); + Inc(Count); + end; + Dest^ := #0; +end; + +function WStrPCopy(Dest: PWideChar; const Source: WideString): PWideChar; +begin + Result := WStrLCopy(Dest, PWideChar(Source), Length(Source)); +end; + +function WStrPLCopy(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar; +begin + Result := WStrLCopy(Dest, PWideChar(Source), MaxLen); +end; +{$ENDIF} + +{$IFNDEF COMPILER_10_UP} +function WStrScan(const Str: PWideChar; Chr: WideChar): PWideChar; +begin + Result := Str; + while Result^ <> Chr do + begin + if Result^ = #0 then + begin + Result := nil; + Exit; + end; + Inc(Result); + end; +end; + +function WStrComp(Str1, Str2: PWideChar): Integer; +begin + Result := WStrLComp(Str1, Str2, MaxInt); +end; + +function WStrPos(Str, SubStr: PWideChar): PWideChar; +var + PSave: PWideChar; + P: PWideChar; + PSub: PWideChar; +begin + // returns a pointer to the first occurance of SubStr in Str + Result := nil; + if (Str <> nil) and (Str^ <> #0) and (SubStr <> nil) and (SubStr^ <> #0) then begin + P := Str; + While P^ <> #0 do begin + if P^ = SubStr^ then begin + // investigate possibility here + PSave := P; + PSub := SubStr; + While (P^ = PSub^) do begin + Inc(P); + Inc(PSub); + if (PSub^ = #0) then begin + Result := PSave; + exit; // found a match + end; + if (P^ = #0) then + exit; // no match, hit end of string + end; + P := PSave; + end; + Inc(P); + end; + end; +end; +{$ENDIF} + +function Tnt_WStrComp(Str1, Str2: PWideChar): Integer; deprecated; +begin + Result := WStrComp(Str1, Str2); +end; + +function Tnt_WStrPos(Str, SubStr: PWideChar): PWideChar; deprecated; +begin + Result := WStrPos(Str, SubStr); +end; + +//------------------------------------------------------------------------------ + +function WStrECopy(Dest, Source: PWideChar): PWideChar; +begin + Result := WStrEnd(WStrCopy(Dest, Source)); +end; + +function WStrComp_EX(Str1, Str2: PWideChar; MaxLen: Cardinal; dwCmpFlags: Cardinal): Integer; +var + Len1, Len2: Integer; +begin + if MaxLen = Cardinal(MaxInt) then begin + Len1 := -1; + Len2 := -1; + end else begin + Len1 := Min(WStrLen(Str1), MaxLen); + Len2 := Min(WStrLen(Str2), MaxLen); + end; + Result := Tnt_CompareStringW(GetThreadLocale, dwCmpFlags, Str1, Len1, Str2, Len2) - 2; +end; + +function WStrLComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; +begin + Result := WStrComp_EX(Str1, Str2, MaxLen, 0); +end; + +function WStrLIComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; +begin + Result := WStrComp_EX(Str1, Str2, MaxLen, NORM_IGNORECASE); +end; + +function WStrIComp(Str1, Str2: PWideChar): Integer; +begin + Result := WStrLIComp(Str1, Str2, MaxInt); +end; + +function WStrLower(Str: PWideChar): PWideChar; +begin + Result := Str; + Tnt_CharLowerBuffW(Str, WStrLen(Str)) +end; + +function WStrUpper(Str: PWideChar): PWideChar; +begin + Result := Str; + Tnt_CharUpperBuffW(Str, WStrLen(Str)) +end; + +function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar; +var + MostRecentFound: PWideChar; +begin + if Chr = #0 then + Result := WStrEnd(Str) + else + begin + Result := nil; + MostRecentFound := Str; + while True do + begin + while MostRecentFound^ <> Chr do + begin + if MostRecentFound^ = #0 then + Exit; + Inc(MostRecentFound); + end; + Result := MostRecentFound; + Inc(MostRecentFound); + end; + end; +end; + +function WStrLCat(Dest: PWideChar; const Source: PWideChar; MaxLen: Cardinal): PWideChar; +begin + Result := Dest; + WStrLCopy(WStrEnd(Dest), Source, MaxLen - WStrLen(Dest)); +end; + +function WStrPas(const Str: PWideChar): WideString; +begin + Result := Str; +end; + +//--------------------------------------------------------------------------------------------- + +{$IFNDEF COMPILER_10_UP} +function WideLastChar(const S: WideString): PWideChar; +begin + if S = '' then + Result := nil + else + Result := @S[Length(S)]; +end; + +function WideQuotedStr(const S: WideString; Quote: WideChar): WideString; +var + P, Src, + Dest: PWideChar; + AddCount: Integer; +begin + AddCount := 0; + P := WStrScan(PWideChar(S), Quote); + while (P <> nil) do + begin + Inc(P); + Inc(AddCount); + P := WStrScan(P, Quote); + end; + + if AddCount = 0 then + Result := Quote + S + Quote + else + begin + SetLength(Result, Length(S) + AddCount + 2); + Dest := PWideChar(Result); + Dest^ := Quote; + Inc(Dest); + Src := PWideChar(S); + P := WStrScan(Src, Quote); + repeat + Inc(P); + Move(Src^, Dest^, 2 * (P - Src)); + Inc(Dest, P - Src); + Dest^ := Quote; + Inc(Dest); + Src := P; + P := WStrScan(Src, Quote); + until P = nil; + P := WStrEnd(Src); + Move(Src^, Dest^, 2 * (P - Src)); + Inc(Dest, P - Src); + Dest^ := Quote; + end; +end; +{$ENDIF} + +{$IFNDEF COMPILER_9_UP} +function WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): Widestring; +var + P, Dest: PWideChar; + DropCount: Integer; +begin + Result := ''; + if (Src = nil) or (Src^ <> Quote) then Exit; + Inc(Src); + DropCount := 1; + P := Src; + Src := WStrScan(Src, Quote); + while Src <> nil do // count adjacent pairs of quote chars + begin + Inc(Src); + if Src^ <> Quote then Break; + Inc(Src); + Inc(DropCount); + Src := WStrScan(Src, Quote); + end; + if Src = nil then Src := WStrEnd(P); + if ((Src - P) <= 1) then Exit; + if DropCount = 1 then + SetString(Result, P, Src - P - 1) + else + begin + SetLength(Result, Src - P - DropCount); + Dest := PWideChar(Result); + Src := WStrScan(P, Quote); + while Src <> nil do + begin + Inc(Src); + if Src^ <> Quote then Break; + Move(P^, Dest^, (Src - P) * SizeOf(WideChar)); + Inc(Dest, Src - P); + Inc(Src); + P := Src; + Src := WStrScan(Src, Quote); + end; + if Src = nil then Src := WStrEnd(P); + Move(P^, Dest^, (Src - P - 1) * SizeOf(WideChar)); + end; +end; +{$ENDIF} + +{$IFNDEF COMPILER_10_UP} +function WideDequotedStr(const S: WideString; AQuote: WideChar): WideString; +var + LText : PWideChar; +begin + LText := PWideChar(S); + Result := WideExtractQuotedStr(LText, AQuote); + if Result = '' then + Result := S; +end; +{$ENDIF} + + +end. diff --git a/cmake/src/lib/TntUnicodeControls/TntWideStrings.pas b/cmake/src/lib/TntUnicodeControls/TntWideStrings.pas new file mode 100644 index 00000000..75132d22 --- /dev/null +++ b/cmake/src/lib/TntUnicodeControls/TntWideStrings.pas @@ -0,0 +1,846 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntWideStrings; + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$INCLUDE TntCompilers.inc} + +interface + +{$IFDEF COMPILER_10_UP} + {$MESSAGE FATAL 'Do not refer to TntWideStrings.pas. It works correctly in Delphi 2006.'} +{$ENDIF} + +uses + Classes; + +{******************************************************************************} +{ } +{ Delphi 2005 introduced TWideStrings in WideStrings.pas. } +{ Unfortunately, it was not ready for prime time. } +{ Setting CommaText is not consistent, and it relies on CharNextW } +{ Which is only available on Windows NT+. } +{ } +{******************************************************************************} + +type + TWideStrings = class; + +{ IWideStringsAdapter interface } +{ Maintains link between TWideStrings and IWideStrings implementations } + + IWideStringsAdapter = interface + ['{25FE0E3B-66CB-48AA-B23B-BCFA67E8F5DA}'] + procedure ReferenceStrings(S: TWideStrings); + procedure ReleaseStrings; + end; + + TWideStringsEnumerator = class + private + FIndex: Integer; + FStrings: TWideStrings; + public + constructor Create(AStrings: TWideStrings); + function GetCurrent: WideString; + function MoveNext: Boolean; + property Current: WideString read GetCurrent; + end; + +{$IFDEF FPC} + TStringsDefined = set of ( + sdDelimiter, sdQuoteChar, sdNameValueSeparator, sdLineBreak, + sdStrictDelimiter); +{$ENDIF} + +{$DEFINE NAMEVALUESEPARATOR_RW} +{$IFNDEF COMPILER_7_UP} + {$UNDEF NAMEVALUESEPARATOR_RW} +{$ENDIF} + +{ TWideStrings class } + + TWideStrings = class(TPersistent) + private + FDefined: TStringsDefined; + FDelimiter: WideChar; + FQuoteChar: WideChar; + {$IFDEF NAMEVALUESEPARATOR_RW} + FNameValueSeparator: WideChar; + {$ENDIF} + FUpdateCount: Integer; + FAdapter: IWideStringsAdapter; + function GetCommaText: WideString; + function GetDelimitedText: WideString; + function GetName(Index: Integer): WideString; + function GetValue(const Name: WideString): WideString; + procedure ReadData(Reader: TReader); + procedure SetCommaText(const Value: WideString); + procedure SetDelimitedText(const Value: WideString); + procedure SetStringsAdapter(const Value: IWideStringsAdapter); + procedure SetValue(const Name, Value: WideString); + procedure WriteData(Writer: TWriter); + function GetDelimiter: WideChar; + procedure SetDelimiter(const Value: WideChar); + function GetQuoteChar: WideChar; + procedure SetQuoteChar(const Value: WideChar); + function GetNameValueSeparator: WideChar; + {$IFDEF NAMEVALUESEPARATOR_RW} + procedure SetNameValueSeparator(const Value: WideChar); + {$ENDIF} + function GetValueFromIndex(Index: Integer): WideString; + procedure SetValueFromIndex(Index: Integer; const Value: WideString); + protected + procedure AssignTo(Dest: TPersistent); override; + procedure DefineProperties(Filer: TFiler); override; + procedure Error(const Msg: WideString; Data: Integer); overload; + procedure Error(Msg: PResStringRec; Data: Integer); overload; + function ExtractName(const S: WideString): WideString; + function Get(Index: Integer): WideString; virtual; abstract; + function GetCapacity: Integer; virtual; + function GetCount: Integer; virtual; abstract; + function GetObject(Index: Integer): TObject; virtual; + function GetTextStr: WideString; virtual; + procedure Put(Index: Integer; const S: WideString); virtual; + procedure PutObject(Index: Integer; AObject: TObject); virtual; + procedure SetCapacity(NewCapacity: Integer); virtual; + procedure SetTextStr(const Value: WideString); virtual; + procedure SetUpdateState(Updating: Boolean); virtual; + property UpdateCount: Integer read FUpdateCount; + function CompareStrings(const S1, S2: WideString): Integer; virtual; + public + destructor Destroy; override; + function Add(const S: WideString): Integer; virtual; + function AddObject(const S: WideString; AObject: TObject): Integer; virtual; + procedure Append(const S: WideString); + procedure AddStrings(Strings: TStrings{TNT-ALLOW TStrings}); overload; virtual; + procedure AddStrings(Strings: TWideStrings); overload; virtual; + procedure Assign(Source: TPersistent); override; + procedure BeginUpdate; + procedure Clear; virtual; abstract; + procedure Delete(Index: Integer); virtual; abstract; + procedure EndUpdate; + function Equals(Strings: TWideStrings): Boolean; + procedure Exchange(Index1, Index2: Integer); virtual; + function GetEnumerator: TWideStringsEnumerator; + function GetTextW: PWideChar; virtual; + function IndexOf(const S: WideString): Integer; virtual; + function IndexOfName(const Name: WideString): Integer; virtual; + function IndexOfObject(AObject: TObject): Integer; virtual; + procedure Insert(Index: Integer; const S: WideString); virtual; abstract; + procedure InsertObject(Index: Integer; const S: WideString; + AObject: TObject); virtual; + procedure LoadFromFile(const FileName: WideString); virtual; + procedure LoadFromStream(Stream: TStream); virtual; + procedure Move(CurIndex, NewIndex: Integer); virtual; + procedure SaveToFile(const FileName: WideString); virtual; + procedure SaveToStream(Stream: TStream); virtual; + procedure SetTextW(const Text: PWideChar); virtual; + property Capacity: Integer read GetCapacity write SetCapacity; + property CommaText: WideString read GetCommaText write SetCommaText; + property Count: Integer read GetCount; + property Delimiter: WideChar read GetDelimiter write SetDelimiter; + property DelimitedText: WideString read GetDelimitedText write SetDelimitedText; + property Names[Index: Integer]: WideString read GetName; + property Objects[Index: Integer]: TObject read GetObject write PutObject; + property QuoteChar: WideChar read GetQuoteChar write SetQuoteChar; + property Values[const Name: WideString]: WideString read GetValue write SetValue; + property ValueFromIndex[Index: Integer]: WideString read GetValueFromIndex write SetValueFromIndex; + property NameValueSeparator: WideChar read GetNameValueSeparator {$IFDEF NAMEVALUESEPARATOR_RW} write SetNameValueSeparator {$ENDIF}; + property Strings[Index: Integer]: WideString read Get write Put; default; + property Text: WideString read GetTextStr write SetTextStr; + property StringsAdapter: IWideStringsAdapter read FAdapter write SetStringsAdapter; + end; + + PWideStringItem = ^TWideStringItem; + TWideStringItem = record + FString: WideString; + FObject: TObject; + end; + + PWideStringItemList = ^TWideStringItemList; + TWideStringItemList = array[0..MaxListSize] of TWideStringItem; + +implementation + +uses + Windows, SysUtils, TntSystem, {$IFDEF COMPILER_9_UP} WideStrUtils, {$ELSE} TntWideStrUtils, {$ENDIF} + TntSysUtils, TntClasses; + +{ TWideStringsEnumerator } + +constructor TWideStringsEnumerator.Create(AStrings: TWideStrings); +begin + inherited Create; + FIndex := -1; + FStrings := AStrings; +end; + +function TWideStringsEnumerator.GetCurrent: WideString; +begin + Result := FStrings[FIndex]; +end; + +function TWideStringsEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FStrings.Count - 1; + if Result then + Inc(FIndex); +end; + +{ TWideStrings } + +destructor TWideStrings.Destroy; +begin + StringsAdapter := nil; + inherited; +end; + +function TWideStrings.Add(const S: WideString): Integer; +begin + Result := GetCount; + Insert(Result, S); +end; + +function TWideStrings.AddObject(const S: WideString; AObject: TObject): Integer; +begin + Result := Add(S); + PutObject(Result, AObject); +end; + +procedure TWideStrings.Append(const S: WideString); +begin + Add(S); +end; + +procedure TWideStrings.AddStrings(Strings: TStrings{TNT-ALLOW TStrings}); +var + I: Integer; +begin + BeginUpdate; + try + for I := 0 to Strings.Count - 1 do + AddObject(Strings[I], Strings.Objects[I]); + finally + EndUpdate; + end; +end; + +procedure TWideStrings.AddStrings(Strings: TWideStrings); +var + I: Integer; +begin + BeginUpdate; + try + for I := 0 to Strings.Count - 1 do + AddObject(Strings[I], Strings.Objects[I]); + finally + EndUpdate; + end; +end; + +procedure TWideStrings.Assign(Source: TPersistent); +begin + if Source is TWideStrings then + begin + BeginUpdate; + try + Clear; + FDefined := TWideStrings(Source).FDefined; + {$IFDEF NAMEVALUESEPARATOR_RW} + FNameValueSeparator := TWideStrings(Source).FNameValueSeparator; + {$ENDIF} + FQuoteChar := TWideStrings(Source).FQuoteChar; + FDelimiter := TWideStrings(Source).FDelimiter; + AddStrings(TWideStrings(Source)); + finally + EndUpdate; + end; + end + else if Source is TStrings{TNT-ALLOW TStrings} then + begin + BeginUpdate; + try + Clear; + {$IFDEF NAMEVALUESEPARATOR_RW} + FNameValueSeparator := WideChar(TStrings{TNT-ALLOW TStrings}(Source).NameValueSeparator); + {$ENDIF} + FQuoteChar := WideChar(TStrings{TNT-ALLOW TStrings}(Source).QuoteChar); + FDelimiter := WideChar(TStrings{TNT-ALLOW TStrings}(Source).Delimiter); + AddStrings(TStrings{TNT-ALLOW TStrings}(Source)); + finally + EndUpdate; + end; + end + else + inherited Assign(Source); +end; + +procedure TWideStrings.AssignTo(Dest: TPersistent); +var + I: Integer; +begin + if Dest is TWideStrings then Dest.Assign(Self) + else if Dest is TStrings{TNT-ALLOW TStrings} then + begin + TStrings{TNT-ALLOW TStrings}(Dest).BeginUpdate; + try + TStrings{TNT-ALLOW TStrings}(Dest).Clear; + {$IFDEF NAMEVALUESEPARATOR_RW} + TStrings{TNT-ALLOW TStrings}(Dest).NameValueSeparator := AnsiChar(NameValueSeparator); + {$ENDIF} + TStrings{TNT-ALLOW TStrings}(Dest).QuoteChar := AnsiChar(QuoteChar); + TStrings{TNT-ALLOW TStrings}(Dest).Delimiter := AnsiChar(Delimiter); + for I := 0 to Count - 1 do + TStrings{TNT-ALLOW TStrings}(Dest).AddObject(Strings[I], Objects[I]); + finally + TStrings{TNT-ALLOW TStrings}(Dest).EndUpdate; + end; + end + else + inherited AssignTo(Dest); +end; + +procedure TWideStrings.BeginUpdate; +begin + if FUpdateCount = 0 then SetUpdateState(True); + Inc(FUpdateCount); +end; + +procedure TWideStrings.DefineProperties(Filer: TFiler); + + function DoWrite: Boolean; + begin + if Filer.Ancestor <> nil then + begin + Result := True; + if Filer.Ancestor is TWideStrings then + Result := not Equals(TWideStrings(Filer.Ancestor)) + end + else Result := Count > 0; + end; + +begin + Filer.DefineProperty('Strings', ReadData, WriteData, DoWrite); +end; + +procedure TWideStrings.EndUpdate; +begin + Dec(FUpdateCount); + if FUpdateCount = 0 then SetUpdateState(False); +end; + +function TWideStrings.Equals(Strings: TWideStrings): Boolean; +var + I, Count: Integer; +begin + Result := False; + Count := GetCount; + if Count <> Strings.GetCount then Exit; + for I := 0 to Count - 1 do if Get(I) <> Strings.Get(I) then Exit; + Result := True; +end; + +procedure TWideStrings.Error(const Msg: WideString; Data: Integer); + + function ReturnAddr: Pointer; + asm + MOV EAX,[EBP+4] + end; + +begin + raise EStringListError.CreateFmt(Msg, [Data]) at ReturnAddr; +end; + +procedure TWideStrings.Error(Msg: PResStringRec; Data: Integer); +begin + Error(WideLoadResString(Msg), Data); +end; + +procedure TWideStrings.Exchange(Index1, Index2: Integer); +var + TempObject: TObject; + TempString: WideString; +begin + BeginUpdate; + try + TempString := Strings[Index1]; + TempObject := Objects[Index1]; + Strings[Index1] := Strings[Index2]; + Objects[Index1] := Objects[Index2]; + Strings[Index2] := TempString; + Objects[Index2] := TempObject; + finally + EndUpdate; + end; +end; + +function TWideStrings.ExtractName(const S: WideString): WideString; +var + P: Integer; +begin + Result := S; + P := Pos(NameValueSeparator, Result); + if P <> 0 then + SetLength(Result, P-1) else + SetLength(Result, 0); +end; + +function TWideStrings.GetCapacity: Integer; +begin // descendents may optionally override/replace this default implementation + Result := Count; +end; + +function TWideStrings.GetCommaText: WideString; +var + LOldDefined: TStringsDefined; + LOldDelimiter: WideChar; + LOldQuoteChar: WideChar; +begin + LOldDefined := FDefined; + LOldDelimiter := FDelimiter; + LOldQuoteChar := FQuoteChar; + Delimiter := ','; + QuoteChar := '"'; + try + Result := GetDelimitedText; + finally + FDelimiter := LOldDelimiter; + FQuoteChar := LOldQuoteChar; + FDefined := LOldDefined; + end; +end; + +function TWideStrings.GetDelimitedText: WideString; +var + S: WideString; + P: PWideChar; + I, Count: Integer; +begin + Count := GetCount; + if (Count = 1) and (Get(0) = '') then + Result := WideString(QuoteChar) + QuoteChar + else + begin + Result := ''; + for I := 0 to Count - 1 do + begin + S := Get(I); + P := PWideChar(S); + while not ((P^ in [WideChar(#0)..WideChar(' ')]) or (P^ = QuoteChar) or (P^ = Delimiter)) do + Inc(P); + if (P^ <> #0) then S := WideQuotedStr(S, QuoteChar); + Result := Result + S + Delimiter; + end; + System.Delete(Result, Length(Result), 1); + end; +end; + +function TWideStrings.GetName(Index: Integer): WideString; +begin + Result := ExtractName(Get(Index)); +end; + +function TWideStrings.GetObject(Index: Integer): TObject; +begin + Result := nil; +end; + +function TWideStrings.GetEnumerator: TWideStringsEnumerator; +begin + Result := TWideStringsEnumerator.Create(Self); +end; + +function TWideStrings.GetTextW: PWideChar; +begin + Result := WStrNew(PWideChar(GetTextStr)); +end; + +function TWideStrings.GetTextStr: WideString; +var + I, L, Size, Count: Integer; + P: PWideChar; + S, LB: WideString; +begin + Count := GetCount; + Size := 0; + LB := sLineBreak; + for I := 0 to Count - 1 do Inc(Size, Length(Get(I)) + Length(LB)); + SetString(Result, nil, Size); + P := Pointer(Result); + for I := 0 to Count - 1 do + begin + S := Get(I); + L := Length(S); + if L <> 0 then + begin + System.Move(Pointer(S)^, P^, L * SizeOf(WideChar)); + Inc(P, L); + end; + L := Length(LB); + if L <> 0 then + begin + System.Move(Pointer(LB)^, P^, L * SizeOf(WideChar)); + Inc(P, L); + end; + end; +end; + +function TWideStrings.GetValue(const Name: WideString): WideString; +var + I: Integer; +begin + I := IndexOfName(Name); + if I >= 0 then + Result := Copy(Get(I), Length(Name) + 2, MaxInt) else + Result := ''; +end; + +function TWideStrings.IndexOf(const S: WideString): Integer; +begin + for Result := 0 to GetCount - 1 do + if CompareStrings(Get(Result), S) = 0 then Exit; + Result := -1; +end; + +function TWideStrings.IndexOfName(const Name: WideString): Integer; +var + P: Integer; + S: WideString; +begin + for Result := 0 to GetCount - 1 do + begin + S := Get(Result); + P := Pos(NameValueSeparator, S); + if (P <> 0) and (CompareStrings(Copy(S, 1, P - 1), Name) = 0) then Exit; + end; + Result := -1; +end; + +function TWideStrings.IndexOfObject(AObject: TObject): Integer; +begin + for Result := 0 to GetCount - 1 do + if GetObject(Result) = AObject then Exit; + Result := -1; +end; + +procedure TWideStrings.InsertObject(Index: Integer; const S: WideString; + AObject: TObject); +begin + Insert(Index, S); + PutObject(Index, AObject); +end; + +procedure TWideStrings.LoadFromFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TWideStrings.LoadFromStream(Stream: TStream); +var + Size: Integer; + S: WideString; +begin + BeginUpdate; + try + Size := Stream.Size - Stream.Position; + SetString(S, nil, Size div SizeOf(WideChar)); + Stream.Read(Pointer(S)^, Length(S) * SizeOf(WideChar)); + SetTextStr(S); + finally + EndUpdate; + end; +end; + +procedure TWideStrings.Move(CurIndex, NewIndex: Integer); +var + TempObject: TObject; + TempString: WideString; +begin + if CurIndex <> NewIndex then + begin + BeginUpdate; + try + TempString := Get(CurIndex); + TempObject := GetObject(CurIndex); + Delete(CurIndex); + InsertObject(NewIndex, TempString, TempObject); + finally + EndUpdate; + end; + end; +end; + +procedure TWideStrings.Put(Index: Integer; const S: WideString); +var + TempObject: TObject; +begin + TempObject := GetObject(Index); + Delete(Index); + InsertObject(Index, S, TempObject); +end; + +procedure TWideStrings.PutObject(Index: Integer; AObject: TObject); +begin +end; + +procedure TWideStrings.ReadData(Reader: TReader); +begin + if Reader.NextValue in [vaString, vaLString] then + SetTextStr(Reader.ReadString) {JCL compatiblity} + else if Reader.NextValue = vaWString then + SetTextStr(Reader.ReadWideString) {JCL compatiblity} + else begin + BeginUpdate; + try + Clear; + Reader.ReadListBegin; + while not Reader.EndOfList do + if Reader.NextValue in [vaString, vaLString] then + Add(Reader.ReadString) {TStrings compatiblity} + else + Add(Reader.ReadWideString); + Reader.ReadListEnd; + finally + EndUpdate; + end; + end; +end; + +procedure TWideStrings.SaveToFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TWideStrings.SaveToStream(Stream: TStream); +var + SW: WideString; +begin + SW := GetTextStr; + Stream.WriteBuffer(PWideChar(SW)^, Length(SW) * SizeOf(WideChar)); +end; + +procedure TWideStrings.SetCapacity(NewCapacity: Integer); +begin + // do nothing - descendents may optionally implement this method +end; + +procedure TWideStrings.SetCommaText(const Value: WideString); +begin + Delimiter := ','; + QuoteChar := '"'; + SetDelimitedText(Value); +end; + +procedure TWideStrings.SetStringsAdapter(const Value: IWideStringsAdapter); +begin + if FAdapter <> nil then FAdapter.ReleaseStrings; + FAdapter := Value; + if FAdapter <> nil then FAdapter.ReferenceStrings(Self); +end; + +procedure TWideStrings.SetTextW(const Text: PWideChar); +begin + SetTextStr(Text); +end; + +procedure TWideStrings.SetTextStr(const Value: WideString); +var + P, Start: PWideChar; + S: WideString; +begin + BeginUpdate; + try + Clear; + P := Pointer(Value); + if P <> nil then + while P^ <> #0 do + begin + Start := P; + while not (P^ in [WideChar(#0), WideChar(#10), WideChar(#13)]) and (P^ <> WideLineSeparator) do + Inc(P); + SetString(S, Start, P - Start); + Add(S); + if P^ = #13 then Inc(P); + if P^ = #10 then Inc(P); + if P^ = WideLineSeparator then Inc(P); + end; + finally + EndUpdate; + end; +end; + +procedure TWideStrings.SetUpdateState(Updating: Boolean); +begin +end; + +procedure TWideStrings.SetValue(const Name, Value: WideString); +var + I: Integer; +begin + I := IndexOfName(Name); + if Value <> '' then + begin + if I < 0 then I := Add(''); + Put(I, Name + NameValueSeparator + Value); + end else + begin + if I >= 0 then Delete(I); + end; +end; + +procedure TWideStrings.WriteData(Writer: TWriter); +var + I: Integer; +begin + Writer.WriteListBegin; + for I := 0 to Count-1 do begin + Writer.WriteWideString(Get(I)); + end; + Writer.WriteListEnd; +end; + +procedure TWideStrings.SetDelimitedText(const Value: WideString); +var + P, P1: PWideChar; + S: WideString; +begin + BeginUpdate; + try + Clear; + P := PWideChar(Value); + while P^ in [WideChar(#1)..WideChar(' ')] do + Inc(P); + while P^ <> #0 do + begin + if P^ = QuoteChar then + S := WideExtractQuotedStr(P, QuoteChar) + else + begin + P1 := P; + while (P^ > ' ') and (P^ <> Delimiter) do + Inc(P); + SetString(S, P1, P - P1); + end; + Add(S); + while P^ in [WideChar(#1)..WideChar(' ')] do + Inc(P); + if P^ = Delimiter then + begin + P1 := P; + Inc(P1); + if P1^ = #0 then + Add(''); + repeat + Inc(P); + until not (P^ in [WideChar(#1)..WideChar(' ')]); + end; + end; + finally + EndUpdate; + end; +end; + +function TWideStrings.GetDelimiter: WideChar; +begin + if not (sdDelimiter in FDefined) then + Delimiter := ','; + Result := FDelimiter; +end; + +function TWideStrings.GetQuoteChar: WideChar; +begin + if not (sdQuoteChar in FDefined) then + QuoteChar := '"'; + Result := FQuoteChar; +end; + +procedure TWideStrings.SetDelimiter(const Value: WideChar); +begin + if (FDelimiter <> Value) or not (sdDelimiter in FDefined) then + begin + Include(FDefined, sdDelimiter); + FDelimiter := Value; + end +end; + +procedure TWideStrings.SetQuoteChar(const Value: WideChar); +begin + if (FQuoteChar <> Value) or not (sdQuoteChar in FDefined) then + begin + Include(FDefined, sdQuoteChar); + FQuoteChar := Value; + end +end; + +function TWideStrings.CompareStrings(const S1, S2: WideString): Integer; +begin + Result := WideCompareText(S1, S2); +end; + +function TWideStrings.GetNameValueSeparator: WideChar; +begin + {$IFDEF NAMEVALUESEPARATOR_RW} + if not (sdNameValueSeparator in FDefined) then + NameValueSeparator := '='; + Result := FNameValueSeparator; + {$ELSE} + Result := '='; + {$ENDIF} +end; + +{$IFDEF NAMEVALUESEPARATOR_RW} +procedure TWideStrings.SetNameValueSeparator(const Value: WideChar); +begin + if (FNameValueSeparator <> Value) or not (sdNameValueSeparator in FDefined) then + begin + Include(FDefined, sdNameValueSeparator); + FNameValueSeparator := Value; + end +end; +{$ENDIF} + +function TWideStrings.GetValueFromIndex(Index: Integer): WideString; +begin + if Index >= 0 then + Result := Copy(Get(Index), Length(Names[Index]) + 2, MaxInt) else + Result := ''; +end; + +procedure TWideStrings.SetValueFromIndex(Index: Integer; const Value: WideString); +begin + if Value <> '' then + begin + if Index < 0 then Index := Add(''); + Put(Index, Names[Index] + NameValueSeparator + Value); + end + else + if Index >= 0 then Delete(Index); +end; + +end. diff --git a/cmake/src/lib/TntUnicodeControls/TntWindows.pas b/cmake/src/lib/TntUnicodeControls/TntWindows.pas new file mode 100644 index 00000000..8fd7ec88 --- /dev/null +++ b/cmake/src/lib/TntUnicodeControls/TntWindows.pas @@ -0,0 +1,1501 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntWindows; + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Windows, ShellApi, ShlObj; + +// ......... compatibility + +const + DT_NOFULLWIDTHCHARBREAK = $00080000; + +const + INVALID_FILE_ATTRIBUTES = DWORD(-1); + +// ................ ANSI TYPES ................ +{TNT-WARN LPSTR} +{TNT-WARN PLPSTR} +{TNT-WARN LPCSTR} +{TNT-WARN LPCTSTR} +{TNT-WARN LPTSTR} + +// ........ EnumResourceTypesW, EnumResourceNamesW and EnumResourceLanguagesW are supposed .... +// ........ to work on Win95/98/ME but have caused access violations in testing on Win95 ...... +// .. TNT--WARN EnumResourceTypes .. +// .. TNT--WARN EnumResourceTypesA .. +// .. TNT--WARN EnumResourceNames .. +// .. TNT--WARN EnumResourceNamesA .. +// .. TNT--WARN EnumResourceLanguages .. +// .. TNT--WARN EnumResourceLanguagesA .. + +//------------------------------------------------------------------------------------------ + +// ......... The Unicode form of these functions are supported on Windows 95/98/ME ......... +{TNT-WARN ExtTextOut} +{TNT-WARN ExtTextOutA} +{TNT-WARN Tnt_ExtTextOutW} + +{TNT-WARN FindResource} +{TNT-WARN FindResourceA} +{TNT-WARN Tnt_FindResourceW} + +{TNT-WARN FindResourceEx} +{TNT-WARN FindResourceExA} +{TNT-WARN Tnt_FindResourceExW} + +{TNT-WARN GetCharWidth} +{TNT-WARN GetCharWidthA} +{TNT-WARN Tnt_GetCharWidthW} + +{TNT-WARN GetCommandLine} +{TNT-WARN GetCommandLineA} +{TNT-WARN Tnt_GetCommandLineW} + +{TNT-WARN GetTextExtentPoint} +{TNT-WARN GetTextExtentPointA} +{TNT-WARN Tnt_GetTextExtentPointW} + +{TNT-WARN GetTextExtentPoint32} +{TNT-WARN GetTextExtentPoint32A} +{TNT-WARN Tnt_GetTextExtentPoint32W} + +{TNT-WARN lstrcat} +{TNT-WARN lstrcatA} +{TNT-WARN Tnt_lstrcatW} + +{TNT-WARN lstrcpy} +{TNT-WARN lstrcpyA} +{TNT-WARN Tnt_lstrcpyW} + +{TNT-WARN lstrlen} +{TNT-WARN lstrlenA} +{TNT-WARN Tnt_lstrlenW} + +{TNT-WARN MessageBox} +{TNT-WARN MessageBoxA} +{TNT-WARN Tnt_MessageBoxW} + +{TNT-WARN MessageBoxEx} +{TNT-WARN MessageBoxExA} +{TNT-WARN Tnt_MessageBoxExA} + +{TNT-WARN TextOut} +{TNT-WARN TextOutA} +{TNT-WARN Tnt_TextOutW} + +//------------------------------------------------------------------------------------------ + +{TNT-WARN LOCALE_USER_DEFAULT} // <-- use GetThreadLocale +{TNT-WARN LOCALE_SYSTEM_DEFAULT} // <-- use GetThreadLocale + +//------------------------------------------------------------------------------------------ +// compatiblity +//------------------------------------------------------------------------------------------ +{$IFNDEF COMPILER_9_UP} +type + {$IFDEF FPC} + TStartupInfoA = STARTUPINFO; + TStartupInfoW = STARTUPINFO; + {$ELSE} + TStartupInfoA = _STARTUPINFOA; + TStartupInfoW = record + cb: DWORD; + lpReserved: PWideChar; + lpDesktop: PWideChar; + lpTitle: PWideChar; + dwX: DWORD; + dwY: DWORD; + dwXSize: DWORD; + dwYSize: DWORD; + dwXCountChars: DWORD; + dwYCountChars: DWORD; + dwFillAttribute: DWORD; + dwFlags: DWORD; + wShowWindow: Word; + cbReserved2: Word; + lpReserved2: PByte; + hStdInput: THandle; + hStdOutput: THandle; + hStdError: THandle; + end; + {$ENDIF} + +function CreateProcessW{TNT-ALLOW CreateProcessW}(lpApplicationName: PWideChar; lpCommandLine: PWideChar; + lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; + bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; + lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; + var lpProcessInformation: TProcessInformation): BOOL; stdcall; external kernel32 name 'CreateProcessW'; + +{$ENDIF} + +{$IFDEF FPC} +type + TCurrencyFmtA = CURRENCYFMT; + TCurrencyFmtW = CURRENCYFMT; + PCurrencyFmtA = ^TCurrencyFmtA; + PCurrencyFmtW = ^TCurrencyFmtW; +{$ENDIF} + +//------------------------------------------------------------------------------------------ + +{TNT-WARN SetWindowText} +{TNT-WARN SetWindowTextA} +{TNT-WARN SetWindowTextW} +function Tnt_SetWindowTextW(hWnd: HWND; lpString: PWideChar): BOOL; + +{TNT-WARN RemoveDirectory} +{TNT-WARN RemoveDirectoryA} +{TNT-WARN RemoveDirectoryW} +function Tnt_RemoveDirectoryW(lpPathName: PWideChar): BOOL; + +{TNT-WARN GetShortPathName} +{TNT-WARN GetShortPathNameA} +{TNT-WARN GetShortPathNameW} +function Tnt_GetShortPathNameW(lpszLongPath: PWideChar; lpszShortPath: PWideChar; + cchBuffer: DWORD): DWORD; + +{TNT-WARN GetFullPathName} +{TNT-WARN GetFullPathNameA} +{TNT-WARN GetFullPathNameW} +function Tnt_GetFullPathNameW(lpFileName: PWideChar; nBufferLength: DWORD; + lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; + +{TNT-WARN CreateFile} +{TNT-WARN CreateFileA} +{TNT-WARN CreateFileW} +function Tnt_CreateFileW(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD; + lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; + hTemplateFile: THandle): THandle; + +{TNT-WARN FindFirstFile} +{TNT-WARN FindFirstFileA} +{TNT-WARN FindFirstFileW} +function Tnt_FindFirstFileW(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; + +{TNT-WARN FindNextFile} +{TNT-WARN FindNextFileA} +{TNT-WARN FindNextFileW} +function Tnt_FindNextFileW(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; + +{TNT-WARN GetFileAttributes} +{TNT-WARN GetFileAttributesA} +{TNT-WARN GetFileAttributesW} +function Tnt_GetFileAttributesW(lpFileName: PWideChar): DWORD; + +{TNT-WARN SetFileAttributes} +{TNT-WARN SetFileAttributesA} +{TNT-WARN SetFileAttributesW} +function Tnt_SetFileAttributesW(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; + +{TNT-WARN CreateDirectory} +{TNT-WARN CreateDirectoryA} +{TNT-WARN CreateDirectoryW} +function Tnt_CreateDirectoryW(lpPathName: PWideChar; + lpSecurityAttributes: PSecurityAttributes): BOOL; + +{TNT-WARN MoveFile} +{TNT-WARN MoveFileA} +{TNT-WARN MoveFileW} +function Tnt_MoveFileW(lpExistingFileName, lpNewFileName: PWideChar): BOOL; + +{TNT-WARN CopyFile} +{TNT-WARN CopyFileA} +{TNT-WARN CopyFileW} +function Tnt_CopyFileW(lpExistingFileName, lpNewFileName: PWideChar; bFailIfExists: BOOL): BOOL; + +{TNT-WARN DeleteFile} +{TNT-WARN DeleteFileA} +{TNT-WARN DeleteFileW} +function Tnt_DeleteFileW(lpFileName: PWideChar): BOOL; + +{TNT-WARN DrawText} +{TNT-WARN DrawTextA} +{TNT-WARN DrawTextW} +function Tnt_DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; + var lpRect: TRect; uFormat: UINT): Integer; + +{TNT-WARN GetDiskFreeSpace} +{TNT-WARN GetDiskFreeSpaceA} +{TNT-WARN GetDiskFreeSpaceW} +function Tnt_GetDiskFreeSpaceW(lpRootPathName: PWideChar; var lpSectorsPerCluster, + lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; + +{TNT-WARN GetVolumeInformation} +{TNT-WARN GetVolumeInformationA} +{TNT-WARN GetVolumeInformationW} +function Tnt_GetVolumeInformationW(lpRootPathName: PWideChar; lpVolumeNameBuffer: PWideChar; + nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; + var lpMaximumComponentLength, lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PWideChar; + nFileSystemNameSize: DWORD): BOOL; + +{TNT-WARN GetModuleFileName} +{TNT-WARN GetModuleFileNameA} +{TNT-WARN GetModuleFileNameW} +function Tnt_GetModuleFileNameW(hModule: HINST; lpFilename: PWideChar; nSize: DWORD): DWORD; + +{TNT-WARN GetTempPath} +{TNT-WARN GetTempPathA} +{TNT-WARN GetTempPathW} +function Tnt_GetTempPathW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; + +{TNT-WARN GetTempFileName} +{TNT-WARN GetTempFileNameA} +{TNT-WARN GetTempFileNameW} +function Tnt_GetTempFileNameW(lpPathName, lpPrefixString: PWideChar; uUnique: UINT; + lpTempFileName: PWideChar): UINT; + +{TNT-WARN GetWindowsDirectory} +{TNT-WARN GetWindowsDirectoryA} +{TNT-WARN GetWindowsDirectoryW} +function Tnt_GetWindowsDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; + +{TNT-WARN GetSystemDirectory} +{TNT-WARN GetSystemDirectoryA} +{TNT-WARN GetSystemDirectoryW} +function Tnt_GetSystemDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; + +{TNT-WARN GetCurrentDirectory} +{TNT-WARN GetCurrentDirectoryA} +{TNT-WARN GetCurrentDirectoryW} +function Tnt_GetCurrentDirectoryW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; + +{TNT-WARN SetCurrentDirectory} +{TNT-WARN SetCurrentDirectoryA} +{TNT-WARN SetCurrentDirectoryW} +function Tnt_SetCurrentDirectoryW(lpPathName: PWideChar): BOOL; + +{TNT-WARN GetComputerName} +{TNT-WARN GetComputerNameA} +{TNT-WARN GetComputerNameW} +function Tnt_GetComputerNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; + +{TNT-WARN GetUserName} +{TNT-WARN GetUserNameA} +{TNT-WARN GetUserNameW} +function Tnt_GetUserNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; + +{TNT-WARN ShellExecute} +{TNT-WARN ShellExecuteA} +{TNT-WARN ShellExecuteW} +function Tnt_ShellExecuteW(hWnd: HWND; Operation, FileName, Parameters, + Directory: PWideChar; ShowCmd: Integer): HINST; + +{TNT-WARN LoadLibrary} +{TNT-WARN LoadLibraryA} +{TNT-WARN LoadLibraryW} +function Tnt_LoadLibraryW(lpLibFileName: PWideChar): HMODULE; + +{TNT-WARN LoadLibraryEx} +{TNT-WARN LoadLibraryExA} +{TNT-WARN LoadLibraryExW} +function Tnt_LoadLibraryExW(lpLibFileName: PWideChar; hFile: THandle; dwFlags: DWORD): HMODULE; + +{TNT-WARN CreateProcess} +{TNT-WARN CreateProcessA} +{TNT-WARN CreateProcessW} +function Tnt_CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar; + lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; + bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; + lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; + var lpProcessInformation: TProcessInformation): BOOL; + +{TNT-WARN GetCurrencyFormat} +{TNT-WARN GetCurrencyFormatA} +{TNT-WARN GetCurrencyFormatW} +function Tnt_GetCurrencyFormatW(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar; + lpFormat: PCurrencyFmtW; lpCurrencyStr: PWideChar; cchCurrency: Integer): Integer; + +{TNT-WARN CompareString} +{TNT-WARN CompareStringA} +{TNT-WARN CompareStringW} +function Tnt_CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: PWideChar; + cchCount1: Integer; lpString2: PWideChar; cchCount2: Integer): Integer; + +{TNT-WARN CharUpper} +{TNT-WARN CharUpperA} +{TNT-WARN CharUpperW} +function Tnt_CharUpperW(lpsz: PWideChar): PWideChar; + +{TNT-WARN CharUpperBuff} +{TNT-WARN CharUpperBuffA} +{TNT-WARN CharUpperBuffW} +function Tnt_CharUpperBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; + +{TNT-WARN CharLower} +{TNT-WARN CharLowerA} +{TNT-WARN CharLowerW} +function Tnt_CharLowerW(lpsz: PWideChar): PWideChar; + +{TNT-WARN CharLowerBuff} +{TNT-WARN CharLowerBuffA} +{TNT-WARN CharLowerBuffW} +function Tnt_CharLowerBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; + +{TNT-WARN GetStringTypeEx} +{TNT-WARN GetStringTypeExA} +{TNT-WARN GetStringTypeExW} +function Tnt_GetStringTypeExW(Locale: LCID; dwInfoType: DWORD; + lpSrcStr: PWideChar; cchSrc: Integer; var lpCharType): BOOL; + +{TNT-WARN LoadString} +{TNT-WARN LoadStringA} +{TNT-WARN LoadStringW} +function Tnt_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; + +{$IFDEF FPC} +type + TMenuItemInfoW = TMENUITEMINFO; + tagMenuItemINFOW = tagMENUITEMINFO; +{$ENDIF} + +{TNT-WARN InsertMenuItem} +{TNT-WARN InsertMenuItemA} +{TNT-WARN InsertMenuItemW} +function Tnt_InsertMenuItemW(hMenu: HMENU; uItem: DWORD; fByPosition: BOOL; lpmii: tagMenuItemINFOW): BOOL; + +{TNT-WARN ExtractIconEx} +{TNT-WARN ExtractIconExA} +{TNT-WARN ExtractIconExW} +function Tnt_ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; + var phiconLarge, phiconSmall: HICON; nIcons: UINT): UINT; + +{TNT-WARN ExtractAssociatedIcon} +{TNT-WARN ExtractAssociatedIconA} +{TNT-WARN ExtractAssociatedIconW} +function Tnt_ExtractAssociatedIconW(hInst: HINST; lpIconPath: PWideChar; + var lpiIcon: Word): HICON; + +{TNT-WARN GetFileVersionInfoSize} +{TNT-WARN GetFileVersionInfoSizeA} +{TNT-WARN GetFileVersionInfoSizeW} +function Tnt_GetFileVersionInfoSizeW(lptstrFilename: PWideChar; var lpdwHandle: DWORD): DWORD; + +{TNT-WARN GetFileVersionInfo} +{TNT-WARN GetFileVersionInfoA} +{TNT-WARN GetFileVersionInfoW} +function Tnt_GetFileVersionInfoW(lptstrFilename: PWideChar; dwHandle, dwLen: DWORD; + lpData: Pointer): BOOL; + +const + VQV_FIXEDFILEINFO = '\'; + VQV_VARFILEINFO_TRANSLATION = '\VarFileInfo\Translation'; + VQV_STRINGFILEINFO = '\StringFileInfo'; + + VER_COMMENTS = 'Comments'; + VER_INTERNALNAME = 'InternalName'; + VER_PRODUCTNAME = 'ProductName'; + VER_COMPANYNAME = 'CompanyName'; + VER_LEGALCOPYRIGHT = 'LegalCopyright'; + VER_PRODUCTVERSION = 'ProductVersion'; + VER_FILEDESCRIPTION = 'FileDescription'; + VER_LEGALTRADEMARKS = 'LegalTrademarks'; + VER_PRIVATEBUILD = 'PrivateBuild'; + VER_FILEVERSION = 'FileVersion'; + VER_ORIGINALFILENAME = 'OriginalFilename'; + VER_SPECIALBUILD = 'SpecialBuild'; + +{TNT-WARN VerQueryValue} +{TNT-WARN VerQueryValueA} +{TNT-WARN VerQueryValueW} +function Tnt_VerQueryValueW(pBlock: Pointer; lpSubBlock: PWideChar; + var lplpBuffer: Pointer; var puLen: UINT): BOOL; + +type +{$IFDEF FPC} + PSHNAMEMAPPINGA = ^SHNAMEMAPPINGA; + SHNAMEMAPPINGA = record + pszOldPath : LPSTR; + pszNewPath : LPSTR; + cchOldPath : longint; + cchNewPath : longint; + end; + + PSHNAMEMAPPINGW = ^SHNAMEMAPPINGW; + SHNAMEMAPPINGW = record + pszOldPath : LPWSTR; + pszNewPath : LPWSTR; + cchOldPath : longint; + cchNewPath : longint; + end; +{$ENDIF} + + TSHNameMappingHeaderA = record + cNumOfMappings: Cardinal; + lpNM: PSHNAMEMAPPINGA; + end; + PSHNameMappingHeaderA = ^TSHNameMappingHeaderA; + + TSHNameMappingHeaderW = record + cNumOfMappings: Cardinal; + lpNM: PSHNAMEMAPPINGW; + end; + PSHNameMappingHeaderW = ^TSHNameMappingHeaderW; + +{TNT-WARN SHFileOperation} +{TNT-WARN SHFileOperationA} +{TNT-WARN SHFileOperationW} // <-- no stub on early Windows 95 +function Tnt_SHFileOperationW(var lpFileOp: TSHFileOpStructW): Integer; + +{TNT-WARN SHFreeNameMappings} +procedure Tnt_SHFreeNameMappings(hNameMappings: THandle); + +{TNT-WARN SHBrowseForFolder} +{TNT-WARN SHBrowseForFolderA} +{TNT-WARN SHBrowseForFolderW} // <-- no stub on early Windows 95 +function Tnt_SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; + +{TNT-WARN SHGetPathFromIDList} +{TNT-WARN SHGetPathFromIDListA} +{TNT-WARN SHGetPathFromIDListW} // <-- no stub on early Windows 95 +function Tnt_SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PWideChar): BOOL; + +{TNT-WARN SHGetFileInfo} +{TNT-WARN SHGetFileInfoA} +{TNT-WARN SHGetFileInfoW} // <-- no stub on early Windows 95 +function Tnt_SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; + var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; + +// ......... introduced ......... +function Tnt_Is_IntResource(ResStr: LPCWSTR): Boolean; + +function LANGIDFROMLCID(lcid: LCID): WORD; +function MAKELANGID(usPrimaryLanguage, usSubLanguage: WORD): WORD; +function MAKELCID(wLanguageID: WORD; wSortID: WORD = SORT_DEFAULT): LCID; +function PRIMARYLANGID(lgid: WORD): WORD; +function SORTIDFROMLCID(lcid: LCID): WORD; +function SUBLANGID(lgid: WORD): WORD; + +implementation + +uses + SysUtils, Math, TntSysUtils, + {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils; + +function _PAnsiCharWithNil(const S: AnsiString): PAnsiChar; +begin + if S = '' then + Result := nil {Win9x needs nil for some parameters instead of empty strings} + else + Result := PAnsiChar(S); +end; + +function _PWideCharWithNil(const S: WideString): PWideChar; +begin + if S = '' then + Result := nil {Win9x needs nil for some parameters instead of empty strings} + else + Result := PWideChar(S); +end; + +function _WStr(lpString: PWideChar; cchCount: Integer): WideString; +begin + if cchCount = -1 then + Result := lpString + else + Result := Copy(WideString(lpString), 1, cchCount); +end; + +procedure _MakeWideWin32FindData(var WideFindData: TWIN32FindDataW; AnsiFindData: TWIN32FindDataA); +begin + CopyMemory(@WideFindData, @AnsiFindData, + PtrUInt(@WideFindData.cFileName) - PtrUInt(@WideFindData)); + WStrPCopy(WideFindData.cFileName, AnsiFindData.cFileName); + WStrPCopy(WideFindData.cAlternateFileName, AnsiFindData.cAlternateFileName); +end; + +function Tnt_SetWindowTextW(hWnd: HWND; lpString: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := SetWindowTextW{TNT-ALLOW SetWindowTextW}(hWnd, lpString) + else + Result := SetWindowTextA{TNT-ALLOW SetWindowTextA}(hWnd, PAnsiChar(AnsiString(lpString))); +end; + +//----------------------------- + +type + TPathLengthResultOption = (poAllowDirectoryMode, poZeroSmallBuff, poExactCopy, poExactCopySubPaths); + TPathLengthResultOptions = set of TPathLengthResultOption; + +procedure _ExactStrCopyW(pDest, pSource: PWideChar; Count: Integer); +var + i: integer; +begin + for i := 1 to Count do begin + pDest^ := pSource^; + Inc(PSource); + Inc(pDest); + end; +end; + +procedure _ExactCopySubPaths(pDest, pSource: PWideChar; Count: Integer); +var + i: integer; + OriginalSource: PWideChar; + PNextSlash: PWideChar; +begin + if Count >= 4 then begin + OriginalSource := pSource; + PNextSlash := WStrScan(pSource, '\'); + for i := 1 to Count - 1 do begin + // determine next path delimiter + if pSource > pNextSlash then begin + PNextSlash := WStrScan(pSource, '\'); + end; + // leave if no more sub paths + if (PNextSlash = nil) + or ((pNextSlash - OriginalSource) >= Count) then begin + exit; + end; + // copy char + pDest^ := pSource^; + Inc(PSource); + Inc(pDest); + end; + end; +end; + +function _HandlePathLengthResult(nBufferLength: DWORD; lpBuffer: PWideChar; const AnsiBuff: AnsiString; Options: TPathLengthResultOptions): Integer; +var + WideBuff: WideString; +begin + WideBuff := AnsiBuff; + if nBufferLength > Cardinal(Length(WideBuff)) then begin + // normal + Result := Length(WideBuff); + WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength); + end else if (poExactCopy in Options) then begin + // exact + Result := nBufferLength; + _ExactStrCopyW(lpBuffer, PWideChar(WideBuff), nBufferLength); + end else begin + // other + if (poAllowDirectoryMode in Options) + and (nBufferLength = Cardinal(Length(WideBuff))) then begin + Result := Length(WideBuff) + 1; + WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength - 1); + end else begin + Result := Length(WideBuff) + 1; + if (nBufferLength > 0) then begin + if (poZeroSmallBuff in Options) then + lpBuffer^ := #0 + else if (poExactCopySubPaths in Options) then + _ExactCopySubPaths(lpBuffer, PWideChar(WideBuff), nBufferLength); + end; + end; + end; +end; + +function _HandleStringLengthResult(nBufferLength: DWORD; lpBuffer: PWideChar; const AnsiBuff: AnsiString; Options: TPathLengthResultOptions): Integer; +var + WideBuff: WideString; +begin + WideBuff := AnsiBuff; + if nBufferLength >= Cardinal(Length(WideBuff)) then begin + // normal + Result := Length(WideBuff); + WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength); + end else if nBufferLength = 0 then + Result := Length(WideBuff) + else + Result := 0; +end; + +//------------------------------------------- + +function Tnt_RemoveDirectoryW(lpPathName: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := RemoveDirectoryW{TNT-ALLOW RemoveDirectoryW}(PWideChar(lpPathName)) + else + Result := RemoveDirectoryA{TNT-ALLOW RemoveDirectoryA}(PAnsiChar(AnsiString(lpPathName))); +end; + +function Tnt_GetShortPathNameW(lpszLongPath: PWideChar; lpszShortPath: PWideChar; + cchBuffer: DWORD): DWORD; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetShortPathNameW{TNT-ALLOW GetShortPathNameW}(lpszLongPath, lpszShortPath, cchBuffer) + else begin + SetLength(AnsiBuff, MAX_PATH * 2); + SetLength(AnsiBuff, GetShortPathNameA{TNT-ALLOW GetShortPathNameA}(PAnsiChar(AnsiString(lpszLongPath)), + PAnsiChar(AnsiBuff), Length(AnsiBuff))); + Result := _HandlePathLengthResult(cchBuffer, lpszShortPath, AnsiBuff, [poExactCopySubPaths]); + end; +end; + +function Tnt_GetFullPathNameW(lpFileName: PWideChar; nBufferLength: DWORD; + lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; +var + AnsiBuff: AnsiString; + AnsiFilePart: PAnsiChar; + AnsiLeadingChars: Integer; + WideLeadingChars: Integer; +begin + if Win32PlatformIsUnicode then + Result := GetFullPathNameW{TNT-ALLOW GetFullPathNameW}(lpFileName, nBufferLength, lpBuffer, lpFilePart) + else begin + SetLength(AnsiBuff, MAX_PATH * 2); + SetLength(AnsiBuff, GetFullPathNameA{TNT-ALLOW GetFullPathNameA}(PAnsiChar(AnsiString(lpFileName)), + Length(AnsiBuff), PAnsiChar(AnsiBuff), AnsiFilePart)); + Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poZeroSmallBuff]); + // deal w/ lpFilePart + if (AnsiFilePart = nil) or (nBufferLength < Result) then + lpFilePart := nil + else begin + AnsiLeadingChars := AnsiFilePart - PAnsiChar(AnsiBuff); + WideLeadingChars := Length(WideString(Copy(AnsiBuff, 1, AnsiLeadingChars))); + lpFilePart := lpBuffer + WideLeadingChars; + end; + end; +end; + +function Tnt_CreateFileW(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD; + lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; + hTemplateFile: THandle): THandle; +begin + if Win32PlatformIsUnicode then + Result := CreateFileW{TNT-ALLOW CreateFileW}(lpFileName, dwDesiredAccess, dwShareMode, + lpSecurityAttributes, dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile) + else + Result := CreateFileA{TNT-ALLOW CreateFileA}(PAnsiChar(AnsiString(lpFileName)), dwDesiredAccess, dwShareMode, + lpSecurityAttributes, dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile) +end; + +function Tnt_FindFirstFileW(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; +var + Ansi_lpFindFileData: TWIN32FindDataA; +begin + if Win32PlatformIsUnicode then + Result := FindFirstFileW{TNT-ALLOW FindFirstFileW}(lpFileName, lpFindFileData) + else begin + Result := FindFirstFileA{TNT-ALLOW FindFirstFileA}(PAnsiChar(AnsiString(lpFileName)), + Ansi_lpFindFileData); + if Result <> INVALID_HANDLE_VALUE then + _MakeWideWin32FindData(lpFindFileData, Ansi_lpFindFileData); + end; +end; + +function Tnt_FindNextFileW(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; +var + Ansi_lpFindFileData: TWIN32FindDataA; +begin + if Win32PlatformIsUnicode then + Result := FindNextFileW{TNT-ALLOW FindNextFileW}(hFindFile, lpFindFileData) + else begin + Result := FindNextFileA{TNT-ALLOW FindNextFileA}(hFindFile, Ansi_lpFindFileData); + if Result then + _MakeWideWin32FindData(lpFindFileData, Ansi_lpFindFileData); + end; +end; + +function Tnt_GetFileAttributesW(lpFileName: PWideChar): DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetFileAttributesW{TNT-ALLOW GetFileAttributesW}(lpFileName) + else + Result := GetFileAttributesA{TNT-ALLOW GetFileAttributesA}(PAnsiChar(AnsiString(lpFileName))); +end; + +function Tnt_SetFileAttributesW(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; +begin + if Win32PlatformIsUnicode then + Result := SetFileAttributesW{TNT-ALLOW SetFileAttributesW}(lpFileName, dwFileAttributes) + else + Result := SetFileAttributesA{TNT-ALLOW SetFileAttributesA}(PAnsiChar(AnsiString(lpFileName)), dwFileAttributes); +end; + +function Tnt_CreateDirectoryW(lpPathName: PWideChar; + lpSecurityAttributes: PSecurityAttributes): BOOL; +begin + if Win32PlatformIsUnicode then + Result := CreateDirectoryW{TNT-ALLOW CreateDirectoryW}(lpPathName, lpSecurityAttributes) + else + Result := CreateDirectoryA{TNT-ALLOW CreateDirectoryA}(PAnsiChar(AnsiString(lpPathName)), lpSecurityAttributes); +end; + +function Tnt_MoveFileW(lpExistingFileName, lpNewFileName: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := MoveFileW{TNT-ALLOW MoveFileW}(lpExistingFileName, lpNewFileName) + else + Result := MoveFileA{TNT-ALLOW MoveFileA}(PAnsiChar(AnsiString(lpExistingFileName)), PAnsiChar(AnsiString(lpNewFileName))); +end; + +function Tnt_CopyFileW(lpExistingFileName, lpNewFileName: PWideChar; bFailIfExists: BOOL): BOOL; +begin + if Win32PlatformIsUnicode then + Result := CopyFileW{TNT-ALLOW CopyFileW}(lpExistingFileName, lpNewFileName, bFailIfExists) + else + Result := CopyFileA{TNT-ALLOW CopyFileA}(PAnsiChar(AnsiString(lpExistingFileName)), + PAnsiChar(AnsiString(lpNewFileName)), bFailIfExists); +end; + +function Tnt_DeleteFileW(lpFileName: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := DeleteFileW{TNT-ALLOW DeleteFileW}(lpFileName) + else + Result := DeleteFileA{TNT-ALLOW DeleteFileA}(PAnsiChar(AnsiString(lpFileName))); +end; + +function Tnt_DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; + var lpRect: TRect; uFormat: UINT): Integer; +begin + if Win32PlatformIsUnicode then + Result := DrawTextW{TNT-ALLOW DrawTextW}(hDC, lpString, nCount, lpRect, uFormat) + else + Result := DrawTextA{TNT-ALLOW DrawTextA}(hDC, + PAnsiChar(AnsiString(_WStr(lpString, nCount))), -1, lpRect, uFormat); +end; + +function Tnt_GetDiskFreeSpaceW(lpRootPathName: PWideChar; var lpSectorsPerCluster, + lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; +begin + if Win32PlatformIsUnicode then + Result := GetDiskFreeSpaceW{TNT-ALLOW GetDiskFreeSpaceW}(lpRootPathName, + lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters) + else + Result := GetDiskFreeSpaceA{TNT-ALLOW GetDiskFreeSpaceA}(PAnsiChar(AnsiString(lpRootPathName)), + lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters) +end; + +function Tnt_GetVolumeInformationW(lpRootPathName: PWideChar; lpVolumeNameBuffer: PWideChar; + nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; + var lpMaximumComponentLength, lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PWideChar; + nFileSystemNameSize: DWORD): BOOL; +var + AnsiFileSystemNameBuffer: AnsiString; + AnsiVolumeNameBuffer: AnsiString; + AnsiBuffLen: DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetVolumeInformationW{TNT-ALLOW GetVolumeInformationW}(lpRootPathName, lpVolumeNameBuffer, nVolumeNameSize, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, lpFileSystemNameBuffer, nFileSystemNameSize) + else begin + SetLength(AnsiVolumeNameBuffer, MAX_COMPUTERNAME_LENGTH + 1); + SetLength(AnsiFileSystemNameBuffer, MAX_COMPUTERNAME_LENGTH + 1); + AnsiBuffLen := Length(AnsiFileSystemNameBuffer); + Result := GetVolumeInformationA{TNT-ALLOW GetVolumeInformationA}(PAnsiChar(AnsiString(lpRootPathName)), PAnsiChar(AnsiVolumeNameBuffer), AnsiBuffLen, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, PAnsiChar(AnsiFileSystemNameBuffer), AnsiBuffLen); + if Result then begin + SetLength(AnsiFileSystemNameBuffer, AnsiBuffLen); + if (nFileSystemNameSize <= AnsiBuffLen) or (Length(AnsiFileSystemNameBuffer) = 0) then + Result := False + else begin + WStrPLCopy(lpFileSystemNameBuffer, AnsiFileSystemNameBuffer, nFileSystemNameSize); + WStrPLCopy(lpVolumeNameBuffer, AnsiVolumeNameBuffer, nVolumeNameSize); + end; + end; + end; +end; + +function Tnt_GetModuleFileNameW(hModule: HINST; lpFilename: PWideChar; nSize: DWORD): DWORD; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetModuleFileNameW{TNT-ALLOW GetModuleFileNameW}(hModule, lpFilename, nSize) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetModuleFileNameA{TNT-ALLOW GetModuleFileNameA}(hModule, PAnsiChar(AnsiBuff), Length(AnsiBuff))); + Result := _HandlePathLengthResult(nSize, lpFilename, AnsiBuff, [poExactCopy]); + end; +end; + +function Tnt_GetTempPathW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetTempPathW{TNT-ALLOW GetTempPathW}(nBufferLength, lpBuffer) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetTempPathA{TNT-ALLOW GetTempPathA}(Length(AnsiBuff), PAnsiChar(AnsiBuff))); + Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poAllowDirectoryMode, poZeroSmallBuff]); + end; +end; + +function Tnt_GetTempFileNameW(lpPathName, lpPrefixString: PWideChar; uUnique: UINT; + lpTempFileName: PWideChar): UINT; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetTempFileNameW{TNT-ALLOW GetTempFileNameW}(lpPathName, lpPrefixString, uUnique, lpTempFileName) + else begin + SetLength(AnsiBuff, MAX_PATH); + Result := GetTempFileNameA{TNT-ALLOW GetTempFileNameA}(PAnsiChar(AnsiString(lpPathName)), PAnsiChar(lpPrefixString), uUnique, PAnsiChar(AnsiBuff)); + AnsiBuff := PAnsiChar(AnsiBuff); + _HandlePathLengthResult(MAX_PATH, lpTempFileName, AnsiBuff, [poZeroSmallBuff]); + end; +end; + +function Tnt_GetWindowsDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetWindowsDirectoryW{TNT-ALLOW GetWindowsDirectoryW}(lpBuffer, uSize) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetWindowsDirectoryA{TNT-ALLOW GetWindowsDirectoryA}(PAnsiChar(AnsiBuff), Length(AnsiBuff))); + Result := _HandlePathLengthResult(uSize, lpBuffer, AnsiBuff, []); + end; +end; + +function Tnt_GetSystemDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetSystemDirectoryW{TNT-ALLOW GetSystemDirectoryW}(lpBuffer, uSize) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetSystemDirectoryA{TNT-ALLOW GetSystemDirectoryA}(PAnsiChar(AnsiBuff), Length(AnsiBuff))); + Result := _HandlePathLengthResult(uSize, lpBuffer, AnsiBuff, []); + end; +end; + +function Tnt_GetCurrentDirectoryW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetCurrentDirectoryW{TNT-ALLOW GetCurrentDirectoryW}(nBufferLength, lpBuffer) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetCurrentDirectoryA{TNT-ALLOW GetCurrentDirectoryA}(Length(AnsiBuff), PAnsiChar(AnsiBuff))); + Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poAllowDirectoryMode, poZeroSmallBuff]); + end; +end; + +function Tnt_SetCurrentDirectoryW(lpPathName: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := SetCurrentDirectoryW{TNT-ALLOW SetCurrentDirectoryW}(lpPathName) + else + Result := SetCurrentDirectoryA{TNT-ALLOW SetCurrentDirectoryA}(PAnsiChar(AnsiString(lpPathName))); +end; + +function Tnt_GetComputerNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; +var + AnsiBuff: AnsiString; + AnsiBuffLen: DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetComputerNameW{TNT-ALLOW GetComputerNameW}(lpBuffer, nSize) + else begin + SetLength(AnsiBuff, MAX_COMPUTERNAME_LENGTH + 1); + AnsiBuffLen := Length(AnsiBuff); + Result := GetComputerNameA{TNT-ALLOW GetComputerNameA}(PAnsiChar(AnsiBuff), AnsiBuffLen); + if Result then begin + SetLength(AnsiBuff, AnsiBuffLen); + if (nSize <= AnsiBuffLen) or (Length(AnsiBuff) = 0) then begin + nSize := AnsiBuffLen + 1; + Result := False; + end else begin + WStrPLCopy(lpBuffer, AnsiBuff, nSize); + nSize := WStrLen(lpBuffer); + end; + end; + end; +end; + +function Tnt_GetUserNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; +var + AnsiBuff: AnsiString; + AnsiBuffLen: DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetUserNameW{TNT-ALLOW GetUserNameW}(lpBuffer, nSize) + else begin + SetLength(AnsiBuff, 255); + AnsiBuffLen := Length(AnsiBuff); + Result := GetUserNameA{TNT-ALLOW GetUserNameA}(PAnsiChar(AnsiBuff), AnsiBuffLen); + if Result then begin + SetLength(AnsiBuff, AnsiBuffLen); + if (nSize <= AnsiBuffLen) or (Length(AnsiBuff) = 0) then begin + nSize := AnsiBuffLen + 1; + Result := False; + end else begin + WStrPLCopy(lpBuffer, AnsiBuff, nSize); + nSize := WStrLen(lpBuffer); + end; + end; + end; +end; + +function Tnt_ShellExecuteW(hWnd: HWND; Operation, FileName, Parameters, + Directory: PWideChar; ShowCmd: Integer): HINST; +begin + if Win32PlatformIsUnicode then + Result := ShellExecuteW{TNT-ALLOW ShellExecuteW}(hWnd, _PWideCharWithNil(WideString(Operation)), + FileName, Parameters, + Directory, ShowCmd) + else begin + Result := ShellExecuteA{TNT-ALLOW ShellExecuteA}(hWnd, _PAnsiCharWithNil(AnsiString(Operation)), + _PAnsiCharWithNil(AnsiString(FileName)), _PAnsiCharWithNil(AnsiString(Parameters)), + _PAnsiCharWithNil(AnsiString(Directory)), ShowCmd) + end; +end; + +function Tnt_LoadLibraryW(lpLibFileName: PWideChar): HMODULE; +begin + if Win32PlatformIsUnicode then + Result := LoadLibraryW{TNT-ALLOW LoadLibraryW}(lpLibFileName) + else + Result := LoadLibraryA{TNT-ALLOW LoadLibraryA}(PAnsiChar(AnsiString(lpLibFileName))); +end; + +function Tnt_LoadLibraryExW(lpLibFileName: PWideChar; hFile: THandle; dwFlags: DWORD): HMODULE; +begin + if Win32PlatformIsUnicode then + Result := LoadLibraryExW{TNT-ALLOW LoadLibraryExW}(lpLibFileName, hFile, dwFlags) + else + Result := LoadLibraryExA{TNT-ALLOW LoadLibraryExA}(PAnsiChar(AnsiString(lpLibFileName)), hFile, dwFlags); +end; + +function Tnt_CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar; + lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; + bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; + lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; + var lpProcessInformation: TProcessInformation): BOOL; +var + AnsiStartupInfo: TStartupInfoA; +begin + if Win32PlatformIsUnicode then begin + Result := CreateProcessW{TNT-ALLOW CreateProcessW}(lpApplicationName, lpCommandLine, + lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, + lpCurrentDirectory, lpStartupInfo, lpProcessInformation) + end else begin + CopyMemory(@AnsiStartupInfo, @lpStartupInfo, SizeOf(TStartupInfo)); + AnsiStartupInfo.lpReserved := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpReserved)); + AnsiStartupInfo.lpDesktop := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpDesktop)); + AnsiStartupInfo.lpTitle := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpTitle)); + Result := CreateProcessA{TNT-ALLOW CreateProcessA}(_PAnsiCharWithNil(AnsiString(lpApplicationName)), + _PAnsiCharWithNil(AnsiString(lpCommandLine)), + lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, + _PAnsiCharWithNil(AnsiString(lpCurrentDirectory)), AnsiStartupInfo, lpProcessInformation); + end; +end; + +function Tnt_GetCurrencyFormatW(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar; + lpFormat: PCurrencyFmtW; lpCurrencyStr: PWideChar; cchCurrency: Integer): Integer; +const + MAX_ANSI_BUFF_SIZE = 64; // can a currency string actually be larger? +var + AnsiFormat: TCurrencyFmtA; + PAnsiFormat: PCurrencyFmtA; + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetCurrencyFormatW{TNT-ALLOW GetCurrencyFormatW}(Locale, dwFlags, lpValue, + {$IFNDEF FPC} lpFormat {$ELSE} PCurrencyFmt(lpFormat) {$ENDIF}, + lpCurrencyStr, cchCurrency) + else begin + if lpFormat = nil then + PAnsiFormat := nil + else begin + ZeroMemory(@AnsiFormat, SizeOf(AnsiFormat)); + AnsiFormat.NumDigits := lpFormat.NumDigits; + AnsiFormat.LeadingZero := lpFormat.LeadingZero; + AnsiFormat.Grouping := lpFormat.Grouping; + AnsiFormat.lpDecimalSep := PAnsiChar(AnsiString(lpFormat.lpDecimalSep)); + AnsiFormat.lpThousandSep := PAnsiChar(AnsiString(lpFormat.lpThousandSep)); + AnsiFormat.NegativeOrder := lpFormat.NegativeOrder; + AnsiFormat.PositiveOrder := lpFormat.PositiveOrder; + AnsiFormat.lpCurrencySymbol := PAnsiChar(AnsiString(lpFormat.lpCurrencySymbol)); + PAnsiFormat := @AnsiFormat; + end; + SetLength(AnsiBuff, MAX_ANSI_BUFF_SIZE); + SetLength(AnsiBuff, GetCurrencyFormatA{TNT-ALLOW GetCurrencyFormatA}(Locale, dwFlags, + PAnsiChar(AnsiString(lpValue)), PAnsiFormat, PAnsiChar(AnsiBuff), MAX_ANSI_BUFF_SIZE)); + Result := _HandleStringLengthResult(cchCurrency, lpCurrencyStr, AnsiBuff, []); + end; +end; + +function Tnt_CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: PWideChar; + cchCount1: Integer; lpString2: PWideChar; cchCount2: Integer): Integer; +var + WideStr1, WideStr2: WideString; + AnsiStr1, AnsiStr2: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := CompareStringW{TNT-ALLOW CompareStringW}(Locale, dwCmpFlags, lpString1, cchCount1, lpString2, cchCount2) + else begin + WideStr1 := _WStr(lpString1, cchCount1); + WideStr2 := _WStr(lpString2, cchCount2); + if (dwCmpFlags = 0) then begin + // binary comparison + if WideStr1 < WideStr2 then + Result := 1 + else if WideStr1 = WideStr2 then + Result := 2 + else + Result := 3; + end else begin + AnsiStr1 := WideStr1; + AnsiStr2 := WideStr2; + Result := CompareStringA{TNT-ALLOW CompareStringA}(Locale, dwCmpFlags, + PAnsiChar(AnsiStr1), -1, PAnsiChar(AnsiStr2), -1); + end; + end; +end; + +function Tnt_CharUpperW(lpsz: PWideChar): PWideChar; +var + AStr: AnsiString; + WStr: WideString; +begin + if Win32PlatformIsUnicode then + Result := CharUpperW{TNT-ALLOW CharUpperW}(lpsz) + else begin + if HiWord(Cardinal(lpsz)) = 0 then begin + // literal char mode + Result := lpsz; + if IsWideCharMappableToAnsi(WideChar(lpsz)) then begin + AStr := WideChar(lpsz); // single character may be more than one byte + CharUpperA{TNT-ALLOW CharUpperA}(PAnsiChar(AStr)); + WStr := AStr; // should always be single wide char + if Length(WStr) = 1 then + Result := PWideChar(WStr[1]); + end + end else begin + // null-terminated string mode + Result := lpsz; + while lpsz^ <> #0 do begin + lpsz^ := WideChar(Tnt_CharUpperW(PWideChar(lpsz^))); + Inc(lpsz); + end; + end; + end; +end; + +function Tnt_CharUpperBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; +var + i: integer; +begin + if Win32PlatformIsUnicode then + Result := CharUpperBuffW{TNT-ALLOW CharUpperBuffW}(lpsz, cchLength) + else begin + Result := cchLength; + for i := 1 to cchLength do begin + lpsz^ := WideChar(Tnt_CharUpperW(PWideChar(lpsz^))); + Inc(lpsz); + end; + end; +end; + +function Tnt_CharLowerW(lpsz: PWideChar): PWideChar; +var + AStr: AnsiString; + WStr: WideString; +begin + if Win32PlatformIsUnicode then + Result := CharLowerW{TNT-ALLOW CharLowerW}(lpsz) + else begin + if HiWord(Cardinal(lpsz)) = 0 then begin + // literal char mode + Result := lpsz; + if IsWideCharMappableToAnsi(WideChar(lpsz)) then begin + AStr := WideChar(lpsz); // single character may be more than one byte + CharLowerA{TNT-ALLOW CharLowerA}(PAnsiChar(AStr)); + WStr := AStr; // should always be single wide char + if Length(WStr) = 1 then + Result := PWideChar(WStr[1]); + end + end else begin + // null-terminated string mode + Result := lpsz; + while lpsz^ <> #0 do begin + lpsz^ := WideChar(Tnt_CharLowerW(PWideChar(lpsz^))); + Inc(lpsz); + end; + end; + end; +end; + +function Tnt_CharLowerBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; +var + i: integer; +begin + if Win32PlatformIsUnicode then + Result := CharLowerBuffW{TNT-ALLOW CharLowerBuffW}(lpsz, cchLength) + else begin + Result := cchLength; + for i := 1 to cchLength do begin + lpsz^ := WideChar(Tnt_CharLowerW(PWideChar(lpsz^))); + Inc(lpsz); + end; + end; +end; + +function Tnt_GetStringTypeExW(Locale: LCID; dwInfoType: DWORD; + lpSrcStr: PWideChar; cchSrc: Integer; var lpCharType): BOOL; +var + AStr: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetStringTypeExW{TNT-ALLOW GetStringTypeExW}(Locale, dwInfoType, lpSrcStr, cchSrc, lpCharType) + else begin + AStr := _WStr(lpSrcStr, cchSrc); + Result := GetStringTypeExA{TNT-ALLOW GetStringTypeExA}(Locale, dwInfoType, + PAnsiChar(AStr), -1, lpCharType); + end; +end; + +function Win9x_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; +// This function originated by the WINE Project. +// It was translated to Pascal by Francisco Leong. +// It was further modified by Troy Wolbrink. +var + hmem: HGLOBAL; + hrsrc: THandle; + p: PWideChar; + string_num, i: Integer; + block: Integer; +begin + Result := 0; + // Netscape v3 fix... + if (HIWORD(uID) = $FFFF) then begin + uID := UINT(-(Integer(uID))); + end; + // figure block, string_num + block := ((uID shr 4) and $FFFF) + 1; // bits 4 - 19, mask out bits 20 - 31, inc by 1 + string_num := uID and $000F; + // get handle & pointer to string block + hrsrc := FindResource{TNT-ALLOW FindResource}(hInstance, MAKEINTRESOURCE(block), RT_STRING); + if (hrsrc <> 0) then + begin + hmem := LoadResource(hInstance, hrsrc); + if (hmem <> 0) then + begin + p := LockResource(hmem); + // walk the block to the requested string + for i := 0 to string_num - 1 do begin + p := p + Integer(p^) + 1; + end; + Result := Integer(p^); { p points to the length of string } + Inc(p); { p now points to the actual string } + if (lpBuffer <> nil) and (nBufferMax > 0) then + begin + Result := min(nBufferMax - 1, Result); { max length to copy } + if (Result > 0) then begin + CopyMemory(lpBuffer, p, Result * sizeof(WideChar)); + end; + lpBuffer[Result] := WideChar(0); { null terminate } + end; + end; + end; +end; + +function Tnt_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; +begin + if Win32PlatformIsUnicode then + Result := Windows.LoadStringW{TNT-ALLOW LoadStringW}(hInstance, uID, lpBuffer, nBufferMax) + else + Result := Win9x_LoadStringW(hInstance, uID, lpBuffer, nBufferMax); +end; + +function Tnt_InsertMenuItemW(hMenu: HMENU; uItem: DWORD; fByPosition: BOOL; lpmii: TMenuItemInfoW): BOOL; +begin + if Win32PlatformIsUnicode then + Result := InsertMenuItemW{TNT-ALLOW InsertMenuItemW}(hMenu, uItem, fByPosition, + {$IFDEF FPC}@{$ENDIF}lpmii) + else begin + TMenuItemInfoA(lpmii).dwTypeData := PAnsiChar(AnsiString(lpmii.dwTypeData)); + Result := InsertMenuItemA{TNT-ALLOW InsertMenuItemA}(hMenu, uItem, fByPosition, + {$IFDEF FPC}@{$ENDIF}TMenuItemInfoA(lpmii)); + end; +end; + +function Tnt_ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; + var phiconLarge, phiconSmall: HICON; nIcons: UINT): UINT; +begin + if Win32PlatformIsUnicode then + Result := ExtractIconExW{TNT-ALLOW ExtractIconExW}(lpszFile, + nIconIndex, phiconLarge, phiconSmall, nIcons) + else + Result := ExtractIconExA{TNT-ALLOW ExtractIconExA}(PAnsiChar(AnsiString(lpszFile)), + nIconIndex, phiconLarge, phiconSmall, nIcons); +end; + +function Tnt_ExtractAssociatedIconW(hInst: HINST; lpIconPath: PWideChar; + var lpiIcon: Word): HICON; +begin + if Win32PlatformIsUnicode then + Result := ExtractAssociatedIconW{TNT-ALLOW ExtractAssociatedIconW}(hInst, + lpIconPath, {$IFDEF FPC}@{$ENDIF}lpiIcon) + else + Result := ExtractAssociatedIconA{TNT-ALLOW ExtractAssociatedIconA}(hInst, + PAnsiChar(AnsiString(lpIconPath)), {$IFDEF FPC}@{$ENDIF}lpiIcon) +end; + +function Tnt_GetFileVersionInfoSizeW(lptstrFilename: PWideChar; var lpdwHandle: DWORD): DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetFileVersionInfoSizeW{TNT-ALLOW GetFileVersionInfoSizeW}(lptstrFilename, lpdwHandle) + else + Result := GetFileVersionInfoSizeA{TNT-ALLOW GetFileVersionInfoSizeA}(PAnsiChar(AnsiString(lptstrFilename)), lpdwHandle); +end; + +function Tnt_GetFileVersionInfoW(lptstrFilename: PWideChar; dwHandle, dwLen: DWORD; + lpData: Pointer): BOOL; +begin + if Win32PlatformIsUnicode then + Result := GetFileVersionInfoW{TNT-ALLOW GetFileVersionInfoW}(lptstrFilename, dwHandle, dwLen, lpData) + else + Result := GetFileVersionInfoA{TNT-ALLOW GetFileVersionInfoA}(PAnsiChar(AnsiString(lptstrFilename)), dwHandle, dwLen, lpData); +end; + +var + Last_VerQueryValue_String: WideString; + +function Tnt_VerQueryValueW(pBlock: Pointer; lpSubBlock: PWideChar; + var lplpBuffer: Pointer; var puLen: UINT): BOOL; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := VerQueryValueW{TNT-ALLOW VerQueryValueW}(pBlock, lpSubBlock, lplpBuffer, puLen) + else begin + Result := VerQueryValueA{TNT-ALLOW VerQueryValueA}(pBlock, PAnsiChar(AnsiString(lpSubBlock)), lplpBuffer, puLen); + if WideTextPos(VQV_STRINGFILEINFO, lpSubBlock) <> 1 then + else begin + { /StringFileInfo, convert ansi result to unicode } + SetString(AnsiBuff, PAnsiChar(lplpBuffer), puLen); + Last_VerQueryValue_String := AnsiBuff; + lplpBuffer := PWideChar(Last_VerQueryValue_String); + puLen := Length(Last_VerQueryValue_String); + end; + end; +end; + +//--------------------------------------------------------------------------------------- +// Wide functions from Shell32.dll should be loaded dynamically (no stub on early Win95) +//--------------------------------------------------------------------------------------- + +type + TSHFileOperationW = function(var lpFileOp: TSHFileOpStructW): Integer; stdcall; + TSHBrowseForFolderW = function(var lpbi: TBrowseInfoW): PItemIDList; stdcall; + TSHGetPathFromIDListW = function(pidl: PItemIDList; pszPath: PWideChar): BOOL; stdcall; + TSHGetFileInfoW = function(pszPath: PWideChar; dwFileAttributes: DWORD; + var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; stdcall; + +var + Safe_SHFileOperationW: TSHFileOperationW = nil; + Safe_SHBrowseForFolderW: TSHBrowseForFolderW = nil; + Safe_SHGetPathFromIDListW: TSHGetPathFromIDListW = nil; + Safe_SHGetFileInfoW: TSHGetFileInfoW = nil; + +var Shell32DLL: HModule = 0; + +procedure LoadWideShell32Procs; +begin + if Shell32DLL = 0 then begin + Shell32DLL := WinCheckH(Tnt_LoadLibraryW('shell32.dll')); + Safe_SHFileOperationW := WinCheckP(GetProcAddress(Shell32DLL, 'SHFileOperationW')); + Safe_SHBrowseForFolderW := WinCheckP(GetProcAddress(Shell32DLL, 'SHBrowseForFolderW')); + Safe_SHGetPathFromIDListW := WinCheckP(GetProcAddress(Shell32DLL, 'SHGetPathFromIDListW')); + Safe_SHGetFileInfoW := WinCheckP(GetProcAddress(Shell32DLL, 'SHGetFileInfoW')); + end; +end; + +function Tnt_SHFileOperationW(var lpFileOp: TSHFileOpStructW): Integer; +var + AnsiFileOp: TSHFileOpStructA; + MapCount: Integer; + PAnsiMap: PSHNameMappingA; + PWideMap: PSHNameMappingW; + OldPath: WideString; + NewPath: WideString; + i: integer; +begin + if Win32PlatformIsUnicode then begin + LoadWideShell32Procs; + Result := Safe_SHFileOperationW(lpFileOp); + end else begin + AnsiFileOp := TSHFileOpStructA(lpFileOp); + // convert PChar -> PWideChar + if lpFileOp.pFrom = nil then + AnsiFileOp.pFrom := nil + else + AnsiFileOp.pFrom := PAnsiChar(AnsiString(ExtractStringArrayStr(lpFileOp.pFrom))); + if lpFileOp.pTo = nil then + AnsiFileOp.pTo := nil + else + AnsiFileOp.pTo := PAnsiChar(AnsiString(ExtractStringArrayStr(lpFileOp.pTo))); + AnsiFileOp.lpszProgressTitle := PAnsiChar(AnsiString(lpFileOp.lpszProgressTitle)); + Result := SHFileOperationA{TNT-ALLOW SHFileOperationA}( + {$IFDEF FPC}@{$ENDIF}AnsiFileOp); + // return struct results + lpFileOp.fAnyOperationsAborted := AnsiFileOp.fAnyOperationsAborted; + lpFileOp.hNameMappings := nil; + if (AnsiFileOp.hNameMappings <> nil) + and ((FOF_WANTMAPPINGHANDLE and AnsiFileOp.fFlags) <> 0) then begin + // alloc mem + MapCount := PSHNameMappingHeaderA(AnsiFileOp.hNameMappings).cNumOfMappings; + lpFileOp.hNameMappings := + AllocMem(SizeOf({hNameMappings}Cardinal) + SizeOf(TSHNameMappingW) * MapCount); + PSHNameMappingHeaderW(lpFileOp.hNameMappings).cNumOfMappings := MapCount; + // init pointers + PAnsiMap := PSHNameMappingHeaderA(AnsiFileOp.hNameMappings).lpNM; + PWideMap := PSHNameMappingHeaderW(lpFileOp.hNameMappings).lpNM; + for i := 1 to MapCount do begin + // old path + OldPath := Copy(PAnsiMap.pszOldPath, 1, PAnsiMap.cchOldPath); + PWideMap.pszOldPath := WStrNew(PWideChar(OldPath)); + PWideMap.cchOldPath := WStrLen(PWideMap.pszOldPath); + // new path + NewPath := Copy(PAnsiMap.pszNewPath, 1, PAnsiMap.cchNewPath); + PWideMap.pszNewPath := WStrNew(PWideChar(NewPath)); + PWideMap.cchNewPath := WStrLen(PWideMap.pszNewPath); + // next record + Inc(PAnsiMap); + Inc(PWideMap); + end; + end; + end; +end; + +procedure Tnt_SHFreeNameMappings(hNameMappings: THandle); +var + i: integer; + MapCount: Integer; + PWideMap: PSHNameMappingW; +begin + if Win32PlatformIsUnicode then + SHFreeNameMappings{TNT-ALLOW SHFreeNameMappings}(hNameMappings) + else begin + // free strings + MapCount := PSHNameMappingHeaderW(hNameMappings).cNumOfMappings; + PWideMap := PSHNameMappingHeaderW(hNameMappings).lpNM; + for i := 1 to MapCount do begin + WStrDispose(PWideMap.pszOldPath); + WStrDispose(PWideMap.pszNewPath); + Inc(PWideMap); + end; + // free struct + FreeMem(Pointer(hNameMappings)); + end; +end; + +function Tnt_SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; +var + AnsiInfo: TBrowseInfoA; + AnsiBuffer: array[0..MAX_PATH] of AnsiChar; +begin + if Win32PlatformIsUnicode then begin + LoadWideShell32Procs; + Result := Safe_SHBrowseForFolderW(lpbi); + end else begin + AnsiInfo := TBrowseInfoA(lpbi); + AnsiInfo.lpszTitle := PAnsiChar(AnsiString(lpbi.lpszTitle)); + if lpbi.pszDisplayName <> nil then + AnsiInfo.pszDisplayName := AnsiBuffer; + Result := SHBrowseForFolderA{TNT-ALLOW SHBrowseForFolderA}( + {$IFDEF FPC}@{$ENDIF}AnsiInfo); + if lpbi.pszDisplayName <> nil then + WStrPCopy(lpbi.pszDisplayName, AnsiInfo.pszDisplayName); + lpbi.iImage := AnsiInfo.iImage; + end; +end; + +function Tnt_SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PWideChar): BOOL; +var + AnsiPath: AnsiString; +begin + if Win32PlatformIsUnicode then begin + LoadWideShell32Procs; + Result := Safe_SHGetPathFromIDListW(pidl, pszPath); + end else begin + SetLength(AnsiPath, MAX_PATH); + Result := SHGetPathFromIDListA{TNT-ALLOW SHGetPathFromIDListA}(pidl, PAnsiChar(AnsiPath)); + if Result then + WStrPCopy(pszPath, PAnsiChar(AnsiPath)) + end; +end; + +function Tnt_SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; + var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; +var + SHFileInfoA: TSHFileInfoA; +begin + if Win32PlatformIsUnicode then begin + LoadWideShell32Procs; + Result := Safe_SHGetFileInfoW(pszPath, dwFileAttributes, psfi, cbFileInfo, uFlags) + end else begin + Result := SHGetFileInfoA{TNT-ALLOW SHGetFileInfoA}(PAnsiChar(AnsiString(pszPath)), + dwFileAttributes, SHFileInfoA, SizeOf(TSHFileInfoA), uFlags); + // update pfsi... + ZeroMemory(@psfi, SizeOf(TSHFileInfoW)); + psfi.hIcon := SHFileInfoA.hIcon; + psfi.iIcon := SHFileInfoA.iIcon; + psfi.dwAttributes := SHFileInfoA.dwAttributes; + WStrPLCopy(psfi.szDisplayName, SHFileInfoA.szDisplayName, MAX_PATH); + WStrPLCopy(psfi.szTypeName, SHFileInfoA.szTypeName, 80); + end; +end; + + +function Tnt_Is_IntResource(ResStr: LPCWSTR): Boolean; +begin + Result := HiWord(Cardinal(ResStr)) = 0; +end; + +function LANGIDFROMLCID(lcid: LCID): WORD; +begin + Result := LoWord(lcid); +end; + +function MAKELANGID(usPrimaryLanguage, usSubLanguage: WORD): WORD; +begin + Result := (usSubLanguage shl 10) or usPrimaryLanguage; +end; + +function MAKELCID(wLanguageID: WORD; wSortID: WORD = SORT_DEFAULT): LCID; +begin + Result := MakeLong(wLanguageID, wSortID); +end; + +function PRIMARYLANGID(lgid: WORD): WORD; +begin + Result := lgid and $03FF; +end; + +function SORTIDFROMLCID(lcid: LCID): WORD; +begin + Result := HiWord(lcid); +end; + +function SUBLANGID(lgid: WORD): WORD; +begin + Result := lgid shr 10; +end; + +initialization + +finalization + if Shell32DLL <> 0 then + FreeLibrary(Shell32DLL); + +end. diff --git a/cmake/src/lib/bass/bass.chm b/cmake/src/lib/bass/bass.chm Binary files differindex 79ab64a2..8071fb0b 100644 --- a/cmake/src/lib/bass/bass.chm +++ b/cmake/src/lib/bass/bass.chm diff --git a/cmake/src/lib/bass/bass.txt b/cmake/src/lib/bass/bass.txt index cdaa7bf0..381519e1 100644 --- a/cmake/src/lib/bass/bass.txt +++ b/cmake/src/lib/bass/bass.txt @@ -1,5 +1,5 @@ BASS 2.4 -Copyright (c) 1999-2008 Un4seen Developments Ltd. All rights reserved. +Copyright (c) 1999-2009 Un4seen Developments Ltd. All rights reserved. Files that you should have found in the BASS package ==================================================== @@ -136,8 +136,8 @@ VB\ Visual Basic API and examples... MODLIVESPEC.BAS MULTI\ Multiple device example PRJMULTI.VBP - PRJMULTI.FRM - PRJDEVICE.FRM + FRMMULTI.FRM + FRMDEVICE.FRM NETRADIO\ Internet streaming example PRJNETRADIO.VBP FRMNETRADIO.FRM @@ -199,6 +199,8 @@ DELPHI\ Delphi API and examples... LIVEFX.DPR UNIT1.PAS UNIT1.DFM + LIVESPEC\ "Live" version of spectrum analyser example + LIVESPEC.DPR MULTI\ Multiple device example MULTI.DPR UNIT1.PAS @@ -229,6 +231,10 @@ DELPHI\ Delphi API and examples... SPEAKERS.DPR UNIT1.PAS UNIT1.DFM + SPECTRUM\ Spectrum analyser example + SPECTRUM.DPR + UNIT1.PAS + COMMON.INC STREAMTEST\ User stream example STREAMTEST.DPR STMAIN.PAS @@ -281,9 +287,12 @@ CUSTLOOP\ Custom looping example MAKEFILE DSPTEST\ DSP example DSPTEST.C - DSPTEST.RC MAKEFILE DSPTEST.NIB +FXTEST\ DX8 effect example + FXTEST.C + MAKEFILE + FXTEST.NIB LIVESPEC\ "Live" version of spectrum analyser example LIVESPEC.C MAKEFILE @@ -567,6 +576,73 @@ There are of course bug fixes and other little improvements made along the way too! To make upgrading simpler, all functions affected by a change to the BASS interface are listed. +2.4.5 - 18/12/2009 +------------------ +* Support for little-endian AIFF files + BASS_StreamCreateFile/User/Url + BASS_SampleLoad +* Support for 64-bit floating-point WAVE/AIFF files + BASS_StreamCreateFile/User/Url + BASS_SampleLoad +* Input volume retrieval failure results in a reading of -1 instead of 1 + BASS_RecordGetInput + RECTEST example updated +* Input volume support on OSX + BASS_RecordSetInput + BASS_RecordGetInput + RECTEST example updated +* Fix for deferred input settings on Vista + BASS_RecordSetInput +* Windows MP3 codec given preference over other installed MP3 codecs (MP3-FREE version) + BASS_StreamCreateFile/User/Url + BASS_SampleLoad + +2.4.4 - 13/10/2009 +------------------ +* RIFF/BWF "radio traffic" tag retrieval + BASS_TAG_RIFF_CART (BASS_ChannelGetTags type) + TAG_CART structure +* Support for ID3v2 tags in RIFF/WAVE/AIFF files ("ID3 " chunk) + BASS_TAG_ID3V2 (BASS_ChannelGetTags type) +* Pushed fractional samples are refused rather than discarded + BASS_StreamPutData +* DX8 effect emulation on OSX + BASS_FX_DX8_CHORUS/DISTORTION/ECHO/FLANGER/PARAMEQ/REVERB (BASS_ChannelSetFX types) + FXTEST example added +* UTF-16 support on OSX + BASS_UNICODE (BASS_StreamCreateFile/SampleLoad/MusicLoad/PluginLoad flag) + +2.4.3 - 8/5/2009 +---------------- +* MOD order list retrieval + BASS_TAG_MUSIC_ORDERS (BASS_ChannelGetTags type) +* Support for ID3v2 tags in RIFF/WAVE files ("id3 " chunk) + BASS_TAG_ID3V2 (BASS_ChannelGetTags type) +* Improved position reporting precision on Vista + BASS_ChannelGetPosition +* Length retrieval when streaming in blocks (BASS_STREAM_BLOCK) + BASS_ChannelGetLength +* Support for CoreAudio codecs on OSX + BASS_StreamCreateFile/User + BASS_SampleLoad + BASS_TAG_CA_CODEC (BASS_ChannelGetTags type) + TAG_CA_CODEC structure +* 3D algorithm option support on OSX + BASS_CONFIG_3DALGORITHM (BASS_SetConfig option) + +2.4.2 - 18/9/2008 +----------------- +* RF64 support + BASS_StreamCreateFile/User +* RIFF/BWF "Broadcast Audio Extension" tag retrieval + BASS_TAG_RIFF_BEXT (BASS_ChannelGetTags type) + TAG_BEXT structure +* ID3v1 tag structure + TAG_ID3 structure +* Multiple simultaneous recordings per device on Vista & OSX (as on XP) + BASS_RecordStart +* DX8 effect parameter defaults updated/corrected in documentation + 2.4 - 2/4/2008 -------------- * "Push" streaming @@ -588,7 +664,7 @@ change to the BASS interface are listed. BASS_FILEPOS_BUFFER (BASS_StreamGetFilePosition mode) * Sinc interpolated MOD music mixing BASS_MUSIC_SINCINTER (BASS_MusicLoad flag) -* MO3 v2.4 support +* MO3 2.4 support BASS_MusicLoad * MOD orders positioning incorporated into channel functions BASS_ChannelGetLength @@ -637,7 +713,7 @@ change to the BASS interface are listed. BASS_ChannelSetFlags *removed* SPEAKERS example updated * 256 sample FFT - BASS_DATA_FFT256 (BASS_ChannelGetDat flag) + BASS_DATA_FFT256 (BASS_ChannelGetData flag) * Channel locking to prevent access by other threads BASS_ChannelLock * Manual channel buffer updating @@ -730,7 +806,7 @@ change to the BASS interface are listed. BASS_ChannelStop * Sample channels created paused to prevent overriding before playback BASS_SampleGetChannel -* Separate "MP3-FREE" version using Windows/OSX MP3 decoder +* Separate "MP3-FREE" version using the OS's MP3 decoder BASS_CONFIG_MP3_CODEC *removed* 2.3.0.1 - 12/6/2006 @@ -1458,7 +1534,7 @@ change to the BASS interface are listed. 0.8 - 24/1/2000 --------------- -* Improved MP3 performance on P2/K6 and above CPUs - fast! +* Improved MP3 performance on P2/K6 and above CPUs * User DSP functions on streams and MOD musics BASS_ChannelSetDSP BASS_ChannelRemoveDSP @@ -1645,7 +1721,7 @@ API/Sample contributors Visual Basic: Adam Hoult, Hendrik Knaepen, Arthur Aminov, Peter Hebels Delphi: Titus Miloi, Rogier Timmermans, Alessandro Cappellozza, - Jesse Naranjo, Chris Troesken + Jesse Naranjo, Chris Troesken, Evgeny Melnikov MASM: Octavian Chis diff --git a/cmake/src/lib/bass/delphi/bass.pas b/cmake/src/lib/bass/delphi/bass.pas index 85d10355..e87b05f5 100644 --- a/cmake/src/lib/bass/delphi/bass.pas +++ b/cmake/src/lib/bass/delphi/bass.pas @@ -1,12 +1,14 @@ { BASS 2.4 Delphi unit - Copyright (c) 1999-2008 Un4seen Developments Ltd. + Copyright (c) 1999-2009 Un4seen Developments Ltd. See the BASS.CHM file for more detailed documentation How to install -------------- Copy BASS.PAS to the \LIB subdirectory of your Delphi path or your project dir + + NOTE: Delphi 2009 users should use the BASS_UNICODE flag where possible } unit Bass; @@ -24,12 +26,6 @@ interface {$DEFINE DLL_CDECL} {$ENDIF} -// IMPORTANT: define BASS_242 when switching to 2.4.2(.1) as -// BASS_RECORDINFO.driver was removed. -// Otherwise BASS_RECORDINFO.freq will point to a wrong location. -{$UNDEF BASS_242} - - {$IFDEF MSWINDOWS} uses Windows; @@ -40,7 +36,7 @@ const BASSVERSIONTEXT = '2.4'; // Use these to test for error from functions that return a DWORD or QWORD - DW_ERROR = Cardinal(-1); // -1 (DWORD) + DW_ERROR = LongWord(-1); // -1 (DWORD) QW_ERROR = Int64(-1); // -1 (QWORD) // Error codes returned by BASS_ErrorGetCode() @@ -100,6 +96,9 @@ const BASS_CONFIG_MUSIC_VIRTUAL = 22; BASS_CONFIG_VERIFY = 23; BASS_CONFIG_UPDATETHREADS = 24; + {$IFDEF LINUX} + BASS_CONFIG_DEV_BUFFER = 27; + {$ENDIF} // BASS_SetConfigPtr options BASS_CONFIG_NET_AGENT = 16; @@ -113,6 +112,9 @@ const BASS_DEVICE_CPSPEAKERS = 1024; // detect speakers via Windows control panel BASS_DEVICE_SPEAKERS = 2048; // force enabling of speaker assignment BASS_DEVICE_NOSPEAKER = 4096; // ignore speaker arrangement + {$IFDEF LINUX} + BASS_DEVICE_DMIX = 8192; // use "dmix" (shared) output + {$ENDIF} // DirectSound interfaces (for use with BASS_GetDSoundObject) BASS_OBJECT_DS = 1; // IDirectSound @@ -229,6 +231,7 @@ const BASS_CTYPE_STREAM_MP2 = $10004; BASS_CTYPE_STREAM_MP3 = $10005; BASS_CTYPE_STREAM_AIFF = $10006; + BASS_CTYPE_STREAM_CA = $10007; BASS_CTYPE_STREAM_WAV = $40000; // WAVE flag, LOWORD=codec BASS_CTYPE_STREAM_WAV_PCM = $50001; BASS_CTYPE_STREAM_WAV_FLOAT = $50003; @@ -250,7 +253,6 @@ const BASS_3DALG_FULL = 2; BASS_3DALG_LIGHT = 3; -{$IFDEF MSWINDOWS} // EAX environments, use with BASS_SetEAXParameters EAX_ENVIRONMENT_GENERIC = 0; EAX_ENVIRONMENT_PADDEDCELL = 1; @@ -280,7 +282,6 @@ const EAX_ENVIRONMENT_PSYCHOTIC = 25; // total number of environments EAX_ENVIRONMENT_COUNT = 26; -{$ENDIF} BASS_STREAMPROC_END = $80000000; // end of user stream flag @@ -359,17 +360,21 @@ const BASS_TAG_META = 5; // ICY metadata : ANSI string BASS_TAG_VENDOR = 9; // OGG encoder : UTF-8 string BASS_TAG_LYRICS3 = 10; // Lyric3v2 tag : ASCII string + BASS_TAG_CA_CODEC = 11; // CoreAudio codec info : TAG_CA_CODEC structure BASS_TAG_RIFF_INFO = $100; // RIFF "INFO" tags : series of null-terminated ANSI strings - BASS_TAG_RIFF_BEXT = $101; // RIFF/BWF Broadcast Audio Extension tags : TAG_BEXT structure + BASS_TAG_RIFF_BEXT = $101; // RIFF/BWF "bext" tags : TAG_BEXT structure + BASS_TAG_RIFF_CART = $102; // RIFF/BWF "cart" tags : TAG_CART structure BASS_TAG_MUSIC_NAME = $10000; // MOD music name : ANSI string BASS_TAG_MUSIC_MESSAGE = $10001; // MOD message : ANSI string + BASS_TAG_MUSIC_ORDERS = $10002; // MOD order list : BYTE array of pattern numbers BASS_TAG_MUSIC_INST = $10100; // + instrument #, MOD instrument name : ANSI string BASS_TAG_MUSIC_SAMPLE = $10300; // + sample #, MOD sample name : ANSI string // BASS_ChannelGetLength/GetPosition/SetPosition modes BASS_POS_BYTE = 0; // byte position BASS_POS_MUSIC_ORDER = 1; // order.row position, MAKELONG(order,row) - + BASS_POS_DECODE = $10000000; // flag: get the decoding (not playing) position + // BASS_RecordSetInput flags BASS_INPUT_OFF = $10000; BASS_INPUT_ON = $20000; @@ -404,10 +409,10 @@ const BASS_DX8_PHASE_180 = 4; type - DWORD = cardinal; + DWORD = LongWord; BOOL = LongBool; FLOAT = Single; - QWORD = int64; // 64-bit (replace "int64" with "comp" if using Delphi 3) + QWORD = Int64; HMUSIC = DWORD; // MOD music handle HSAMPLE = DWORD; // sample handle @@ -449,9 +454,6 @@ type formats: DWORD; // supported standard formats (WAVE_FORMAT_xxx flags) inputs: DWORD; // number of inputs singlein: BOOL; // only 1 input can be set at a time - {$IFNDEF BASS_242} - driver: PChar; // driver - {$ENDIF} freq: DWORD; // current input rate (OSX only) end; @@ -485,7 +487,7 @@ type origres: DWORD; // original resolution plugin: HPLUGIN; // plugin sample: HSAMPLE; // sample - filename: PAnsiChar; // filename + filename: PChar; // filename end; BASS_PLUGINFORM = record @@ -534,7 +536,7 @@ type genre: Byte; end; - // BWF Broadcast Audio Extension tag structure + // BWF "bext" tag structure TAG_BEXT = record Description: Array[0..255] of AnsiChar; // description Originator: Array[0..31] of AnsiChar; // name of the originator @@ -548,6 +550,42 @@ type CodingHistory: Array of AnsiChar; // history end; + // BWF "cart" tag structures + TAG_CART_TIMER = record + dwUsage: DWORD; // FOURCC timer usage ID + dwValue: DWORD; // timer value in samples from head + end; + + TAG_CART = record + Version: array [0..3] of AnsiChar; // version of the data structure + Title: array [0..63] of AnsiChar; // title of cart audio sequence + Artist: array [0..63] of AnsiChar; // artist or creator name + CutID: array [0..63] of AnsiChar; // cut number identification + ClientID: array [0..63] of AnsiChar; // client identification + Category: array [0..63] of AnsiChar; // category ID, PSA, NEWS, etc + Classification: array [0..63] of AnsiChar; // classification or auxiliary key + OutCue: array [0..63] of AnsiChar; // out cue text + StartDate: array [0..9] of AnsiChar; // yyyy-mm-dd + StartTime: array [0..7] of AnsiChar; // hh:mm:ss + EndDate: array [0..9] of AnsiChar; // yyyy-mm-dd + EndTime: array [0..7] of AnsiChar; // hh:mm:ss + ProducerAppID: array [0..63] of AnsiChar; // name of vendor or application + ProducerAppVersion: array [0..63] of AnsiChar; // version of producer application + UserDef: array [0..63] of AnsiChar; // user defined text + dwLevelReference: DWORD; // sample value for 0 dB reference + PostTimer: array [0..7] of TAG_CART_TIMER; // 8 time markers after head + Reserved: array [0..275] of AnsiChar; + URL: array [0..1023] of AnsiChar; // uniform resource locator + TagText: array [0..0] of AnsiChar; // free form text for scripts or tags + end; + + // CoreAudio codec info structure + TAG_CA_CODEC = record + ftype: DWORD; // file format + atype: DWORD; // audio format + name: {const} PAnsiChar; // description + end; + BASS_DX8_CHORUS = record fWetDryMix: FLOAT; fDepth: FLOAT; @@ -599,14 +637,14 @@ type end; BASS_DX8_I3DL2REVERB = record - lRoom: Longint; // [-10000, 0] default: -1000 mB - lRoomHF: Longint; // [-10000, 0] default: 0 mB + lRoom: LongInt; // [-10000, 0] default: -1000 mB + lRoomHF: LongInt; // [-10000, 0] default: 0 mB flRoomRolloffFactor: FLOAT; // [0.0, 10.0] default: 0.0 flDecayTime: FLOAT; // [0.1, 20.0] default: 1.49s flDecayHFRatio: FLOAT; // [0.1, 2.0] default: 0.83 - lReflections: Longint; // [-10000, 1000] default: -2602 mB + lReflections: LongInt; // [-10000, 1000] default: -2602 mB flReflectionsDelay: FLOAT; // [0.0, 0.3] default: 0.007 s - lReverb: Longint; // [-10000, 2000] default: 200 mB + lReverb: LongInt; // [-10000, 2000] default: 200 mB flReverbDelay: FLOAT; // [0.0, 0.1] default: 0.011 s flDiffusion: FLOAT; // [0.0, 100.0] default: 100.0 % flDensity: FLOAT; // [0.0, 100.0] default: 100.0 % @@ -695,6 +733,9 @@ const {$IFDEF MSWINDOWS} bassdll = 'bass.dll'; {$ENDIF} +{$IFDEF LINUX} + bassdll = 'bass'; +{$ENDIF} {$IFDEF DARWIN} bassdll = 'libbass.dylib'; {$linklib libbass} @@ -705,12 +746,12 @@ function BASS_GetConfig(option: DWORD): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$END function BASS_SetConfigPtr(option: DWORD; value: Pointer): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_GetConfigPtr(option: DWORD): Pointer; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_GetVersion: DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ErrorGetCode: Integer; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; +function BASS_ErrorGetCode: LongInt; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_GetDeviceInfo(device: DWORD; var info: BASS_DEVICEINFO): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; {$IFDEF MSWINDOWS} -function BASS_Init(device: Integer; freq, flags: DWORD; win: HWND; clsid: PGUID): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; +function BASS_Init(device: LongInt; freq, flags: DWORD; win: HWND; clsid: PGUID): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; {$ELSE} -function BASS_Init(device: Integer; freq, flags: DWORD; win: Pointer; clsid: Pointer): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; +function BASS_Init(device: LongInt; freq, flags: DWORD; win: Pointer; clsid: Pointer): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; {$ENDIF} function BASS_SetDevice(device: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_GetDevice: DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; @@ -727,7 +768,7 @@ function BASS_Pause: BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL function BASS_SetVolume(volume: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_GetVolume: FLOAT; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_PluginLoad(filename: PAnsiChar; flags: DWORD): HPLUGIN; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; +function BASS_PluginLoad(filename: PChar; flags: DWORD): HPLUGIN; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_PluginFree(handle: HPLUGIN): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_PluginGetInfo(handle: HPLUGIN): PBASS_PLUGININFO; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; @@ -737,7 +778,7 @@ function BASS_Set3DPosition(var pos, vel, front, top: BASS_3DVECTOR): BOOL; {$IF function BASS_Get3DPosition(var pos, vel, front, top: BASS_3DVECTOR): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; procedure BASS_Apply3D; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; {$IFDEF MSWINDOWS} -function BASS_SetEAXParameters(env: Integer; vol, decay, damp: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; +function BASS_SetEAXParameters(env: LongInt; vol, decay, damp: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_GetEAXParameters(var env: DWORD; var vol, decay, damp: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; {$ENDIF} @@ -765,14 +806,14 @@ function BASS_StreamPutData(handle: HSTREAM; buffer: Pointer; length: DWORD): DW function BASS_StreamPutFileData(handle: HSTREAM; buffer: Pointer; length: DWORD): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_RecordGetDeviceInfo(device: DWORD; var info: BASS_DEVICEINFO): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_RecordInit(device: Integer):BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; +function BASS_RecordInit(device: LongInt):BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_RecordSetDevice(device: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_RecordGetDevice: DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_RecordFree: BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_RecordGetInfo(var info: BASS_RECORDINFO): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_RecordGetInputName(input: Integer): PAnsiChar; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_RecordSetInput(input: Integer; flags: DWORD; volume: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_RecordGetInput(input: Integer; var volume: FLOAT): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; +function BASS_RecordGetInputName(input: LongInt): PAnsiChar; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; +function BASS_RecordSetInput(input: LongInt; flags: DWORD; volume: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; +function BASS_RecordGetInput(input: LongInt; var volume: FLOAT): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_RecordStart(freq, chans, flags: DWORD; proc: RECORDPROC; user: Pointer): HRECORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_ChannelBytes2Seconds(handle: DWORD; pos: QWORD): Double; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF}external bassdll; @@ -792,7 +833,7 @@ function BASS_ChannelSetAttribute(handle, attrib: DWORD; value: FLOAT): BOOL; {$ function BASS_ChannelGetAttribute(handle, attrib: DWORD; var value: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_ChannelSlideAttribute(handle, attrib: DWORD; value: FLOAT; time: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_ChannelIsSliding(handle, attrib: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF}external bassdll; -function BASS_ChannelSet3DAttributes(handle: DWORD; mode: Integer; min, max: FLOAT; iangle, oangle, outvol: Integer): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; +function BASS_ChannelSet3DAttributes(handle: DWORD; mode: LongInt; min, max: FLOAT; iangle, oangle, outvol: LongInt): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_ChannelGet3DAttributes(handle: DWORD; var mode: DWORD; var min, max: FLOAT; var iangle, oangle, outvol: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_ChannelSet3DPosition(handle: DWORD; var pos, orient, vel: BASS_3DVECTOR): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_ChannelGet3DPosition(handle: DWORD; var pos, orient, vel: BASS_3DVECTOR): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; @@ -803,11 +844,11 @@ function BASS_ChannelGetLevel(handle: DWORD): DWORD; {$IFDEF DLL_STDCALL}stdcall function BASS_ChannelGetData(handle: DWORD; buffer: Pointer; length: DWORD): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_ChannelSetSync(handle: DWORD; type_: DWORD; param: QWORD; proc: SYNCPROC; user: Pointer): HSYNC; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_ChannelRemoveSync(handle: DWORD; sync: HSYNC): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelSetDSP(handle: DWORD; proc: DSPPROC; user: Pointer; priority: Integer): HDSP; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; +function BASS_ChannelSetDSP(handle: DWORD; proc: DSPPROC; user: Pointer; priority: LongInt): HDSP; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_ChannelRemoveDSP(handle: DWORD; dsp: HDSP): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_ChannelSetLink(handle, chan: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_ChannelRemoveLink(handle, chan: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelSetFX(handle, type_: DWORD; priority: Integer): HFX; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; +function BASS_ChannelSetFX(handle, type_: DWORD; priority: LongInt): HFX; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_ChannelRemoveFX(handle: DWORD; fx: HFX): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; function BASS_FXSetParameters(handle: HFX; par: Pointer): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; @@ -817,7 +858,7 @@ function BASS_FXReset(handle: HFX): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$ function BASS_SPEAKER_N(n: DWORD): DWORD; {$IFDEF MSWINDOWS} -function BASS_SetEAXPreset(env: Integer): BOOL; +function BASS_SetEAXPreset(env: LongInt): BOOL; { This function is defined in the implementation part of this unit. It is not part of BASS.DLL but an extra function which makes it easier @@ -834,7 +875,7 @@ begin end; {$IFDEF MSWINDOWS} -function BASS_SetEAXPreset(env: Integer): BOOL; +function BASS_SetEAXPreset(env: LongInt): BOOL; begin case (env) of EAX_ENVIRONMENT_GENERIC: diff --git a/cmake/src/lib/ctypes/ctypes.pas b/cmake/src/lib/ctypes/ctypes.pas index 6cdf77fc..694552dc 100644 --- a/cmake/src/lib/ctypes/ctypes.pas +++ b/cmake/src/lib/ctypes/ctypes.pas @@ -1,72 +1,72 @@ -{
- This file is part of the Free Pascal run time library.
- Copyright (c) 2004 by Marco van de Voort, member of the
- Free Pascal development team
-
- Implements C types for in header conversions
-
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
-
- **********************************************************************}
-
-unit ctypes;
-
-interface
-
-type
- qword = int64; // Keep h2pas "uses ctypes" headers working with delphi.
-
- { the following type definitions are compiler dependant }
- { and system dependant }
-
- cint8 = shortint; pcint8 = ^cint8;
- cuint8 = byte; pcuint8 = ^cuint8;
- cchar = cint8; pcchar = ^cchar;
- cschar = cint8; pcschar = ^cschar;
- cuchar = cuint8; pcuchar = ^cuchar;
-
- cint16 = smallint; pcint16 = ^cint16;
- cuint16 = word; pcuint16 = ^cuint16;
- cshort = cint16; pcshort = ^cshort;
- csshort = cint16; pcsshort = ^csshort;
- cushort = cuint16; pcushort = ^cushort;
-
- cint32 = longint; pcint32 = ^cint32;
- cuint32 = longword; pcuint32 = ^cuint32;
- cint = cint32; pcint = ^cint; { minimum range is : 32-bit }
- csint = cint32; pcsint = ^csint; { minimum range is : 32-bit }
- cuint = cuint32; pcuint = ^cuint; { minimum range is : 32-bit }
- csigned = cint; pcsigned = ^csigned;
- cunsigned = cuint; pcunsigned = ^cunsigned;
-
- cint64 = int64; pcint64 = ^cint64;
- cuint64 = qword; pcuint64 = ^cuint64;
- clonglong = cint64; pclonglong = ^clonglong;
- cslonglong = cint64; pcslonglong = ^cslonglong;
- culonglong = cuint64; pculonglong = ^culonglong;
-
- cbool = longbool; pcbool = ^cbool;
-
-{$if defined(cpu64) and not(defined(win64) and defined(cpux86_64))}
- clong = int64; pclong = ^clong;
- cslong = int64; pcslong = ^cslong;
- culong = qword; pculong = ^culong;
-{$else}
- clong = longint; pclong = ^clong;
- cslong = longint; pcslong = ^cslong;
- culong = cardinal; pculong = ^culong;
-{$ifend}
-
- cfloat = single; pcfloat = ^cfloat;
- cdouble = double; pcdouble = ^cdouble;
- clongdouble = extended; pclongdouble = ^clongdouble;
-
-implementation
-
-end.
+{ + This file is part of the Free Pascal run time library. + Copyright (c) 2004 by Marco van de Voort, member of the + Free Pascal development team + + Implements C types for in header conversions + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + + **********************************************************************} + +unit ctypes; + +interface + +type + qword = int64; // Keep h2pas "uses ctypes" headers working with delphi. + + { the following type definitions are compiler dependant } + { and system dependant } + + cint8 = shortint; pcint8 = ^cint8; + cuint8 = byte; pcuint8 = ^cuint8; + cchar = cint8; pcchar = ^cchar; + cschar = cint8; pcschar = ^cschar; + cuchar = cuint8; pcuchar = ^cuchar; + + cint16 = smallint; pcint16 = ^cint16; + cuint16 = word; pcuint16 = ^cuint16; + cshort = cint16; pcshort = ^cshort; + csshort = cint16; pcsshort = ^csshort; + cushort = cuint16; pcushort = ^cushort; + + cint32 = longint; pcint32 = ^cint32; + cuint32 = longword; pcuint32 = ^cuint32; + cint = cint32; pcint = ^cint; { minimum range is : 32-bit } + csint = cint32; pcsint = ^csint; { minimum range is : 32-bit } + cuint = cuint32; pcuint = ^cuint; { minimum range is : 32-bit } + csigned = cint; pcsigned = ^csigned; + cunsigned = cuint; pcunsigned = ^cunsigned; + + cint64 = int64; pcint64 = ^cint64; + cuint64 = qword; pcuint64 = ^cuint64; + clonglong = cint64; pclonglong = ^clonglong; + cslonglong = cint64; pcslonglong = ^cslonglong; + culonglong = cuint64; pculonglong = ^culonglong; + + cbool = longbool; pcbool = ^cbool; + +{$if defined(cpu64) and not(defined(win64) and defined(cpux86_64))} + clong = int64; pclong = ^clong; + cslong = int64; pcslong = ^cslong; + culong = qword; pculong = ^culong; +{$else} + clong = longint; pclong = ^clong; + cslong = longint; pcslong = ^cslong; + culong = cardinal; pculong = ^culong; +{$ifend} + + cfloat = single; pcfloat = ^cfloat; + cdouble = double; pcdouble = ^cdouble; + clongdouble = extended; pclongdouble = ^clongdouble; + +implementation + +end. diff --git a/cmake/src/lib/ffmpeg/avcodec.pas b/cmake/src/lib/ffmpeg/avcodec.pas index ceb1b7f0..7e55e13a 100644 --- a/cmake/src/lib/ffmpeg/avcodec.pas +++ b/cmake/src/lib/ffmpeg/avcodec.pas @@ -27,13 +27,9 @@ (* * Conversion of libavcodec/avcodec.h * Min. version: 51.16.0, revision 6577, Sat Oct 7 15:30:46 2006 UTC - * Max. version: 52.11.0, revision 16912, Sun Feb 1 02:00:19 2009 UTC + * Max. version: 52.67.2, revision 23191, Wed May 19 19:30 2010 CET + * *) -{ - * update to - * Max. version: 52.31.2, Sar Jun 13 22:05:00 2009 UTC - * MiSchi -} unit avcodec; @@ -63,9 +59,34 @@ uses UConfig; const + (* + * IMPORTANT: The official FFmpeg C headers change very quickly. Often some + * of the data structures are changed so that they become incompatible with + * older header files. The Pascal headers have to be adjusted to those changes, + * otherwise the application might crash randomly or strange bugs (not + * necessarily related to video or audio due to buffer overflows etc.) might + * occur. + * + * In the past users reported problems with USDX that took hours to fix and + * the problem was an unsupported version of FFmpeg. So we decided to disable + * support for future versions of FFmpeg until the headers are revised by us + * for that version as they otherwise most probably will break USDX. + * + * If the headers do not yet support your FFmpeg version you may want to + * adjust the max. version numbers manually but please note: it may work but + * in many cases it does not. The USDX team does NOT PROVIDE ANY SUPPORT + * for the game if the MAX. VERSION WAS CHANGED. + * + * The only safe way to support new versions of FFmpeg is to add the changes + * of the FFmpeg git repository C headers to the Pascal headers. + * You can accelerate this process by posting a patch with the git changes + * translated to Pascal to our bug tracker (please join our IRC chat before + * you start working on it). Simply adjusting the max. versions is NOT a valid + * fix. + *) (* Max. supported version by this header *) LIBAVCODEC_MAX_VERSION_MAJOR = 52; - LIBAVCODEC_MAX_VERSION_MINOR = 31; + LIBAVCODEC_MAX_VERSION_MINOR = 67; LIBAVCODEC_MAX_VERSION_RELEASE = 2; LIBAVCODEC_MAX_VERSION = (LIBAVCODEC_MAX_VERSION_MAJOR * VERSION_MAJOR) + (LIBAVCODEC_MAX_VERSION_MINOR * VERSION_MINOR) + @@ -173,7 +194,9 @@ type CODEC_ID_QDRAW, CODEC_ID_VIXL, CODEC_ID_QPEG, +{$IF LIBAVCODEC_VERSION_MAJOR < 53} CODEC_ID_XVID, +{$IFEND} CODEC_ID_PNG, CODEC_ID_PPM, CODEC_ID_PBM, @@ -260,6 +283,33 @@ type {$IF LIBAVCODEC_VERSION >= 52031002} // >= 52.31.2 CODEC_ID_MAD, {$IFEND} +{$IF LIBAVCODEC_VERSION >= 52037000} // >= 52.37.0 + CODEC_ID_FRWU, +{$IFEND} +{$IF LIBAVCODEC_VERSION >= 52041000} // >= 52.41.0 + CODEC_ID_FLASHSV2, +{$IFEND} +{$IF LIBAVCODEC_VERSION >= 52043000} // >= 52.43.0 + CODEC_ID_CDGRAPHICS, + CODEC_ID_R210, +{$IFEND} + CODEC_ID_ANM, +{$IF LIBAVCODEC_VERSION >= 52049000} // >= 52.49.0 + CODEC_ID_BINKVIDEO, +{$IFEND} +{$IF LIBAVCODEC_VERSION >= 52052000} // >= 52.52.0 + CODEC_ID_IFF_ILBM, + CODEC_ID_IFF_BYTERUN1, +{$IFEND} +{$IF LIBAVCODEC_VERSION >= 52058000} // >= 52.58.0 + CODEC_ID_KGV1, +{$IFEND} +{$IF LIBAVCODEC_VERSION >= 52062000} // >= 52.62.0 + CODEC_ID_YOP, +{$IFEND} +{$IF LIBAVCODEC_VERSION >= 52067002} // >= 52.67.2 + CODEC_ID_VP8, +{$IFEND} //* various PCM "codecs" */ CODEC_ID_PCM_S16LE= $10000, @@ -286,6 +336,9 @@ type CODEC_ID_PCM_F32LE, CODEC_ID_PCM_F64BE, CODEC_ID_PCM_F64LE, +{$IF LIBAVCODEC_VERSION >= 52034000} // >= 52.34.0 + CODEC_ID_PCM_BLURAY, +{$IFEND} //* various ADPCM codecs */ CODEC_ID_ADPCM_IMA_QT= $11000, @@ -390,6 +443,13 @@ type {$IF LIBAVCODEC_VERSION >= 52026000} // >= 52.26.0 CODEC_ID_MP4ALS, {$IFEND} +{$IF LIBAVCODEC_VERSION >= 52035000} // >= 52.35.0 + CODEC_ID_ATRAC1, +{$IFEND} +{$IF LIBAVCODEC_VERSION >= 52049000} // >= 52.49.0 + CODEC_ID_BINKAUDIO_RDFT, + CODEC_ID_BINKAUDIO_DCT, +{$IFEND} //* subtitle codecs */ CODEC_ID_DVD_SUBTITLE= $17000, @@ -398,6 +458,12 @@ type CODEC_ID_XSUB, CODEC_ID_SSA, CODEC_ID_MOV_TEXT, +{$IF LIBAVCODEC_VERSION >= 52033000} // >= 52.33.0 + CODEC_ID_HDMV_PGS_SUBTITLE, +{$IFEND} +{$IF LIBAVCODEC_VERSION >= 52037001} // >= 52.37.1 + CODEC_ID_DVB_TELETEXT, +{$IFEND} (* other specific kind of codecs (generally used for attachments) *) CODEC_ID_TTF= $18000, @@ -416,6 +482,7 @@ const CODEC_ID_MPEG4AAC = CODEC_ID_AAC; {$IFEND} +{$IF LIBAVCODEC_VERSION_MAJOR < 53} // < 53.0.0 type TCodecType = ( CODEC_TYPE_UNKNOWN = -1, @@ -426,6 +493,25 @@ type CODEC_TYPE_ATTACHMENT, CODEC_TYPE_NB ); +{$IFEND} + +{ + TAVMediaType moved to avutil in LIBAVUTIL_VERSION 50.14.0 + but moving it in the pascal headers was not really necessary + but caused problems. So, I (KMS) left it here. +} +{$IF LIBAVCODEC_VERSION >= 52064000} // >= 52.64.0 +type + TAVMediaType = ( + AVMEDIA_TYPE_UNKNOWN = -1, + AVMEDIA_TYPE_VIDEO, + AVMEDIA_TYPE_AUDIO, + AVMEDIA_TYPE_DATA, + AVMEDIA_TYPE_SUBTITLE, + AVMEDIA_TYPE_ATTACHMENT, + AVMEDIA_TYPE_NB + ); +{$IFEND} {** * all in native endian @@ -465,6 +551,13 @@ const CH_TOP_BACK_RIGHT = $00020000; CH_STEREO_LEFT = $20000000; ///< Stereo downmix. CH_STEREO_RIGHT = $40000000; ///< See CH_STEREO_LEFT. +{** Channel mask value used for AVCodecContext.request_channel_layout + * to indicate that the user requests the channel order of the decoder output + * to be the native codec channel order. + *} +{$IF LIBAVCODEC_VERSION >= 52038001} // >= 52.38.1 + CH_LAYOUT_NATIVE = $8000000000000000; +{$IFEND} {* Audio channel convenience macros *} CH_LAYOUT_MONO = (CH_FRONT_CENTER); @@ -483,6 +576,9 @@ const CH_BACK_RIGHT); CH_LAYOUT_5POINT1_BACK = (CH_LAYOUT_5POINT0_BACK or CH_LOW_FREQUENCY); {$IFEND} +{$IF LIBAVCODEC_VERSION >= 52034000} // >= 52.34.0 + CH_LAYOUT_7POINT0 = (CH_LAYOUT_5POINT0 or CH_BACK_LEFT or CH_BACK_RIGHT); +{$IFEND} CH_LAYOUT_7POINT1 = (CH_LAYOUT_5POINT1 or CH_BACK_LEFT or CH_BACK_RIGHT); {$IF LIBAVCODEC_VERSION < 52025000} // < 52.25.0 CH_LAYOUT_7POINT1_WIDE = (CH_LAYOUT_SURROUND or CH_LOW_FREQUENCY or @@ -494,11 +590,30 @@ const CH_FRONT_RIGHT_OF_CENTER); CH_LAYOUT_STEREO_DOWNMIX = (CH_STEREO_LEFT or CH_STEREO_RIGHT); - -const - {* in bytes *} +{* in bytes *} AVCODEC_MAX_AUDIO_FRAME_SIZE = 192000; // 1 second of 48khz 32bit audio +{$IF LIBAVCODEC_VERSION <= 52056000} // <= 52.56.0 +{** + * Required number of additionally allocated bytes at the end of the input bitstream for decoding. + * This is mainly needed because some optimized bitstream readers read + * 32 or 64 bit at once and could read over the end.<br> + * Note: If the first 23 bits of the additional bytes are not 0, then damaged + * MPEG bitstreams could cause overread and segfault. + *} + FF_INPUT_BUFFER_PADDING_SIZE = 8; +{$ELSEIF LIBAVCODEC_VERSION < 52058000} // < 52.58.0 +{** + * Required number of additionally allocated bytes at the end of the input bitstream for decoding. + * The first 8 bytes are needed because some optimized bitstream readers read + * 32 or 64 bit at once and could read over the end. The remainder is to give + * decoders a reasonable amount of distance to work with before checking for + * buffer overreads.<br> + * Note: If the first 23 bits of the additional bytes are not 0, then damaged + * MPEG bitstreams could cause overread and segfault. + *} + FF_INPUT_BUFFER_PADDING_SIZE = 64; +{$ELSE} // >= 52.58.0} {** * Required number of additionally allocated bytes at the end of the input bitstream for decoding. * This is mainly needed because some optimized bitstream readers read @@ -507,6 +622,7 @@ const * MPEG bitstreams could cause overread and segfault. *} FF_INPUT_BUFFER_PADDING_SIZE = 8; +{$IFEND} {** * minimum encoding buffer size. @@ -676,6 +792,16 @@ const CODEC_FLAG2_CHUNKS = $00008000; ///< Input bitstream might be truncated at a packet boundaries instead of only at frame boundaries. CODEC_FLAG2_NON_LINEAR_QUANT = $00010000; ///< Use MPEG-2 nonlinear quantizer. CODEC_FLAG2_BIT_RESERVOIR = $00020000; ///< Use a bit reservoir when encoding if possible + {$IF LIBAVCODEC_VERSION >= 52043000} // >= 52.43.0 + CODEC_FLAG2_MBTREE = $00040000; ///< Use macroblock tree ratecontrol (x264 only) + {$IFEND} + {$IF LIBAVCODEC_VERSION >= 52061000} // >= 52.61.0 + CODEC_FLAG2_PSY = $00080000; ///< Use psycho visual optimizations. + CODEC_FLAG2_SSIM = $00100000; ///< Compute SSIM during encoding, error[] values are undefined. + {$IFEND} + {$IF LIBAVCODEC_VERSION >= 52067000} // >= 52.67.0 + CODEC_FLAG2_INTRA_REFRESH = $00200000; ///< Use periodic insertion of intra blocks instead of keyframes. + {$IFEND} (* Unsupported options : * Syntax Arithmetic coding (SAC) @@ -684,11 +810,11 @@ const (* /Fx *) (* codec capabilities *) -const CODEC_CAP_DRAW_HORIZ_BAND = $0001; ///< decoder can use draw_horiz_band callback (** - * Codec uses get_buffer() for allocating buffers. - * direct rendering method 1 + * Codec uses get_buffer() for allocating buffers and supports custom allocators. + * If not set, it might not use get_buffer() at all or use operations that + * assume the buffer was allocated by avcodec_default_get_buffer. *) CODEC_CAP_DR1 = $0002; (* if 'parse_only' field is true, then avcodec_parse_frame() can be used *) @@ -712,6 +838,21 @@ const *) CODEC_CAP_HWACCEL_VDPAU = $0080; + {$IF LIBAVCODEC_VERSION >= 52035000} // >= 52.35.0 + (** + * Codec can output multiple frames per AVPacket + * Normally demuxers return one frame at a time, demuxers which do not do + * are connected to a parser to split what they return into proper frames. + * This flag is reserved to the very rare category of codecs which have a + * bitstream that cannot be split into frames without timeconsuming + * operations like full decoding. Demuxers carring such bitstreams thus + * may return multiple frames in a packet. This has many disadvantages like + * prohibiting stream copy in many cases thus it should only be considered + * as a last resort. + *) + CODEC_CAP_SUBFRAMES = $0100; + {$IFEND} + //the following defines may change, don't expect compatibility if you use them MB_TYPE_INTRA4x4 = $001; MB_TYPE_INTRA16x16 = $002; //FIXME h264 specific @@ -765,6 +906,9 @@ const FF_QSCALE_TYPE_MPEG1 = 0; FF_QSCALE_TYPE_MPEG2 = 1; FF_QSCALE_TYPE_H264 = 2; + {$IF LIBAVCODEC_VERSION >= 52049000} // >= 52.49.0 + FF_QSCALE_TYPE_VP56 = 3; + {$IFEND} FF_BUFFER_TYPE_INTERNAL = 1; FF_BUFFER_TYPE_USER = 2; ///< Direct rendering buffers (image is (de)allocated by user) @@ -809,6 +953,9 @@ const FF_BUG_HPEL_CHROMA = 2048; FF_BUG_DC_CLIP = 4096; FF_BUG_MS = 8192; ///< workaround various bugs in microsofts broken decoders + {$IF LIBAVCODEC_VERSION >= 52054000} // >= 52.54.0 + FF_BUG_TRUNCATED = 16384; + {$IFEND} //FF_BUG_FAKE_SCALABILITY = 16 //Autodetection should work 100%. FF_COMPLIANCE_VERY_STRICT = 2; ///< strictly conform to a older more strict version of the spec or reference software @@ -854,6 +1001,9 @@ const FF_IDCT_EA = 21; FF_IDCT_SIMPLENEON = 22; FF_IDCT_SIMPLEALPHA = 23; + {$IF LIBAVCODEC_VERSION >= 52055000} // >= 52.55.0 + FF_IDCT_BINK = 24; + {$IFEND} FF_EC_GUESS_MVS = 1; FF_EC_DEBLOCK = 2; @@ -974,11 +1124,11 @@ const FF_COMPRESSION_DEFAULT = -1; +{$IF LIBAVCODEC_MAX_VERSION_MAJOR < 53} const AVPALETTE_SIZE = 1024; AVPALETTE_COUNT = 256; -{$IF LIBAVCODEC_MAX_VERSION_MAJOR < 53} type (** * AVPaletteControl @@ -1054,7 +1204,7 @@ type end; const - {$IF LIBAVCODEC_VERSION >= 52030002} // >= 52.30.2 + {$IF LIBAVCODEC_VERSION < 52030002} // < 52.30.2 PKT_FLAG_KEY = $0001; {$ELSE} AV_PKT_FLAG_KEY = $0001; @@ -1079,7 +1229,11 @@ type TQuadIntArray = array[0..3] of cint; // int (*func)(struct AVCodecContext *c2, void *arg) TExecuteFunc = function(c2: PAVCodecContext; arg: Pointer): cint; cdecl; - +{$IF LIBAVCODEC_VERSION >= 52037000} // >= 52.37.0 + // int (*func)(struct AVCodecContext *c2, void *arg, int jobnr, int threadnr) + TExecute2Func = function(c2: PAVCodecContext; arg: Pointer; jobnr: cint; threadnr: cint): cint; cdecl; +{$IFEND} + TAVClass = record class_name: PAnsiChar; (* actually passing a pointer to an AVCodecContext @@ -1088,6 +1242,23 @@ type of AVIn/OutputFormat *) item_name: function(): PAnsiChar; cdecl; option: PAVOption; + +{$IF LIBAVUTIL_VERSION >= 50015000} // 50.15.0 + (** + * LIBAVUTIL_VERSION with which this structure was created. + * This is used to allow fields to be added without requiring major + * version bumps everywhere. + *) + version: cint; +{$IFEND} + +{$IF LIBAVUTIL_VERSION >= 50015002} // 50.15.2 + (** + * Offset in the structure where log_level_offset is stored. + * 0 means there is no such variable + *) + log_level_offset_offset: cint; +{$IFEND} end; {** @@ -1283,7 +1454,8 @@ type *) dct_coeff: PsmallInt; (** - * motion referece frame index + * motion reference frame index + * the order in which these are stored can depend on the codec. * - encoding: Set by user. * - decoding: Set by libavcodec. *) @@ -1307,118 +1479,11 @@ type *) hwaccel_data_private: pointer; {$IFEND} + {$IF LIBAVCODEC_VERSION >= 52022000} // >= 52.22.0 hwaccel_picture_private: pointer; {$IFEND} - {$IF LIBAVCODEC_VERSION >= 51070000} // >= 51.70.0 - (** - * Bits per sample/pixel of internal libavcodec pixel/sample format. - * This field is applicable only when sample_fmt is SAMPLE_FMT_S32. - * - encoding: set by user. - * - decoding: set by libavcodec. - *) - bits_per_raw_sample: cint; - {$IFEND} - - {$IF LIBAVCODEC_VERSION >= 52002000} // >= 52.2.0 - (** - * Audio channel layout. - * - encoding: set by user. - * - decoding: set by libavcodec. - *) - channel_layout: cint64; - - (** - * Request decoder to use this channel layout if it can (0 for default) - * - encoding: unused - * - decoding: Set by user. - *) - request_channel_layout: cint64; - {$IFEND} - - {$IF LIBAVCODEC_VERSION >= 52004000} // >= 52.4.0 - (** - * Ratecontrol attempt to use, at maximum, <value> of what can be used without an underflow. - * - encoding: Set by user. - * - decoding: unused. - *) - rc_max_available_vbv_use: cfloat; - - (** - * Ratecontrol attempt to use, at least, <value> times the amount needed to prevent a vbv overflow. - * - encoding: Set by user. - * - decoding: unused. - *) - rc_min_vbv_overflow_use: cfloat; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52018000} // >= 52.18.0 - (** - * Hardware accelerator in use - * - encoding: unused. - * - decoding: Set by libavcodec - *) - hwaccel: PAVHWAccel; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52020000} // >= 52.20.0 - (** - * For some codecs, the time base is closer to the field rate than the frame rate. - * Most notably, H.264 and MPEG-2 specify time_base as half of frame duration - * if no telecine is used ... - * - * Set to time_base ticks per frame. Default 1, e.g., H.264/MPEG-2 set it to 2. - *) - ticks_per_frame: cint; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52021000} // >= 52.21.0 - (** - * Hardware accelerator context. - * For some hardware accelerators, a global context needs to be - * provided by the user. In that case, this holds display-dependent - * data FFmpeg cannot instantiate itself. Please refer to the - * FFmpeg HW accelerator documentation to know how to fill this - * is. e.g. for VA API, this is a struct vaapi_context. - * - encoding: unused - * - decoding: Set by user - *) - hwaccel_context: pointer; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52028000} // >= 52.28.0 - (** - * Chromaticity coordinates of the source primaries. - * - encoding: Set by user - * - decoding: Set by libavcodec - *) - color_primaries: TAVColorPrimaries; - - (** - * Color Transfer Characteristic. - * - encoding: Set by user - * - decoding: Set by libavcodec - *) - color_trc: TAVColorTransferCharacteristic; - - (** - * YUV colorspace type. - * - encoding: Set by user - * - decoding: Set by libavcodec - *) - colorspace: TAVColorSpace; - - (** - * MPEG vs JPEG YUV range. - * - encoding: Set by user - * - decoding: Set by libavcodec - *) - color_range: TAVColorRange; - - (** - * This defines the location of chroma samples. - * - encoding: Set by user - * - decoding: Set by libavcodec - *) - chroma_sample_location: TAVChromaLocation; - {$IFEND} end; (** @@ -1563,7 +1628,7 @@ type * - encoding: Set by user. * - decoding: Set by libavcodec. *) - sample_fmt: TSampleFormat; ///< sample format, currenly unused + sample_fmt: TSampleFormat; ///< sample format (* The following data should not be initialized. *) (** @@ -1689,7 +1754,11 @@ type opaque: pointer; codec_name: array [0..31] of AnsiChar; +{$IF LIBAVCODEC_VERSION < 52064000} // < 52.64.0 codec_type: TCodecType; (* see CODEC_TYPE_xxx *) +{$ELSE} + codec_type: TAVMediaType; (* see AVMEDIA_TYPE_xxx *) +{$IFEND} codec_id: TCodecID; (* see CODEC_ID_xxx *) (** @@ -1760,7 +1829,7 @@ type (** * Called at the beginning of each frame to get a buffer for it. * If pic.reference is set then the frame will be read later by libavcodec. - * avcodec_align_dimensions() should be used to find the required width and + * avcodec_align_dimensions2() should be used to find the required width and * height, as they normally need to be rounded up to the next multiple of 16. * if CODEC_CAP_DR1 is not set then get_buffer() must call * avcodec_default_get_buffer() instead of providing buffers allocated by @@ -2745,7 +2814,111 @@ type reordered_opaque: cint64; {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52028000} // 52.28.0 + {$IF LIBAVCODEC_VERSION >= 51069000} // 51.69.0 + (** + * Bits per sample/pixel of internal libavcodec pixel/sample format. + * This field is applicable only when sample_fmt is SAMPLE_FMT_S32. + * - encoding: set by user. + * - decoding: set by libavcodec. + *) + bits_per_raw_sample: cint; + {$IFEND} + + {$IF LIBAVCODEC_VERSION >= 52002000} // 52.2.0 + (** + * Audio channel layout. + * - encoding: set by user. + * - decoding: set by libavcodec. + *) + channel_layout: cint64; + + (** + * Request decoder to use this channel layout if it can (0 for default) + * - encoding: unused + * - decoding: Set by user. + *) + request_channel_layout: cint64; + {$IFEND} + + {$IF LIBAVCODEC_VERSION >= 52004000} // >= 52.4.0 + (** + * Ratecontrol attempt to use, at maximum, <value> of what can be used without an underflow. + * - encoding: Set by user. + * - decoding: unused. + *) + rc_max_available_vbv_use: cfloat; + + (** + * Ratecontrol attempt to use, at least, <value> times the amount needed to prevent a vbv overflow. + * - encoding: Set by user. + * - decoding: unused. + *) + rc_min_vbv_overflow_use: cfloat; + {$IFEND} + + {$IF LIBAVCODEC_VERSION >= 52018000} // >= 52.18.0 + (** + * Hardware accelerator in use + * - encoding: unused. + * - decoding: Set by libavcodec + *) + hwaccel: PAVHWAccel; + {$IFEND} + + {$IF LIBAVCODEC_VERSION >= 52020000} // >= 52.20.0 + (** + * For some codecs, the time base is closer to the field rate than the frame rate. + * Most notably, H.264 and MPEG-2 specify time_base as half of frame duration + * if no telecine is used ... + * + * Set to time_base ticks per frame. Default 1, e.g., H.264/MPEG-2 set it to 2. + *) + ticks_per_frame: cint; + {$IFEND} + + {$IF LIBAVCODEC_VERSION >= 52021000} // >= 52.21.0 + (** + * Hardware accelerator context. + * For some hardware accelerators, a global context needs to be + * provided by the user. In that case, this holds display-dependent + * data FFmpeg cannot instantiate itself. Please refer to the + * FFmpeg HW accelerator documentation to know how to fill this + * is. e.g. for VA API, this is a struct vaapi_context. + * - encoding: unused + * - decoding: Set by user + *) + hwaccel_context: pointer; + {$IFEND} + + {$IF LIBAVCODEC_VERSION >= 52028000} // >= 52.28.0 + (** + * Chromaticity coordinates of the source primaries. + * - encoding: Set by user + * - decoding: Set by libavcodec + *) + color_primaries: TAVColorPrimaries; + + (** + * Color Transfer Characteristic. + * - encoding: Set by user + * - decoding: Set by libavcodec + *) + color_trc: TAVColorTransferCharacteristic; + + (** + * YUV colorspace type. + * - encoding: Set by user + * - decoding: Set by libavcodec + *) + colorspace: TAVColorSpace; + + (** + * MPEG vs JPEG YUV range. + * - encoding: Set by user + * - decoding: Set by libavcodec + *) + color_range: TAVColorRange; + (** * This defines the location of chroma samples. * - encoding: Set by user @@ -2753,6 +2926,95 @@ type *) chroma_sample_location: TAVChromaLocation; {$IFEND} + + {$IF LIBAVCODEC_VERSION >= 52037000} // >= 52.37.0 + (** + * The codec may call this to execute several independent things. + * It will return only after finishing all tasks. + * The user may replace this with some multithreaded implementation, + * the default implementation will execute the parts serially. + * Also see avcodec_thread_init and e.g. the --enable-pthread configure option. + * @param c context passed also to func + * @param count the number of things to execute + * @param arg2 argument passed unchanged to func + * @param ret return values of executed functions, must have space for "count" values. May be NULL. + * @param func function that will be called count times, with jobnr from 0 to count-1. + * threadnr will be in the range 0 to c->thread_count-1 < MAX_THREADS and so that no + * two instances of func executing at the same time will have the same threadnr. + * @return always 0 currently, but code should handle a future improvement where when any call to func + * returns < 0 no further calls to func may be done and < 0 is returned. + * - encoding: Set by libavcodec, user can override. + * - decoding: Set by libavcodec, user can override. + *) + execute2: function (c: PAVCodecContext; func: TExecute2Func; arg2: Pointer; ret: Pcint; count: cint): cint; cdecl; + {$IFEND} + + {$IF LIBAVCODEC_VERSION >= 52042000} // >= 52.42.0 + (** + * explicit P-frame weighted prediction analysis method + * 0: off + * 1: fast blind weighting (one reference duplicate with -1 offset) + * 2: smart weighting (full fade detection analysis) + * - encoding: Set by user. + * - decoding: unused + *) + weighted_p_pred: cint; + {$IFEND} + + {$IF LIBAVCODEC_VERSION >= 52061000} // >= 52.61.0 + (** + * AQ mode + * 0: Disabled + * 1: Variance AQ (complexity mask) + * 2: Auto-variance AQ (experimental) + * - encoding: Set by user + * - decoding: unused + *) + aq_mode: cint; + + (** + * AQ strength + * Reduces blocking and blurring in flat and textured areas. + * - encoding: Set by user + * - decoding: unused + *) + aq_strength: cfloat; + + (** + * PSY RD + * Strength of psychovisual optimization + * - encoding: Set by user + * - decoding: unused + *) + psy_rd: cfloat; + + (** + * PSY trellis + * Strength of psychovisual optimization + * - encoding: Set by user + * - decoding: unused + *) + psy_trellis: cfloat; + + (** + * RC lookahead + * Number of frames for frametype and ratecontrol lookahead + * - encoding: Set by user + * - decoding: unused + *) + rc_lookahead: cint; + {$IFEND} + + {$IF LIBAVCODEC_VERSION >= 52067000} // >= 52.67.0 + (** + * Constant rate factor maximum + * With CRF encoding mode and VBV restrictions enabled, prevents quality from being worse + * than crf_max, even if doing so would violate VBV restrictions. + * - encoding: Set by user. + * - decoding: unused + *) + crf_max: cfloat; + {$IFEND} end; (** @@ -2760,7 +3022,11 @@ type *) TAVCodec = record name: PAnsiChar; +{$IF LIBAVCODEC_VERSION < 52064000} // < 52.64.0 type_: TCodecType; +{$ELSE} + type_: TAVMediaType; +{$IFEND} id: TCodecID; priv_data_size: cint; init: function (avctx: PAVCodecContext): cint; cdecl; (* typo corretion by the Creative CAT *) @@ -2815,13 +3081,23 @@ type *) name: PAnsiChar; +{$IF LIBAVCODEC_VERSION < 52064000} // < 52.64.0 (** * Type of codec implemented by the hardware accelerator. * * See CODEC_TYPE_xxx *) type_: TCodecType; +{$ELSE} + (** + * Type of codec implemented by the hardware accelerator. + * + * See AVMediaType_xxx + *) + type_: TAVMediaType; +{$IFEND} + (** * Codec implemented by the hardware accelerator. * @@ -2983,6 +3259,9 @@ type {$ELSE} rects: PPAVSubtitleRect; {$IFEND} + {$IF LIBAVCODEC_VERSION >= 52032000} // >= 52.32.0 + pts: cint64; ///< Same as packet pts, in AV_TIME_BASE + {$IFEND} end; {$IF LIBAVCODEC_VERSION >= 52025000} // 52.25.0 @@ -3005,7 +3284,7 @@ procedure av_destruct_packet(pkt: PAVPacket); * * @param pkt packet *) -procedure av_init_packet(pkt: PAVPacket); +procedure av_init_packet(var pkt: TAVPacket); cdecl; external av__codec; (* @@ -3223,6 +3502,7 @@ function avcodec_get_pix_fmt_name(pix_fmt: TAVPixelFormat): PAnsiChar; procedure avcodec_set_dimensions(s: PAVCodecContext; width: cint; height: cint); cdecl; external av__codec; +{$IF LIBAVCODEC_MAX_VERSION_MAJOR < 53} (** * Returns the pixel format corresponding to the name name. * @@ -3232,12 +3512,22 @@ procedure avcodec_set_dimensions(s: PAVCodecContext; width: cint; height: cint); * For example in a little-endian system, first looks for "gray16", * then for "gray16le". * - * Finally if no pixel format has been found, returns PIX_FMT_NONE. + * Finally if no pixel format has been found, returns PIX_FMT_NONE.* + * @deprecated Deprecated in favor of av_get_pix_fmt(). *) function avcodec_get_pix_fmt(name: {const} PAnsiChar): TAVPixelFormat; cdecl; external av__codec; +{$IF LIBAVCODEC_VERSION >= 52049000} // >= 52.49.0 + deprecated; +{$IFEND} +{$IFEND} -function avcodec_pix_fmt_to_codec_tag(p: TAVPixelFormat): cuint; +(** + * Returns a value representing the fourCC code associated to the + * pixel format pix_fmt, or 0 if no associated fourCC code can be + * found. + *) +function avcodec_pix_fmt_to_codec_tag(pix_fmt: TAVPixelFormat): cuint; cdecl; external av__codec; const @@ -3390,6 +3680,20 @@ function avcodec_build(): cuint; cdecl; external av__codec; deprecated; {$IFEND} +{$IF LIBAVCODEC_VERSION >= 52041000} // 52.41.0 +(** + * Returns the libavcodec build-time configuration. + *) +function avcodec_configuration(): PAnsiChar; + cdecl; external av__codec; + +(** + * Returns the libavcodec license. + *) +function avcodec_license(): PAnsiChar; + cdecl; external av__codec; +{$IFEND} + (** * Initializes libavcodec. * @@ -3463,8 +3767,13 @@ procedure avcodec_get_context_defaults(s: PAVCodecContext); {$IF LIBAVCODEC_VERSION >= 51039000} // 51.39.0 (** THIS FUNCTION IS NOT YET PART OF THE PUBLIC API! * we WILL change its arguments and name a few times! *) +{$IF LIBAVCODEC_VERSION < 52064000} // < 52.64.0 procedure avcodec_get_context_defaults2(s: PAVCodecContext; ctype: TCodecType); cdecl; external av__codec; +{$ELSE} +procedure avcodec_get_context_defaults2(s: PAVCodecContext; ctype: TAVMediaType); + cdecl; external av__codec; +{$IFEND} {$IFEND} (** @@ -3480,8 +3789,29 @@ function avcodec_alloc_context(): PAVCodecContext; {$IF LIBAVCODEC_VERSION >= 51039000} // 51.39.0 (** THIS FUNCTION IS NOT YET PART OF THE PUBLIC API! * we WILL change its arguments and name a few times! *) +{$IF LIBAVCODEC_VERSION < 52064000} // < 52.64.0 function avcodec_alloc_context2(ctype: TCodecType): PAVCodecContext; cdecl; external av__codec; +{$ELSE} +function avcodec_alloc_context2(ctype: TAVMediaType): PAVCodecContext; + cdecl; external av__codec; +{$IFEND} +{$IFEND} + +{$IF LIBAVCODEC_VERSION >= 52065000} // >= 52.65.0 +(** + * Copy the settings of the source AVCodecContext into the destination + * AVCodecContext. The resulting destination codec context will be + * unopened, i.e. you are required to call avcodec_open() before you + * can use this AVCodecContext to decode/encode video/audio data. + * + * @param dest target codec context, should be initialized with + * avcodec_alloc_context(), but otherwise uninitialized + * @param src source codec context + * @return AVERROR() on error (e.g. memory allocation error), 0 on success + *) +function avcodec_copy_context(dest: PAVCodecContext; src: {const} PAVCodecContext): cint; + cdecl; external av__codec; {$IFEND} (** @@ -3508,9 +3838,38 @@ procedure avcodec_default_release_buffer (s: PAVCodecContext; pic: PAVFrame); cdecl; external av__codec; function avcodec_default_reget_buffer (s: PAVCodecContext; pic: PAVFrame): cint; cdecl; external av__codec; + +{$IF LIBAVCODEC_VERSION >= 52066000} // >= 52.66.0 +(** + * Returns the amount of padding in pixels which the get_buffer callback must + * provide around the edge of the image for codecs which do not have the + * CODEC_FLAG_EMU_EDGE flag. + * + * @return Required padding in pixels. + *) +function avcodec_get_edge_width(): cuint; + cdecl; external av__codec; +{$IFEND} + +(** + * Modifies width and height values so that they will result in a memory + * buffer that is acceptable for the codec if you do not use any horizontal + * padding. + *) procedure avcodec_align_dimensions(s: PAVCodecContext; width: PCint; height: PCint); cdecl; external av__codec; +{$IF LIBAVCODEC_VERSION >= 52055000} // >= 52.55.0 +(** + * Modifies width and height values so that they will result in a memory + * buffer that is acceptable for the codec if you also ensure that all + * line sizes are a multiple of the respective linesize_align[i]. + *) +procedure avcodec_align_dimensions2(s: PAVCodecContext; width: PCint; height: PCint; + linesize_align: PQuadIntArray); + cdecl; external av__codec; +{$IFEND} + (** * Checks if the given dimension of a picture is valid, meaning that all * bytes of the picture can be addressed with a signed int. @@ -3529,11 +3888,10 @@ function avcodec_thread_init(s: PAVCodecContext; thread_count: cint): cint; procedure avcodec_thread_free(s: PAVCodecContext); cdecl; external av__codec; - {$IF LIBAVCODEC_VERSION < 52004000} // < 52.4.0 function avcodec_thread_execute(s: PAVCodecContext; func: TExecuteFunc; arg: PPointer; var ret: cint; count: cint): cint; cdecl; external av__codec; -{$ELSE} +{$ELSEIF LIBAVCODEC_VERSION < 52059000} // < 52.59.0 function avcodec_thread_execute(s: PAVCodecContext; func: TExecuteFunc; arg: Pointer; var ret: cint; count: cint; size: cint): cint; cdecl; external av__codec; {$IFEND} @@ -3545,6 +3903,11 @@ function avcodec_default_execute(s: PAVCodecContext; func: TExecuteFunc; arg: PP function avcodec_default_execute(s: PAVCodecContext; func: TExecuteFunc; arg: Pointer; var ret: cint; count: cint; size: cint): cint; cdecl; external av__codec; {$IFEND} + +{$IF LIBAVCODEC_VERSION >= 52037000} // >= 52.37.0 +function avcodec_default_execute2(s: PAVCodecContext; func: TExecuteFunc; arg: Pointer; var ret: cint; count: cint): cint; + cdecl; external av__codec; +{$IFEND} //FIXME func typedef (** @@ -3595,7 +3958,7 @@ function avcodec_decode_audio(avctx: PAVCodecContext; samples: PSmallint; * * @deprecated Use avcodec_decode_audio3 instead. * @param avctx the codec context - * @param[out] samples the output buffer + * @param[out] samples the output buffer, sample type in avctx->sample_fmt * @param[in,out] frame_size_ptr the output buffer size in bytes * @param[in] buf the input buffer * @param[in] buf_size the input buffer size in bytes @@ -3613,9 +3976,11 @@ function avcodec_decode_audio2(avctx: PAVCodecContext; samples: PSmallint; (** * Decodes the audio frame of size avpkt->size from avpkt->data into samples. * Some decoders may support multiple frames in a single AVPacket, such - * decoders would then just decode the first frame. + * decoders would then just decode the first frame. In this case, + * avcodec_decode_audio3 has to be called again with an AVPacket that contains + * the remaining data in order to decode the second frame etc. * If no frame - * could be decompressed, frame_size_ptr is zero. Otherwise, it is the + * could be outputted, frame_size_ptr is zero. Otherwise, it is the * decompressed frame size in bytes. * * @warning You must set frame_size_ptr to the allocated size of the @@ -3638,7 +4003,7 @@ function avcodec_decode_audio2(avctx: PAVCodecContext; samples: PSmallint; * (AltiVec and SSE do). * * @note Some codecs have a delay between input and output, these need to be - * feeded with avpkt->data=NULL, avpkt->size=0 at the end to return the remaining frames. + * fed with avpkt->data=NULL, avpkt->size=0 at the end to return the remaining frames. * * @param avctx the codec context * @param[out] samples the output buffer @@ -3648,7 +4013,7 @@ function avcodec_decode_audio2(avctx: PAVCodecContext; samples: PSmallint; * data and size, some decoders might in addition need other fields. * All decoders are designed to use the least fields possible though. * @return On error a negative value is returned, otherwise the number of bytes - * used or zero if no frame could be decompressed. + * used or zero if no frame data was decompressed (used) from the input AVPacket. *) function avcodec_decode_audio3(avctx: PAVCodecContext; samples: PSmallint; var frame_size_ptr: cint; @@ -3664,6 +4029,8 @@ function avcodec_decode_audio3(avctx: PAVCodecContext; samples: PSmallint; * @deprecated Use avcodec_decode_video2 instead. * @param avctx the codec context * @param[out] picture The AVFrame in which the decoded video frame will be stored. + * Use avcodec_alloc_frame to get an AVFrame, the codec will + * allocate memory for the actual bitmap. * @param[in] buf the input buffer * @param[in] buf_size the size of the input buffer in bytes * @param[in,out] got_picture_ptr Zero if no frame could be decompressed, otherwise, it is nonzero. @@ -3701,7 +4068,7 @@ function avcodec_decode_video(avctx: PAVCodecContext; picture: PAVFrame; * @param[in] avpkt The input AVpacket containing the input buffer. * You can create such packet with av_init_packet() and by then setting * data and size, some decoders might in addition need other fields like - * flags&PKT_FLAG_KEY. All decoders are designed to use the least + * flags&AV_PKT_FLAG_KEY. All decoders are designed to use the least * fields possible. * @param[in,out] got_picture_ptr Zero if no frame could be decompressed, otherwise, it is nonzero. * @return On error a negative value is returned, otherwise the number of bytes @@ -3987,9 +4354,10 @@ type codec_ids: array [0..4] of cint; (* several codec IDs are permitted *) priv_data_size: cint; parser_init: function(s: PAVCodecParserContext): cint; cdecl; - parser_parse: function(s: PAVCodecParserContext; avctx: PAVCodecContext; - poutbuf: {const} PPointer; poutbuf_size: PCint; - buf: {const} PByteArray; buf_size: cint): cint; cdecl; + parser_parse: function(s: PAVCodecParserContext; + avctx: PAVCodecContext; + poutbuf: {const} PPointer; poutbuf_size: PCint; + buf: {const} PByteArray; buf_size: cint): cint; cdecl; parser_close: procedure(s: PAVCodecParserContext); cdecl; split: function(avctx: PAVCodecContext; buf: {const} PByteArray; buf_size: cint): cint; cdecl; @@ -4112,6 +4480,7 @@ function av_bitstream_filter_filter(bsfc: PAVBitStreamFilterContext; poutbuf: PPointer; poutbuf_size: PCint; buf: PByte; buf_size: cint; keyframe: cint): cint; cdecl; external av__codec; + procedure av_bitstream_filter_close(bsf: PAVBitStreamFilterContext); cdecl; external av__codec; @@ -4255,6 +4624,13 @@ function img_pad(dst: PAVPicture; src: {const} PAVPicture; height, width: cint; cdecl; external av__codec; deprecated; {$IFEND} +(** + * Encodes extradata length to a buffer. Used by xiph codecs. + * + * @param s buffer to write to; must be at least (v/255+1) bytes long + * @param v size of extradata in bytes + * @return number of bytes written to the buffer. + *) function av_xiphlacing(s: PByte; v: cuint): cuint; cdecl; external av__codec; @@ -4286,6 +4662,13 @@ function av_parse_video_frame_rate(frame_rate: PAVRational; str: {const} PAnsiCh cdecl; external av__codec; {$IFEND} +{$IF LIBAVCODEC_VERSION < 52059000} // <52.59.0 + +{ + The following error codes are moved to libavutil/error.h on + revision 22501 Mar 13 2010 +} + {* error handling *} const @@ -4313,13 +4696,20 @@ const {$ENDIF} {$ENDIF} +(** + * We need the sign of the error, because some platforms have + * E* and errno already negated. The previous version failed + * with Delphi, because it needed EINVAL defined. + * Warning: This code is platform dependent and assumes constants + * to be 32 bit. + * This version does the following steps: + * 1) shr 30: shifts the sign bit to bit position 2 + * 2) and $00000002: sets all other bits to zero + * positive EINVAL gives 0, negative gives 2 + * 3) - 1: positive EINVAL gives -1, negative 1 + *) const -{$IF EINVAL > 0} - AVERROR_SIGN = -1; -{$ELSE} - {* Some platforms have E* and errno already negated. *} - AVERROR_SIGN = 1; -{$IFEND} + AVERROR_SIGN = (EINVAL shr 30) and $00000002 - 1; (* #if EINVAL > 0 @@ -4347,6 +4737,35 @@ const // Note: function calls as constant-initializers are invalid //AVERROR_PATCHWELCOME = -MKTAG('P','A','W','E'); {**< Not yet implemented in FFmpeg. Patches welcome. *} AVERROR_PATCHWELCOME = -(ord('P') or (ord('A') shl 8) or (ord('W') shl 16) or (ord('E') shl 24)); +{$IFEND} + +{$IF LIBAVCODEC_VERSION >= 52032000} // >= 52.32.0 +(** + * Logs a generic warning message about a missing feature. This function is + * intended to be used internally by FFmpeg (libavcodec, libavformat, etc.) + * only, and would normally not be used by applications. + * @param[in] avc a pointer to an arbitrary struct of which the first field is + * a pointer to an AVClass struct + * @param[in] feature string containing the name of the missing feature + * @param[in] want_sample indicates if samples are wanted which exhibit this feature. + * If want_sample is non-zero, additional verbage will be added to the log + * message which tells the user how to report samples to the development + * mailing list. + *) +procedure av_log_missing_feature(avc: Pointer; feature: {const} Pchar; want_sample: cint); + cdecl; external av__codec; + +(** + * Logs a generic warning message asking for a sample. This function is + * intended to be used internally by FFmpeg (libavcodec, libavformat, etc.) + * only, and would normally not be used by applications. + * @param[in] avc a pointer to an arbitrary struct of which the first field is + * a pointer to an AVClass struct + * @param[in] msg string containing an optional message, or NULL if no message + *) +procedure av_log_ask_for_sample(avc: Pointer; msg: {const} Pchar); + cdecl; external av__codec; +{$IFEND} {$IF LIBAVCODEC_VERSION >= 52018000} // 52.18.0 (** @@ -4396,18 +4815,15 @@ type implementation -{$IF (LIBAVCODEC_VERSION >= 52025000) and (LIBAVCODEC_VERSION <= 5202700)} // 52.25.0 +{$IF (LIBAVCODEC_VERSION >= 52025000) and (LIBAVCODEC_VERSION <= 52027000)} // 52.25.0 - 52.27.0 procedure av_free_packet(pkt: PAVPacket);{$IFDEF HASINLINE} inline; {$ENDIF} begin - if (pkt <> nil) then + if assigned(pkt) then begin - if (pkt.destruct <> nil) then - pkt.destruct(pkt) - else - begin - pkt.data = NULL; - pkt.size = 0; - end; + if assigned(pkt^.destruct) then + pkt^.destruct(pkt); + pkt^.data := NIL; + pkt^.size := 0; end; end; {$IFEND} diff --git a/cmake/src/lib/ffmpeg/avformat.pas b/cmake/src/lib/ffmpeg/avformat.pas index 0ec2c118..b745f962 100644 --- a/cmake/src/lib/ffmpeg/avformat.pas +++ b/cmake/src/lib/ffmpeg/avformat.pas @@ -26,14 +26,9 @@ (* * Conversion of libavformat/avformat.h - * Min. version: 50.5.0 , revision 6577, Sat Oct 7 15:30:46 2006 UTC - * Max. version: 52.25.0, revision 16986, Wed Feb 4 05:56:39 2009 UTC + * Min. version: 50.5.0 , revision 6577, Sat Oct 7 15:30:46 2006 UTC + * Max. version: 52.63.0, revision 23179, Wed May 19 19:17:00 2010 CET *) -{ - * update to - * Max. version: 52.34.0, Sat Jun 13 00:37:00 2009 UTC - * MiSchi -} unit avformat; @@ -63,9 +58,34 @@ uses UConfig; const + (* + * IMPORTANT: The official FFmpeg C headers change very quickly. Often some + * of the data structures are changed so that they become incompatible with + * older header files. The Pascal headers have to be adjusted to those changes, + * otherwise the application might crash randomly or strange bugs (not + * necessarily related to video or audio due to buffer overflows etc.) might + * occur. + * + * In the past users reported problems with USDX that took hours to fix and + * the problem was an unsupported version of FFmpeg. So we decided to disable + * support for future versions of FFmpeg until the headers are revised by us + * for that version as they otherwise most probably will break USDX. + * + * If the headers do not yet support your FFmpeg version you may want to + * adjust the max. version numbers manually but please note: it may work but + * in many cases it does not. The USDX team does NOT PROVIDE ANY SUPPORT + * for the game if the MAX. VERSION WAS CHANGED. + * + * The only safe way to support new versions of FFmpeg is to add the changes + * of the FFmpeg git repository C headers to the Pascal headers. + * You can accelerate this process by posting a patch with the git changes + * translated to Pascal to our bug tracker (please join our IRC chat before + * you start working on it). Simply adjusting the max. versions is NOT a valid + * fix. + *) (* Max. supported version by this header *) LIBAVFORMAT_MAX_VERSION_MAJOR = 52; - LIBAVFORMAT_MAX_VERSION_MINOR = 34; + LIBAVFORMAT_MAX_VERSION_MINOR = 63; LIBAVFORMAT_MAX_VERSION_RELEASE = 0; LIBAVFORMAT_MAX_VERSION = (LIBAVFORMAT_MAX_VERSION_MAJOR * VERSION_MAJOR) + (LIBAVFORMAT_MAX_VERSION_MINOR * VERSION_MINOR) + @@ -91,19 +111,36 @@ const {$IF LIBAVFORMAT_VERSION >= 52020000} // 52.20.0 (** - * Returns the LIBAVFORMAT_VERSION_INT constant. + * I return the LIBAVFORMAT_VERSION_INT constant. You got + * a fucking problem with that, douchebag? *) function avformat_version(): cuint; cdecl; external av__format; {$IFEND} +{$IF LIBAVFORMAT_VERSION >= 52039002} // 52.39.2 +(** + * Returns the libavformat build-time configuration. + *) +function avformat_configuration(): {const} PansiChar; + cdecl; external av__format; + +(** + * Returns the libavformat license. + *) +function avformat_license(): {const} PansiChar; + cdecl; external av__format; +{$IFEND} + type PAVFile = Pointer; (* * Public Metadata API. * The metadata API allows libavformat to export metadata tags to a client - * application using a sequence of key/value pairs. + * application using a sequence of key/value pairs. Like all strings in FFmpeg, + * metadata must be stored as UTF-8 encoded Unicode. Note that metadata + * exported by demuxers isn't checked to be valid UTF-8 in most cases. * Important concepts to keep in mind: * 1. Keys are unique; there can never be 2 tags with the same key. This is * also meant semantically, i.e., a demuxer should not knowingly produce @@ -122,6 +159,13 @@ type const AV_METADATA_MATCH_CASE = 1; AV_METADATA_IGNORE_SUFFIX = 2; +{$IF LIBAVFORMAT_VERSION >= 52043000} // >= 52.43.0 + AV_METADATA_DONT_STRDUP_KEY = 4; + AV_METADATA_DONT_STRDUP_VAL = 8; +{$IFEND} +{$IF LIBAVFORMAT_VERSION >= 52061000} // >= 52.61.0 + AV_METADATA_DONT_OVERWRITE = 16; +{$IFEND} type PAVMetadataTag = ^TAVMetadataTag; @@ -133,9 +177,11 @@ type PAVMetadata = Pointer; {$IF LIBAVFORMAT_VERSION > 52024001} // > 52.24.1 +{$IF LIBAVFORMAT_VERSION_MAJOR = 52} (** * Gets a metadata element with matching key. * @param prev Set to the previous matching element to find the next. + * If set to NULL the first matching element is returned. * @param flags Allows case as well as suffix-insensitive comparisons. * @return Found tag or NULL, changing key or value leads to undefined behavior. *) @@ -148,9 +194,25 @@ function av_metadata_get(m: PAVMetadata; key: {const} PAnsiChar; * @param key tag key to add to m (will be av_strduped) * @param value tag value to add to m (will be av_strduped) * @return >= 0 on success otherwise an error code <0 + * @deprecated Use av_metadata_set2() instead. *) function av_metadata_set(var pm: PAVMetadata; key: {const} PAnsiChar; value: {const} PAnsiChar): cint; cdecl; external av__format; +{$IF LIBAVFORMAT_VERSION >= 52061000} // >= 52.61.0 + deprecated; +{$IFEND} +{$IFEND} + +{$IF LIBAVFORMAT_VERSION >= 52043000} // >= 52.43.0 +(** + * Sets the given tag in m, overwriting an existing tag. + * @param key tag key to add to m (will be av_strduped depending on flags) + * @param value tag value to add to m (will be av_strduped depending on flags) + * @return >= 0 on success otherwise an error code <0 + *) +function av_metadata_set2(var pm: PAVMetadata; key: {const} PAnsiChar; value: {const} PAnsiChar; flags: cint): cint; + cdecl; external av__format; +{$IFEND} (** * Frees all the memory allocated for an AVMetadata struct. @@ -161,7 +223,7 @@ procedure av_metadata_free(var m: PAVMetadata); (* packet functions *) -{$IF LIBAVCODEC_VERSION < 52032000} // < 52.32.0 +{$IF LIBAVFORMAT_VERSION < 52032000} // < 52.32.0 type PAVPacket = ^TAVPacket; TAVPacket = record @@ -259,7 +321,7 @@ function av_new_packet(var pkt: TAVPacket; size: cint): cint; function av_get_packet(s: PByteIOContext; var pkt: TAVPacket; size: cint): cint; cdecl; external av__format; -{$IF LIBAVCODEC_VERSION < 52032000} // < 52.32.0 +{$IF LIBAVFORMAT_VERSION < 52032000} // < 52.32.0 (** * @warning This is a hack - the packet memory allocation stuff is broken. The * packet is allocated if it was not really allocated. @@ -295,8 +357,8 @@ type (** This structure contains the data a format has to probe a file. *) TAVProbeData = record filename: PAnsiChar; - buf: PByteArray; - buf_size: cint; + buf: PByteArray; (**< Buffer must have AVPROBE_PADDING_SIZE of extra allocated bytes filled with zero. *) + buf_size: cint; (**< Size of buf except extra allocated bytes *) end; const @@ -316,19 +378,36 @@ const {$IF LIBAVFORMAT_VERSION >= 52029002} // 52.29.2 AVFMT_VARIABLE_FPS = $0400; (**< Format allows variable fps. *) {$IFEND} + {$IF LIBAVFORMAT_VERSION >= 52052000} // 52.52.0 + AVFMT_NODIMENSIONS = $0800; (**< Format does not need width/height *) + {$IFEND} // used by AVIndexEntry AVINDEX_KEYFRAME = $0001; AVFMTCTX_NOHEADER = $0001; (**< signal that no header is present (streams are added dynamically) *) +{$IF LIBAVFORMAT_VERSION_MAJOR < 53} MAX_STREAMS = 20; +{$ELSE} + MAX_STREAMS = 100; +{$IFEND} AVFMT_NOOUTPUTLOOP = -1; AVFMT_INFINITEOUTPUTLOOP = 0; AVFMT_FLAG_GENPTS = $0001; ///< Generate missing pts even if it requires parsing future frames. AVFMT_FLAG_IGNIDX = $0002; ///< Ignore index. AVFMT_FLAG_NONBLOCK = $0004; ///< Do not block when reading packets from input. +{$IF LIBAVFORMAT_VERSION >= 52048000} // >= 52.48.0 + AVFMT_FLAG_IGNDTS = $0008; ///< Ignore DTS on frames that contain both DTS & PTS +{$IFEND} +{$IF LIBAVFORMAT_VERSION >= 52060000} // >= 52.60.0 + AVFMT_FLAG_NOFILLIN = $0010; ///< Do not infer any values from other values, just return what is stored in the container + AVFMT_FLAG_NOPARSE = $0020; ///< Do not use AVParsers, you also must set AVFMT_FLAG_NOFILLIN as the fillin code works on frames and no parsing -> no frames. Also seeking to frames can not work if parsing to find frame boundaries has been disabled +{$IFEND} +{$IF LIBAVFORMAT_VERSION >= 52063000} // >= 52.63.0 + AVFMT_FLAG_RTP_HINT = $0040; ///< Add RTP hinting to the output file +{$IFEND} // used by AVStream MAX_REORDER_DELAY = 16; @@ -347,8 +426,20 @@ const // used by TAVFormatContext.debug FF_FDEBUG_TS = 0001; - {$IF LIBAVFORMAT_VERSION >= 52034000} // > 52.34.0 + {$IF LIBAVFORMAT_VERSION >= 52034000} // >= 52.34.0 + {$IF LIBAVFORMAT_VERSION < 52039000} // < 52.39.0 MAX_PROBE_PACKETS = 100; + {$ELSE} + MAX_PROBE_PACKETS = 2500; + {$IFEND} + {$IFEND} + + {$IF LIBAVFORMAT_VERSION >= 52035000} // >= 52.35.0 + {$IF LIBAVFORMAT_VERSION < 52039000} // < 52.39.0 + RAW_PACKET_BUFFER_SIZE = 32000; + {$ELSE} + RAW_PACKET_BUFFER_SIZE = 2500000; + {$IFEND} {$IFEND} type @@ -543,11 +634,11 @@ type (** General purpose read-only value that the format can use. *) value: cint; - (** Start/resume playing - only meaningful if using a network-based format + (** Starts/resumes playing - only meaningful if using a network-based format (RTSP). *) read_play: function (c: PAVFormatContext): cint; cdecl; - (** Pause playing - only meaningful if using a network-based format + (** Pauses playing - only meaningful if using a network-based format (RTSP). *) read_pause: function (c: PAVFormatContext): cint; cdecl; @@ -557,7 +648,7 @@ type {$IF LIBAVFORMAT_VERSION >= 52030000} // 52.30.0 (** - * Seek to timestamp ts. + * Seeks to timestamp ts. * Seeking will be done so that the point from which all active streams * can be presented successfully will be closest to ts and within min/max_ts. * Active streams are all streams that have AVStream.discard < AVDISCARD_ALL. @@ -724,13 +815,32 @@ type *) reference_dts: cint64; {$IFEND} - {$IF LIBAVFORMAT_VERSION >= 52034000} // > 52.34.0 + {$IF LIBAVFORMAT_VERSION >= 52034000} // >= 52.34.0 (** * Number of packets to buffer for codec probing * NOT PART OF PUBLIC API *) probe_packets: cint; {$IFEND} + {$IF LIBAVFORMAT_VERSION >= 52038000} // >= 52.38.0 + (** + * last packet in packet_buffer for this stream when muxing. + * used internally, NOT PART OF PUBLIC API, dont read or write from outside of libav* + *) + last_in_packet_buffer: PAVPacketList; + {$IFEND} + {$IF LIBAVFORMAT_VERSION >= 52041000} // >= 52.41.0 + (** + * Average framerate + *) + avg_frame_rate: TAVRational; + {$IFEND} + {$IF LIBAVFORMAT_VERSION >= 52054000} // >= 52.54.0 + (** + * Number of frames that have been demuxed during av_find_stream_info() + *) + codec_info_nb_frames: cint; + {$IFEND} end; (** @@ -781,8 +891,9 @@ type It is deduced from the AVStream values. *) start_time: cint64; (** Decoding: duration of the stream, in AV_TIME_BASE fractional - seconds. NEVER set this value directly: it is deduced from the - AVStream values. *) + seconds. Only set this value if you know none of the individual stream + durations and also dont set any of them. This is deduced from the + AVStream values if not set. *) duration: cint64; (** decoding: total file size, 0 if unknown *) file_size: cint64; @@ -804,7 +915,11 @@ type index_built: cint; mux_rate: cint; + {$IF LIBAVFORMAT_VERSION < 52034001} // < 52.34.1 packet_size: cint; + {$ELSE} + packet_size: cuint; + {$IFEND} preload: cint; max_delay: cint; @@ -903,6 +1018,26 @@ type {$IF LIBAVFORMAT_VERSION >= 52024001} // 52.24.1 metadata: PAVMetadata; {$IFEND} + + {$IF LIBAVFORMAT_VERSION >= 52035000} // 52.35.0 + (** + * Remaining size available for raw_packet_buffer, in bytes. + * NOT PART OF PUBLIC API + *) + raw_packet_buffer_remaining_size: cint; + {$IFEND} + + {$IF LIBAVFORMAT_VERSION >= 52056000} // 52.56.0 + (** + * Start time of the stream in real world time, in microseconds + * since the unix epoch (00:00 1st January 1970). That is, pts=0 + * in the stream was captured at this real world time. + * - encoding: Set by user. + * - decoding: Unused. + *) + start_time_realtime: cint64; + {$IFEND} + end; (** @@ -1019,15 +1154,39 @@ procedure av_register_input_format(format: PAVInputFormat); procedure av_register_output_format(format: PAVOutputFormat); cdecl; external av__format; +{$IF LIBAVFORMAT_VERSION_MAJOR < 53} // < 53 function guess_stream_format(short_name: PAnsiChar; filename: PAnsiChar; mime_type: PAnsiChar): PAVOutputFormat; - cdecl; external av__format; + cdecl; external av__format; deprecated; +{$IFEND} +(** + * Returns the output format in the list of registered output formats + * which best matches the provided parameters, or returns NULL if + * there is no match. + * + * @param short_name if non-NULL checks if short_name matches with the + * names of the registered formats + * @param filename if non-NULL checks if filename terminates with the + * extensions of the registered formats + * @param mime_type if non-NULL checks if mime_type matches with the + * MIME type of the registered formats + *) +(** + * @deprecated Use av_guess_format() instead. + *) function guess_format(short_name: PAnsiChar; filename: PAnsiChar; mime_type: PAnsiChar): PAVOutputFormat; cdecl; external av__format; +{$IF LIBAVFORMAT_VERSION >= 52045000} // >= 52.45.0 + deprecated; +function av_guess_format(short_name: PAnsiChar; + filename: PAnsiChar; + mime_type: PAnsiChar): PAVOutputFormat; + cdecl; external av__format; +{$IFEND} (** * Guesses the codec ID based upon muxer and filename. @@ -1038,7 +1197,7 @@ function av_guess_codec(fmt: PAVOutputFormat; short_name: PAnsiChar; cdecl; external av__format; (** - * Send a nice hexadecimal dump of a buffer to the specified file stream. + * Sends a nice hexadecimal dump of a buffer to the specified file stream. * * @param f The file stream pointer where the dump should be sent to. * @param buf buffer @@ -1051,7 +1210,7 @@ procedure av_hex_dump(f: PAVFile; buf: PByteArray; size: cint); {$IF LIBAVFORMAT_VERSION >= 51011000} // 51.11.0 (** - * Send a nice hexadecimal dump of a buffer to the log. + * Sends a nice hexadecimal dump of a buffer to the log. * * @param avcl A pointer to an arbitrary struct of which the first field is a * pointer to an AVClass struct. @@ -1067,7 +1226,7 @@ procedure av_hex_dump_log(avcl: Pointer; level: cint; buf: PByteArray; size: cin {$IFEND} (** - * Send a nice dump of a packet to the specified file stream. + * Sends a nice dump of a packet to the specified file stream. * * @param f The file stream pointer where the dump should be sent to. * @param pkt packet to dump @@ -1078,7 +1237,7 @@ procedure av_pkt_dump(f: PAVFile; pkt: PAVPacket; dump_payload: cint); {$IF LIBAVFORMAT_VERSION >= 51011000} // 51.11.0 (** - * Send a nice dump of a packet to the log. + * Sends a nice dump of a packet to the log. * * @param avcl A pointer to an arbitrary struct of which the first field is a * pointer to an AVClass struct. @@ -1092,7 +1251,7 @@ procedure av_pkt_dump_log(avcl: Pointer; level: cint; pkt: PAVPacket; dump_paylo {$IFEND} (** - * Initialize libavformat and register all the muxers, demuxers and + * Initializes libavformat and registers all the muxers, demuxers and * protocols. If you do not call this function, then you can select * exactly which formats you want to support. * @@ -1104,9 +1263,23 @@ procedure av_register_all(); cdecl; external av__format; {$IF LIBAVFORMAT_VERSION >= 51008000} // 51.8.0 -(** codec tag <-> codec id *) +(** + * Gets the CodecID for the given codec tag tag. + * If no codec id is found returns CODEC_ID_NONE. + * + * @param tags list of supported codec_id-codec_tag pairs, as stored + * in AVInputFormat.codec_tag and AVOutputFormat.codec_tag + *) function av_codec_get_id(var tags: PAVCodecTag; tag: cuint): TCodecID; cdecl; external av__format; + +(** + * Gets the codec tag for the given codec id id. + * If no codec tag is found returns 0. + * + * @param tags list of supported codec_id-codec_tag pairs, as stored + * in AVInputFormat.codec_tag and AVOutputFormat.codec_tag + *) function av_codec_get_tag(var tags: PAVCodecTag; id: TCodecID): cuint; cdecl; external av__format; {$IFEND} @@ -1120,7 +1293,7 @@ function av_find_input_format(short_name: PAnsiChar): PAVInputFormat; cdecl; external av__format; (** - * Guess file format. + * Guesses file format. * * @param is_opened Whether the file is already opened; determines whether * demuxers with or without AVFMT_NOFILE are probed. @@ -1128,17 +1301,33 @@ function av_find_input_format(short_name: PAnsiChar): PAVInputFormat; function av_probe_input_format(pd: PAVProbeData; is_opened: cint): PAVInputFormat; cdecl; external av__format; +{$IF LIBAVFORMAT_VERSION >= 52062000} // 52.62.0 +(** + * Guesses the file format. + * + * @param is_opened Whether the file is already opened; determines whether + * demuxers with or without AVFMT_NOFILE are probed. + * @param score_max A probe score larger that this is required to accept a + * detection, the variable is set to the actual detection + * score afterwards. + * If the score is <= AVPROBE_SCORE_MAX / 4 it is recommended + * to retry with a larger probe buffer. + *) +function av_probe_input_format2(pd: PAVProbeData; is_opened: cint; score_max: PCint): PAVInputFormat; + cdecl; external av__format; +{$IFEND} + (** * Allocates all the structures needed to read an input stream. * This does not open the needed codecs for decoding the stream[s]. *) -function av_open_input_stream(ic_ptr: PAVFormatContext; +function av_open_input_stream(var ic_ptr: PAVFormatContext; pb: PByteIOContext; filename: PAnsiChar; fmt: PAVInputFormat; ap: PAVFormatParameters): cint; cdecl; external av__format; (** - * Open a media file as input. The codecs are not opened. Only the file + * Opens a media file as input. The codecs are not opened. Only the file * header (if present) is read. * * @param ic_ptr The opened media file handle is put here. @@ -1156,7 +1345,7 @@ function av_open_input_file(var ic_ptr: PAVFormatContext; filename: PAnsiChar; {$IF LIBAVFORMAT_VERSION >= 52026000} // 52.26.0 (** - * Allocate an AVFormatContext. + * Allocates an AVFormatContext. * Can be freed with av_free() but do not forget to free everything you * explicitly allocated as well! *) @@ -1173,7 +1362,7 @@ function av_alloc_format_context(): PAVFormatContext; {$IFEND} (** - * Read packets of a media file to get stream information. This + * Reads packets of a media file to get stream information. This * is useful for file formats with no headers such as MPEG. This * function also computes the real framerate in case of MPEG-2 repeat * frame mode. @@ -1189,7 +1378,7 @@ function av_find_stream_info(ic: PAVFormatContext): cint; cdecl; external av__format; (** - * Read a transport packet from a media file. + * Reads a transport packet from a media file. * * This function is obsolete and should never be used. * Use av_read_frame() instead. @@ -1202,7 +1391,7 @@ function av_read_packet(s: PAVFormatContext; var pkt: TAVPacket): cint; cdecl; external av__format; (** - * Return the next frame of a stream. + * Returns the next frame of a stream. * * The returned packet is valid * until the next av_read_frame() or until av_close_input_file() and @@ -1224,7 +1413,7 @@ function av_read_frame(s: PAVFormatContext; var pkt: TAVPacket): cint; cdecl; external av__format; (** - * Seek to the keyframe at timestamp. + * Seeks to the keyframe at timestamp. * 'timestamp' in 'stream_index'. * @param stream_index If stream_index is (-1), a default * stream is selected, and timestamp is automatically converted @@ -1240,7 +1429,7 @@ function av_seek_frame(s: PAVFormatContext; stream_index: cint; timestamp: cint6 {$IF LIBAVFORMAT_VERSION >= 52026000} // 52.26.0 (** - * Seek to timestamp ts. + * Seeks to timestamp ts. * Seeking will be done so that the point from which all active streams * can be presented successfully will be closest to ts and within min/max_ts. * Active streams are all streams that have AVStream.discard < AVDISCARD_ALL. @@ -1259,7 +1448,7 @@ function av_seek_frame(s: PAVFormatContext; stream_index: cint; timestamp: cint6 * @param ts target timestamp * @param max_ts largest acceptable timestamp * @param flags flags - * @returns >=0 on success, error code otherwise + * @return >=0 on success, error code otherwise * * @NOTE This is part of the new seek API which is still under construction. * Thus do not use this yet. It may change at any time, do not expect @@ -1275,14 +1464,14 @@ function avformat_seek_file(s: PAVFormatContext; {$IFEND} (** - * Start playing a network-based stream (e.g. RTSP stream) at the + * Starts playing a network-based stream (e.g. RTSP stream) at the * current position. *) function av_read_play(s: PAVFormatContext): cint; cdecl; external av__format; (** - * Pause a network-based stream (e.g. RTSP stream). + * Pauses a network-based stream (e.g. RTSP stream). * * Use av_read_play() to resume it. *) @@ -1291,7 +1480,7 @@ function av_read_pause(s: PAVFormatContext): cint; {$IF LIBAVFORMAT_VERSION >= 52003000} // 52.3.0 (** - * Free a AVFormatContext allocated by av_open_input_stream. + * Frees a AVFormatContext allocated by av_open_input_stream. * @param s context to free *) procedure av_close_input_stream(s: PAVFormatContext); @@ -1299,7 +1488,7 @@ procedure av_close_input_stream(s: PAVFormatContext); {$IFEND} (** - * Close a media file (but not its codecs). + * Closes a media file (but not its codecs). * * @param s media file handle *) @@ -1307,7 +1496,7 @@ procedure av_close_input_file(s: PAVFormatContext); cdecl; external av__format; (** - * Add a new stream to a media file. + * Adds a new stream to a media file. * * Can only be called in the read_header() function. If the flag * AVFMTCTX_NOHEADER is in the format context, then new streams @@ -1325,7 +1514,7 @@ function av_new_program(s: PAVFormatContext; id: cint): PAVProgram; {$IF LIBAVFORMAT_VERSION >= 52014000} // 52.14.0 (** - * Add a new chapter. + * Adds a new chapter. * This function is NOT part of the public API * and should ONLY be used by demuxers. * @@ -1343,7 +1532,7 @@ function ff_new_chapter(s: PAVFormatContext; id: cint; time_base: TAVRational; {$IFEND} (** - * Set the pts for a given stream. + * Sets the pts for a given stream. * * @param s stream * @param pts_wrap_bits number of bits effectively used by the pts @@ -1352,13 +1541,20 @@ function ff_new_chapter(s: PAVFormatContext; id: cint; time_base: TAVRational; * @param pts_den denominator to convert to seconds (MPEG: 90000) *) procedure av_set_pts_info(s: PAVStream; pts_wrap_bits: cint; +{$IF LIBAVFORMAT_VERSION < 52036000} // < 52.36.0 pts_num: cint; pts_den: cint); +{$ELSE} + pts_num: cuint; pts_den: cuint); +{$IFEND} cdecl; external av__format; const AVSEEK_FLAG_BACKWARD = 1; ///< seek backward AVSEEK_FLAG_BYTE = 2; ///< seeking based on position in bytes AVSEEK_FLAG_ANY = 4; ///< seek to any frame, even non-keyframes +{$IF LIBAVFORMAT_VERSION >= 52037000} // >= 52.37.0 + AVSEEK_FLAG_FRAME = 8; +{$IFEND} function av_find_default_stream_index(s: PAVFormatContext): cint; cdecl; external av__format; @@ -1387,7 +1583,7 @@ procedure ff_reduce_index(s: PAVFormatContext; stream_index: cint); {$IFEND} (** - * Add an index entry into a sorted list. Update the entry if the list + * Adds an index entry into a sorted list. Updates the entry if the list * already contains it. * * @param timestamp timestamp in the timebase of the given stream @@ -1447,7 +1643,7 @@ function av_set_parameters(s: PAVFormatContext; ap: PAVFormatParameters): cint; cdecl; external av__format; (** - * Allocate the stream private data and write the stream header to an + * Allocates the stream private data and writes the stream header to an * output media file. * * @param s media file handle @@ -1457,7 +1653,7 @@ function av_write_header(s: PAVFormatContext): cint; cdecl; external av__format; (** - * Write a packet to an output media file. + * Writes a packet to an output media file. * * The packet shall contain one audio or video frame. * The packet must be correctly interleaved according to the container @@ -1490,7 +1686,7 @@ function av_interleaved_write_frame(s: PAVFormatContext; var pkt: TAVPacket): ci cdecl; external av__format; (** - * Interleave a packet per dts in an output media file. + * Interleaves a packet per dts in an output media file. * * Packets with pkt->destruct == av_destruct_packet will be freed inside this * function, so they cannot be used after it. Note that calling av_free_packet() @@ -1527,8 +1723,8 @@ procedure ff_interleave_add_packet(s: PAVFormatContext; {$IFEND} (** - * @brief Write the stream trailer to an output media file and - * free the file private data. + * Writes the stream trailer to an output media file and frees the + * file private data. * * May only be called after a successful call to av_write_header. * @@ -1639,7 +1835,7 @@ function av_get_frame_filename(buf: PAnsiChar; buf_size: cint; {$IFEND}; (** - * Check whether filename actually is a numbered sequence generator. + * Checks whether filename actually is a numbered sequence generator. * * @param filename possible numbered sequence string * @return 1 if a valid numbered sequence string, 0 otherwise @@ -1652,7 +1848,7 @@ function av_filename_number_test(filename: PAnsiChar): cint; {$IF LIBAVFORMAT_VERSION >= 51012002} // 51.12.2 (** - * Generate an SDP for an RTP session. + * Generates an SDP for an RTP session. * * @param ac array of AVFormatContexts describing the RTP streams. If the * array is composed by only one context, such context can contain @@ -1669,6 +1865,17 @@ function avf_sdp_create(ac: PPAVFormatContext; n_files: cint; buff: PByteArray; cdecl; external av__format; {$IFEND} +{$IF LIBAVFORMAT_VERSION >= 52060000} // 52.60.0 +(** + * Returns a positive value if the given filename has one of the given + * extensions, 0 otherwise. + * + * @param extensions a comma-separated list of filename extensions + *) +function av_match_ext(filename: {const} Pchar; extensions: {const} Pchar): cint; + cdecl; external av__format; +{$IFEND} + implementation {$IF LIBAVFORMAT_VERSION < 51012002} // 51.12.2 @@ -1686,7 +1893,7 @@ begin end; {$IFEND} -{$IF LIBAVCODEC_VERSION < 52032000} // < 52.32.0 +{$IF LIBAVFORMAT_VERSION < 52032000} // < 52.32.0 procedure av_free_packet(pkt: PAVPacket); begin if ((pkt <> nil) and (@pkt^.destruct <> nil)) then diff --git a/cmake/src/lib/ffmpeg/avio.pas b/cmake/src/lib/ffmpeg/avio.pas index dc0a330b..4863ee39 100644 --- a/cmake/src/lib/ffmpeg/avio.pas +++ b/cmake/src/lib/ffmpeg/avio.pas @@ -28,11 +28,11 @@ (* * Conversion of libavformat/avio.h * unbuffered I/O operations - * revision 16100, Sat Dec 13 13:39:13 2008 UTC - * update Tue, Jun 10 01:00:00 2009 UTC - * * @warning This file has to be considered an internal but installed * header, so it should not be directly included in your projects. + * + * update to + * Max. avformat version: 52.62.0, revision 23004, Tue May 11 19:29:00 2010 CET *) unit avio; @@ -70,6 +70,16 @@ const *) AVSEEK_SIZE = $10000; +{$IF LIBAVFORMAT_VERSION >= 52056000} // 52.56.0 + (** + * Oring this flag as into the "whence" parameter to a seek function causes it to + * seek by any means (like reopening and linear reading) or other normally unreasonble + * means that can be extreemly slow. + * This may be ignored by the seek code. + *) + AVSEEK_FORCE = $20000; +{$IFEND} + type TURLInterruptCB = function (): cint; cdecl; @@ -93,7 +103,7 @@ type is_streamed: cint; (**< true if streamed (no seek possible), default = false *) max_packet_size: cint; (**< if non zero, the stream is packetized with this max packet size *) priv_data: pointer; - filename: PAnsiChar; (**< specified filename *) + filename: PAnsiChar; (**< specified URL *) end; PPURLContext = ^PURLContext; @@ -106,16 +116,54 @@ type TURLProtocol = record name: PAnsiChar; +{$IF LIBAVFORMAT_VERSION < 52047000} // 52.47.0 url_open: function (h: PURLContext; filename: {const} PAnsiChar; flags: cint): cint; cdecl; +{$ELSE} + url_open: function (h: PURLContext; url: {const} PAnsiChar; flags: cint): cint; cdecl; +{$IFEND} + +(** + * Reads up to size bytes from the resource accessed by h, and stores + * the read bytes in buf. + * + * @return The number of bytes actually read, or a negative value + * corresponding to an AVERROR code in case of error. A value of zero + * indicates that it is not possible to read more from the accessed + * resource (except if the value of the size argument is also zero). + *) url_read: function (h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; - url_read_complete: function (h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; + +(** + * Read as many bytes as possible (up to size), calling the + * read function multiple times if necessary. + * Will also retry if the read function returns AVERROR(EAGAIN). + * This makes special short-read handling in applications + * unnecessary, if the return value is < size then it is + * certain there was either an error or the end of file was reached. + *) url_write: function (h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; + +(** + * Changes the position that will be used by the next read/write + * operation on the resource accessed by h. + * + * @param pos specifies the new position to set + * @param whence specifies how pos should be interpreted, it must be + * one of SEEK_SET (seek from the beginning), SEEK_CUR (seek from the + * current position), SEEK_END (seek from the end), or AVSEEK_SIZE + * (return the filesize of the requested resource, pos is ignored). + * @return a negative value corresponding to an AVERROR code in case + * of failure, or the resulting file position, measured in bytes from + * the beginning of the file. You can use this feature together with + * SEEK_CUR to read the current file position. + *) url_seek: function (h: PURLContext; pos: cint64; whence: cint): cint64; cdecl; + url_close: function (h: PURLContext): cint; cdecl; next: PURLProtocol; {$IF (LIBAVFORMAT_VERSION >= 52001000) and (LIBAVFORMAT_VERSION < 52004000)} // 52.1.0 .. 52.4.0 - url_read_play: function (h: PURLContext): cint; - url_read_pause: function (h: PURLContext): cint; + url_read_play: function (h: PURLContext): cint; cdecl; + url_read_pause: function (h: PURLContext): cint; cdecl; {$IFEND} {$IF LIBAVFORMAT_VERSION >= 52004000} // 52.4.0 url_read_pause: function (h: PURLContext; pause: cint): cint; cdecl; @@ -124,6 +172,9 @@ type url_read_seek: function (h: PURLContext; stream_index: cint; timestamp: cint64; flags: cint): cint64; cdecl; {$IFEND} + {$IF LIBAVFORMAT_VERSION >= 52031000} // 52.31.0 + url_get_file_handle: function (h: PURLContext): cint; cdecl; + {$IFEND} end; (** @@ -168,31 +219,85 @@ type {$IF LIBAVFORMAT_VERSION >= 52021000} // 52.21.0 +(** + * Creates an URLContext for accessing to the resource indicated by + * URL, and opens it using the URLProtocol up. + * + * @param puc pointer to the location where, in case of success, the + * function puts the pointer to the created URLContext + * @param flags flags which control how the resource indicated by URL + * is to be opened + * @return 0 in case of success, a negative value corresponding to an + * AVERROR code in case of failure + *) function url_open_protocol(puc: PPURLContext; up: PURLProtocol; +{$IF LIBAVFORMAT_VERSION < 52047000} // 52.47.0 filename: {const} PAnsiChar; flags: cint): cint; +{$ELSE} + url: {const} PAnsiChar; flags: cint): cint; +{$IFEND} cdecl; external av__format; {$IFEND} + +(** + * Creates an URLContext for accessing to the resource indicated by + * url, and opens it. + * + * @param puc pointer to the location where, in case of success, the + * function puts the pointer to the created URLContext + * @param flags flags which control how the resource indicated by url + * is to be opened + * @return 0 in case of success, a negative value corresponding to an + * AVERROR code in case of failure + *) +{$IF LIBAVFORMAT_VERSION < 52047000} // 52.47.0 function url_open(h: PPointer; filename: {const} PAnsiChar; flags: cint): cint; +{$ELSE} +function url_open(h: PPointer; url: {const} PAnsiChar; flags: cint): cint; +{$IFEND} cdecl; external av__format; function url_read (h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; external av__format; +{$IF LIBAVFORMAT_VERSION >= 52034000} // 52.34.0 +function url_read_complete (h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; + cdecl; external av__format; +{$IFEND} function url_write (h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; external av__format; function url_seek (h: PURLContext; pos: cint64; whence: cint): cint64; cdecl; external av__format; + +(** + * Closes the resource accessed by the URLContext h, and frees the + * memory used by it. + * + * @return a negative value if an error condition occurred, 0 + * otherwise + *) function url_close (h: PURLContext): cint; cdecl; external av__format; + +(** + * Returns a non-zero value if the resource indicated by url + * exists, 0 otherwise. + *) +{$IF LIBAVFORMAT_VERSION < 52047000} // 52.47.0 function url_exist(filename: {const} PAnsiChar): cint; +{$ELSE} +function url_exist(url: {const} PAnsiChar): cint; +{$IFEND} cdecl; external av__format; + function url_filesize (h: PURLContext): cint64; cdecl; external av__format; -{ + +(** * Return the file descriptor associated with this URL. For RTP, this * will return only the RTP file descriptor, not the RTCP file descriptor. * To get both, use rtp_get_file_handles(). * * @return the file descriptor associated with this URL, or <0 on error. -} + *) (* not implemented *) function url_get_file_handle(h: PURLContext): cint; cdecl; external av__format; @@ -264,30 +369,36 @@ var url_interrupt_cb: PURLInterruptCB; external av__format; **) -{ -* If protocol is NULL, returns the first registered protocol, -* if protocol is non-NULL, returns the next registered protocol after protocol, -* or NULL if protocol is the last one. -} {$IF LIBAVFORMAT_VERSION >= 52002000} // 52.2.0 +(** + * If protocol is NULL, returns the first registered protocol, + * if protocol is non-NULL, returns the next registered protocol after protocol, + * or NULL if protocol is the last one. + *) function av_protocol_next(p: PURLProtocol): PURLProtocol; cdecl; external av__format; {$IFEND} {$IF LIBAVFORMAT_VERSION <= 52028000} // 52.28.0 (** + * Registers the URLProtocol protocol. + *) +(** * @deprecated Use av_register_protocol() instead. *) -function register_protocol (protocol: PURLProtocol): cint; +function register_protocol(protocol: PURLProtocol): cint; cdecl; external av__format; +(** Alias for register_protocol() *) +function av_register_protocol(protocol: PURLProtocol): cint; + cdecl; external av__format name 'register_protocol'; {$ELSE} -function av_register_protocol (protocol: PURLProtocol): cint; +function av_register_protocol(protocol: PURLProtocol): cint; cdecl; external av__format; {$IFEND} type - TReadWriteFunc = function (opaque: Pointer; buf: PByteArray; buf_size: cint): cint; cdecl; - TSeekFunc = function (opaque: Pointer; offset: cint64; whence: cint): cint64; cdecl; + TReadWriteFunc = function(opaque: Pointer; buf: PByteArray; buf_size: cint): cint; cdecl; + TSeekFunc = function(opaque: Pointer; offset: cint64; whence: cint): cint64; cdecl; function init_put_byte(s: PByteIOContext; buffer: PByteArray; @@ -400,11 +511,10 @@ function url_fgets(s: PByteIOContext; buf: PAnsiChar; buf_size: cint): PAnsiChar procedure put_flush_packet (s: PByteIOContext); cdecl; external av__format; - (** * Reads size bytes from ByteIOContext into buf. - * @returns number of bytes read or AVERROR + * @return number of bytes read or AVERROR *) function get_buffer(s: PByteIOContext; buf: PByteArray; size: cint): cint; cdecl; external av__format; @@ -413,7 +523,7 @@ function get_buffer(s: PByteIOContext; buf: PByteArray; size: cint): cint; * Reads size bytes from ByteIOContext into buf. * This reads at most 1 packet. If that is not enough fewer bytes will be * returned. - * @returns number of bytes read or AVERROR + * @return number of bytes read or AVERROR *) function get_partial_buffer(s: PByteIOContext; buf: PByteArray; size: cint): cint; cdecl; external av__format; @@ -449,8 +559,17 @@ function ff_get_v(bc: PByteIOContext): cuint64; function url_is_streamed(s: PByteIOContext): cint; {$IFDEF HasInline}inline;{$ENDIF} -(** @note when opened as read/write, the buffers are only used for - writing *) +(** + * Creates and initializes a ByteIOContext for accessing the + * resource referenced by the URLContext h. + * @note When the URLContext h has been opened in read+write mode, the + * ByteIOContext can be used only for writing. + * + * @param s Used to return the pointer to the created ByteIOContext. + * In case of failure the pointed to value is set to NULL. + * @return 0 in case of success, a negative value corresponding to an + * AVERROR code in case of failure + *) {$IF LIBAVFORMAT_VERSION >= 52000000} // 52.0.0 function url_fdopen (var s: PByteIOContext; h: PURLContext): cint; {$ELSE} @@ -462,6 +581,7 @@ function url_fdopen (s: PByteIOContext; h: PURLContext): cint; function url_setbufsize (s: PByteIOContext; buf_size: cint): cint; cdecl; external av__format; +{$IF LIBAVFORMAT_VERSION_MAJOR < 53} {$IF LIBAVFORMAT_VERSION >= 51015000} // 51.15.0 (** Reset the buffer for reading or writing. * @note Will drop any data currently in the buffer without transmitting it. @@ -470,14 +590,48 @@ function url_setbufsize (s: PByteIOContext; buf_size: cint): cint; function url_resetbuf(s: PByteIOContext; flags: cint): cint; cdecl; external av__format; {$IFEND} +{$IFEND} -(** @note when opened as read/write, the buffers are only used for - writing *) +{$IF LIBAVFORMAT_VERSION >= 52061000} // 52.61.0 +(** + * Rewinds the ByteIOContext using the specified buffer containing the first buf_size bytes of the file. + * Used after probing to avoid seeking. + * Joins buf and s->buffer, taking any overlap into consideration. + * @note s->buffer must overlap with buf or they can't be joined and the function fails + * @note This function is NOT part of the public API + * + * @param s The read-only ByteIOContext to rewind + * @param buf The probe buffer containing the first buf_size bytes of the file + * @param buf_size The size of buf + * @return 0 in case of success, a negative value corresponding to an + * AVERROR code in case of failure + *) +function ff_rewind_with_probe_data(s: PByteIOContext; buf: PAnsiChar; buf_size: cint): cint; + cdecl; external av__format; +{$IFEND} + +(** + * Creates and initializes a ByteIOContext for accessing the + * resource indicated by url. + * @note When the resource indicated by url has been opened in + * read+write mode, the ByteIOContext can be used only for writing. + * + * @param s Used to return the pointer to the created ByteIOContext. + * In case of failure the pointed to value is set to NULL. + * @param flags flags which control how the resource indicated by url + * is to be opened + * @return 0 in case of success, a negative value corresponding to an + * AVERROR code in case of failure + *) +{$IF LIBAVFORMAT_VERSION < 52047000} // 52.47.0 {$IF LIBAVFORMAT_VERSION >= 52000000} // 52.0.0 function url_fopen(var s: PByteIOContext; filename: {const} PAnsiChar; flags: cint): cint; {$ELSE} function url_fopen(s: PByteIOContext; filename: {const} PAnsiChar; flags: cint): cint; {$IFEND} +{$ELSE} +function url_fopen(var s: PByteIOContext; url: {const} PAnsiChar; flags: cint): cint; +{$IFEND} cdecl; external av__format; function url_fclose(s: PByteIOContext): cint; cdecl; external av__format; diff --git a/cmake/src/lib/ffmpeg/avutil.pas b/cmake/src/lib/ffmpeg/avutil.pas index 6a93ea12..c26700c6 100644 --- a/cmake/src/lib/ffmpeg/avutil.pas +++ b/cmake/src/lib/ffmpeg/avutil.pas @@ -28,22 +28,20 @@ * Conversions of * * libavutil/avutil.h: - * Min. version: 49.0.1, revision 6577, Sat Oct 7 15:30:46 2006 UTC - * Max. version: 49.14.0, revision 16912, Sun Feb 1 02:00:19 2009 UTC + * Min. version: 49.0.1, revision 6577, Sat Oct 7 15:30:46 2006 UTC + * Max. version: 50.15.2, revision 23059, Tue May 11 22:05:00 2010 CET * * libavutil/mem.h: * revision 16590, Tue Jan 13 23:44:16 2009 UTC * * libavutil/log.h: * revision 16571, Tue Jan 13 00:14:43 2009 UTC + * + * include/keep pixfmt.h (change in revision 50.01.0) + * Maybe, the pixelformats are not needed, but it has not been checked. + * log.h is only partial. + * *) -{ - Update changes auf avutil.h, mem.h and log.h - Max. version 50.03.0, Tue, Jun 09 24:00:00 2009 UTC - include/keep pixfmt.h (change in revision 50.01.0) - Maybe, the pixelformats are not needed, but it has not been checked. - log.h is only partial. -} unit avutil; @@ -65,13 +63,41 @@ uses ctypes, mathematics, rational, + {$IFDEF UNIX} + BaseUnix, + {$ENDIF} UConfig; const + (* + * IMPORTANT: The official FFmpeg C headers change very quickly. Often some + * of the data structures are changed so that they become incompatible with + * older header files. The Pascal headers have to be adjusted to those changes, + * otherwise the application might crash randomly or strange bugs (not + * necessarily related to video or audio due to buffer overflows etc.) might + * occur. + * + * In the past users reported problems with USDX that took hours to fix and + * the problem was an unsupported version of FFmpeg. So we decided to disable + * support for future versions of FFmpeg until the headers are revised by us + * for that version as they otherwise most probably will break USDX. + * + * If the headers do not yet support your FFmpeg version you may want to + * adjust the max. version numbers manually but please note: it may work but + * in many cases it does not. The USDX team does NOT PROVIDE ANY SUPPORT + * for the game if the MAX. VERSION WAS CHANGED. + * + * The only safe way to support new versions of FFmpeg is to add the changes + * of the FFmpeg git repository C headers to the Pascal headers. + * You can accelerate this process by posting a patch with the git changes + * translated to Pascal to our bug tracker (please join our IRC chat before + * you start working on it). Simply adjusting the max. versions is NOT a valid + * fix. + *) (* Max. supported version by this header *) LIBAVUTIL_MAX_VERSION_MAJOR = 50; - LIBAVUTIL_MAX_VERSION_MINOR = 3; - LIBAVUTIL_MAX_VERSION_RELEASE = 0; + LIBAVUTIL_MAX_VERSION_MINOR = 15; + LIBAVUTIL_MAX_VERSION_RELEASE = 2; LIBAVUTIL_MAX_VERSION = (LIBAVUTIL_MAX_VERSION_MAJOR * VERSION_MAJOR) + (LIBAVUTIL_MAX_VERSION_MINOR * VERSION_MINOR) + (LIBAVUTIL_MAX_VERSION_RELEASE * VERSION_RELEASE); @@ -101,6 +127,41 @@ function avutil_version(): cuint; cdecl; external av__format; {$IFEND} +{$IF LIBAVUTIL_VERSION >= 50004000} // >= 50.4.0 +(** + * Returns the libavutil build-time configuration. + *) +function avutil_configuration(): PAnsiChar; + cdecl; external av__format; + +(** + * Returns the libavutil license. + *) +function avutil_license(): PAnsiChar; + cdecl; external av__format; +{$IFEND} + +{ + TAVMediaType moved to avutil in LIBAVUTIL_VERSION 50.14.0 + but moving it in the pascal headers was not really necessary + but caused problems. So, I (KMS) left it there. + +type + TAVMediaType = ( + AVMEDIA_TYPE_UNKNOWN = -1, + AVMEDIA_TYPE_VIDEO, + AVMEDIA_TYPE_AUDIO, + AVMEDIA_TYPE_DATA, + AVMEDIA_TYPE_SUBTITLE, + AVMEDIA_TYPE_ATTACHMENT, + AVMEDIA_TYPE_NB + ); +} + +{$INCLUDE error.pas} + +(* libavutil/pixfmt.h up to revision 23144, May 16 2010 *) + type (** * Pixel format. Notes: @@ -148,8 +209,8 @@ type PIX_FMT_RGB555, ///< packed RGB 5:5:5, 16bpp, (msb)1A 5R 5G 5B(lsb), in CPU endianness, most significant bit to 0 {$IFEND} PIX_FMT_GRAY8, ///< Y , 8bpp - PIX_FMT_MONOWHITE, ///< Y , 1bpp, 0 is white, 1 is black - PIX_FMT_MONOBLACK, ///< Y , 1bpp, 0 is black, 1 is white + PIX_FMT_MONOWHITE, ///< Y , 1bpp, 0 is white, 1 is black, in each byte pixels are ordered from the msb to the lsb + PIX_FMT_MONOBLACK, ///< Y , 1bpp, 0 is black, 1 is white, in each byte pixels are ordered from the msb to the lsb PIX_FMT_PAL8, ///< 8 bit with PIX_FMT_RGB32 palette PIX_FMT_YUVJ420P, ///< planar YUV 4:2:0, 12bpp, full scale (JPEG) PIX_FMT_YUVJ422P, ///< planar YUV 4:2:2, 16bpp, full scale (JPEG) @@ -166,12 +227,12 @@ type PIX_FMT_BGR555, ///< packed RGB 5:5:5, 16bpp, (msb)1A 5B 5G 5R(lsb), in CPU endianness, most significant bit to 1 {$IFEND} PIX_FMT_BGR8, ///< packed RGB 3:3:2, 8bpp, (msb)2B 3G 3R(lsb) - PIX_FMT_BGR4, ///< packed RGB 1:2:1, 4bpp, (msb)1B 2G 1R(lsb) + PIX_FMT_BGR4, ///< packed RGB 1:2:1, bitstream, 4bpp, (msb)1B 2G 1R(lsb), a byte contains two pixels, the first pixel in the byte is the one composed by the 4 msb bits PIX_FMT_BGR4_BYTE, ///< packed RGB 1:2:1, 8bpp, (msb)1B 2G 1R(lsb) PIX_FMT_RGB8, ///< packed RGB 3:3:2, 8bpp, (msb)2R 3G 3B(lsb) - PIX_FMT_RGB4, ///< packed RGB 1:2:1, 4bpp, (msb)1R 2G 1B(lsb) + PIX_FMT_RGB4, ///< packed RGB 1:2:1, bitstream, 4bpp, (msb)1R 2G 1B(lsb), a byte contains two pixels, the first pixel in the byte is the one composed by the 4 msb bits PIX_FMT_RGB4_BYTE, ///< packed RGB 1:2:1, 8bpp, (msb)1R 2G 1B(lsb) - PIX_FMT_NV12, ///< planar YUV 4:2:0, 12bpp, 1 plane for Y and 1 for UV + PIX_FMT_NV12, ///< planar YUV 4:2:0, 12bpp, 1 plane for Y and 1 plane for the UV components, which are interleaved (first byte U and the following byte V) PIX_FMT_NV21, ///< as above, but U and V bytes are swapped {$IF LIBAVUTIL_VERSION <= 50001000} // 50.01.0 PIX_FMT_RGB32_1, ///< packed RGB 8:8:8, 32bpp, (msb)8R 8G 8B 8A(lsb), in CPU endianness @@ -193,8 +254,8 @@ type PIX_FMT_VDPAU_WMV3,///< WMV3 HW decoding with VDPAU, data[0] contains a vdpau_render_state struct which contains the bitstream of the slices as well as various fields extracted from headers PIX_FMT_VDPAU_VC1, ///< VC-1 HW decoding with VDPAU, data[0] contains a vdpau_render_state struct which contains the bitstream of the slices as well as various fields extracted from headers {$IF LIBAVUTIL_VERSION >= 49015000} // 49.15.0 - PIX_FMT_RGB48BE, ///< packed RGB 16:16:16, 48bpp, 16R, 16G, 16B, big-endian - PIX_FMT_RGB48LE, ///< packed RGB 16:16:16, 48bpp, 16R, 16G, 16B, little-endian + PIX_FMT_RGB48BE, ///< packed RGB 16:16:16, 48bpp, 16R, 16G, 16B, the 2-byte value for each R/G/B component is stored as big-endian + PIX_FMT_RGB48LE, ///< packed RGB 16:16:16, 48bpp, 16R, 16G, 16B, the 2-byte value for each R/G/B component is stored as little-endian {$IFEND} {$IF LIBAVUTIL_VERSION >= 50001000} // 50.01.0 PIX_FMT_RGB565BE, ///< packed RGB 5:6:5, 16bpp, (msb) 5R 6G 5B(lsb), big-endian @@ -267,11 +328,13 @@ const PIX_FMT_YUV422 = PIX_FMT_YUYV422; {$IFEND} -(* libavutil/common.h *) // until now MKTAG is all from common.h KMS 9/6/2009 +(* libavutil/common.h *) // until now MKTAG and MKBETAG is all from common.h KMS 19/5/2010 function MKTAG(a, b, c, d: AnsiChar): integer; +function MKBETAG(a, b, c, d: AnsiChar): integer; (* libavutil/mem.h *) + (* memory handling functions *) (** @@ -287,7 +350,7 @@ function av_malloc(size: cuint): pointer; (** * Allocates or reallocates a block of memory. - * If ptr is NULL and size > 0, allocates a new block. If \p + * If ptr is NULL and size > 0, allocates a new block. If * size is zero, frees the memory block pointed to by ptr. * @param size Size in bytes for the memory block to be allocated or * reallocated. @@ -326,7 +389,7 @@ function av_mallocz(size: cuint): pointer; * Duplicates the string s. * @param s string to be duplicated. * @return Pointer to a newly allocated string containing a - * copy of \p s or NULL if the string cannot be allocated. + * copy of s or NULL if the string cannot be allocated. *) function av_strdup({const} s: PAnsiChar): PAnsiChar; cdecl; external av__util; {av_malloc_attrib} @@ -388,11 +451,40 @@ const AV_LOG_DEBUG = 48; {$IFEND} +(** + * Sends the specified message to the log if the level is less than or equal + * to the current av_log_level. By default, all logging messages are sent to + * stderr. This behavior can be altered by setting a different av_vlog callback + * function. + * + * @param avcl A pointer to an arbitrary struct of which the first field is a + * pointer to an AVClass struct. + * @param level The importance level of the message, lower values signifying + * higher importance. + * @param fmt The format string (printf-compatible) that specifies how + * subsequent arguments are converted to output. + * @see av_vlog + *) + +{** to be translated if needed +#ifdef __GNUC__ +void av_log(void*, int level, const char *fmt, ...) __attribute__ ((__format__ (__printf__, 3, 4))); +#else +void av_log(void*, int level, const char *fmt, ...); +#endif + +void av_vlog(void*, int level, const char *fmt, va_list); +**} + function av_log_get_level(): cint; cdecl; external av__util; procedure av_log_set_level(level: cint); cdecl; external av__util; +{** to be translated if needed +void av_log_set_callback(void (*)(void*, int, const char*, va_list)); +void av_log_default_callback(void* ptr, int level, const char* fmt, va_list vl); +**} implementation @@ -403,4 +495,10 @@ begin Result := (ord(a) or (ord(b) shl 8) or (ord(c) shl 16) or (ord(d) shl 24)); end; +function MKBETAG(a, b, c, d: AnsiChar): integer; +begin + Result := (ord(d) or (ord(c) shl 8) or (ord(b) shl 16) or (ord(a) shl 24)); +end; + + end. diff --git a/cmake/src/lib/ffmpeg/error.pas b/cmake/src/lib/ffmpeg/error.pas new file mode 100644 index 00000000..95cecd0f --- /dev/null +++ b/cmake/src/lib/ffmpeg/error.pas @@ -0,0 +1,113 @@ +(* + * This file is part of FFmpeg. + * + * FFmpeg is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * FFmpeg is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with FFmpeg; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * + * This is a part of the Pascal port of ffmpeg. + * - Changes and updates by the UltraStar Deluxe Team + * + * Conversion of libavutil/error.h + * Max. avutil version: 50.15.2, revision 23059, Tue May 11 18:30 2010 CET + * + *) + +{$IF LIBAVUTIL_VERSION >= 50012000} // >= 50.12.0 + +{* error handling *} + +const +{$IFDEF UNIX} + ENOENT = ESysENOENT; + EIO = ESysEIO; + ENOMEM = ESysENOMEM; + EINVAL = ESysEINVAL; + EDOM = ESysEDOM; + ENOSYS = ESysENOSYS; + EILSEQ = ESysEILSEQ; + EPIPE = ESysEPIPE; +{$ELSE} + ENOENT = 2; + EIO = 5; + ENOMEM = 12; + EINVAL = 22; + EPIPE = 32; // just an assumption. needs to be checked. + EDOM = 33; + {$IFDEF MSWINDOWS} + // Note: we assume that ffmpeg was compiled with MinGW. + // This must be changed if DLLs were compiled with cygwin. + ENOSYS = 40; // MSVC/MINGW: 40, CYGWIN: 88, LINUX/FPC: 38 + EILSEQ = 42; // MSVC/MINGW: 42, CYGWIN: 138, LINUX/FPC: 84 + {$ENDIF} +{$ENDIF} + +(** + * We need the sign of the error, because some platforms have + * E* and errno already negated. The previous version failed + * with Delphi, because it needed EINVAL defined. + * Warning: This code is platform dependent and assumes constants + * to be 32 bit. + * This version does the following steps: + * 1) shr 30: shifts the sign bit to bit position 2 + * 2) and $00000002: sets all other bits to zero + * positive EINVAL gives 0, negative gives 2 + * 3) not: inverts all bits. This gives -1 and -3 + * 3) - 1: positive EINVAL gives -1, negative 1 + *) +const + AVERROR_SIGN = (EINVAL shr 30) and $00000002 - 1; + +(* +#if EINVAL > 0 +#define AVERROR(e) (-(e)) {**< Returns a negative error code from a POSIX error code, to return from library functions. *} +#define AVUNERROR(e) (-(e)) {**< Returns a POSIX error code from a library function error return value. *} +#else +{* Some platforms have E* and errno already negated. *} +#define AVERROR(e) (e) +#define AVUNERROR(e) (e) +#endif +*) + +const + AVERROR_UNKNOWN = AVERROR_SIGN * EINVAL; (**< unknown error *) + AVERROR_IO = AVERROR_SIGN * EIO; (**< I/O error *) + AVERROR_NUMEXPECTED = AVERROR_SIGN * EDOM; (**< Number syntax expected in filename. *) + AVERROR_INVALIDDATA = AVERROR_SIGN * EINVAL; (**< invalid data found *) + AVERROR_NOMEM = AVERROR_SIGN * ENOMEM; (**< not enough memory *) + AVERROR_NOFMT = AVERROR_SIGN * EILSEQ; (**< unknown format *) + AVERROR_NOTSUPP = AVERROR_SIGN * ENOSYS; (**< Operation not supported. *) + AVERROR_NOENT = AVERROR_SIGN * ENOENT; (**< No such file or directory. *) +{$IF LIBAVCODEC_VERSION >= 52017000} // 52.17.0 + AVERROR_EOF = AVERROR_SIGN * EPIPE; (**< End of file. *) +{$IFEND} + // Note: function calls as constant-initializers are invalid + //AVERROR_PATCHWELCOME = -MKTAG('P','A','W','E'); {**< Not yet implemented in FFmpeg. Patches welcome. *} + AVERROR_PATCHWELCOME = -(ord('P') or (ord('A') shl 8) or (ord('W') shl 16) or (ord('E') shl 24)); +{$IFEND} + +{$IF LIBAVUTIL_VERSION >= 50013000} // >= 50.13.0 +(* + * Puts a description of the AVERROR code errnum in errbuf. + * In case of failure the global variable errno is set to indicate the + * error. Even in case of failure av_strerror() will print a generic + * error message indicating the errnum provided to errbuf. + * + * @param errbuf_size the size in bytes of errbuf + * @return 0 on success, a negative value if a description for errnum + * cannot be found + *) + +function av_strerror(errnum: cint; errbuf: Pchar; errbuf_size: cint): cint; + cdecl; external av__util; +{$IFEND} diff --git a/cmake/src/lib/ffmpeg/mathematics.pas b/cmake/src/lib/ffmpeg/mathematics.pas index 92ee0a5e..3a1f6a2c 100644 --- a/cmake/src/lib/ffmpeg/mathematics.pas +++ b/cmake/src/lib/ffmpeg/mathematics.pas @@ -26,10 +26,8 @@ (* * Conversion of libavutil/mathematics.h - * revision 16844, Wed Jan 28 08:50:10 2009 UTC + * avutil max. version 50.15.2, revision 23059, Tue May 11 22:10:00 2010 CET * - * update, MiSchi, no code change - * Fri Jun 12 2009 21:50:00 UTC *) unit mathematics; @@ -53,8 +51,18 @@ const M_E = 2.7182818284590452354; // e M_LN2 = 0.69314718055994530942; // log_e 2 M_LN10 = 2.30258509299404568402; // log_e 10 +{$IF LIBAVUTIL_VERSION >= 50009000} // >= 50.9.0 + M_LOG2_10 = 3.32192809488736234787; // log_2 10 +{$IFEND} M_PI = 3.14159265358979323846; // pi M_SQRT1_2 = 0.70710678118654752440; // 1/sqrt(2) +{$IF LIBAVUTIL_VERSION >= 50014000} // >= 50.14.0 + M_SQRT2 = 1.41421356237309504880; // sqrt(2) +{$IFEND} +{$IF LIBAVUTIL_VERSION >= 50005001} // >= 50.5.1 + NAN = 0.0/0.0; + INFINITY = 1.0/0.0; +{$IFEND} type TAVRounding = ( @@ -66,6 +74,11 @@ type ); {$IF LIBAVUTIL_VERSION >= 49013000} // 49.13.0 +(** + * Returns the greatest common divisor of a and b. + * If both a or b are 0 or either or both are <0 then behavior is + * undefined. + *) function av_gcd(a: cint64; b: cint64): cint64; cdecl; external av__util; {av_const} {$IFEND} @@ -90,6 +103,17 @@ function av_rescale_rnd (a, b, c: cint64; enum: TAVRounding): cint64; function av_rescale_q (a: cint64; bq, cq: TAVRational): cint64; cdecl; external av__util; {av_const} +{$IF LIBAVUTIL_VERSION >= 50008000} // 50.8.0 +(** + * Compares 2 timestamps each in its own timebases. + * The result of the function is undefined if one of the timestamps + * is outside the int64_t range when represented in the others timebase. + * @return -1 if ts_a is before ts_b, 1 if ts_a is after ts_b or 0 if they represent the same position + *) +function av_compare_ts(ts_a: cint64; tb_a: TAVRational; ts_b: cint64; tb_b: TAVRational): cint; + cdecl; external av__util; +{$IFEND} + implementation end. diff --git a/cmake/src/lib/ffmpeg/opt.pas b/cmake/src/lib/ffmpeg/opt.pas index a2e2cce9..c755ed35 100644 --- a/cmake/src/lib/ffmpeg/opt.pas +++ b/cmake/src/lib/ffmpeg/opt.pas @@ -23,14 +23,10 @@ * - For Mac OS X, some modifications were made by The Creative CAT, denoted as CAT * in the source codes. * - Changes and updates by the UltraStar Deluxe Team - *) - -(* + * * Conversion of libavcodec/opt.h - * revision 16912, Sun Feb 1 02:00:19 2009 UTC + * Max. avcodec version: 52.67.0, revision 23057, Tue May 11 18:17 2010 CET * - * update, MiSchi, no code change - * Fri Jun 12 2009 21:50:00 UTC *) unit opt; @@ -110,6 +106,53 @@ type unit_: {const} PAnsiChar; end; +{$IF LIBAVCODEC_VERSION >= 52042000} // >= 52.42.0 +(** + * AVOption2. + * THIS IS NOT PART OF THE API/ABI YET! + * This is identical to AVOption except that default_val was replaced by + * an union, it should be compatible with AVOption on normal platforms. + *) +type + PAVOption2 = ^TAVOption2; + TAVOption2 = record + name : {const} PAnsiChar; + + (** + * short English help text + * @todo What about other languages? + *) + help : {const} PAnsiChar; + + (** + * The offset relative to the context structure where the option + * value is stored. It should be 0 for named constants. + *) + offset : cint; + type_ : TAVOptionType; + + (** + * the default value for scalar options + *) + default_val : record + case cint of + 0 : (dbl: cdouble); + 1 : (str: PAnsiChar); + end; + min : cdouble; + max : cdouble; + flags : cint; +//FIXME think about enc-audio, ... style flags + + (** + * The logical unit to which the option belongs. Non-constant + * options and corresponding named constants share the same + * unit. May be NULL. + *) + unit_: {const} PAnsiChar; + end; +{$IFEND} + {$IF LIBAVCODEC_VERSION >= 51039000} // 51.39.0 (** * Looks for an option in obj. Looks only for the options which @@ -189,10 +232,10 @@ function av_set_q(obj: pointer; name: {const} PAnsiChar; n: TAVRational): PAVOpt function av_set_int(obj: pointer; name: {const} PAnsiChar; n: cint64): PAVOption; cdecl; external av__codec; -function av_get_double(obj: pointer; name: {const} PAnsiChar; var o_out: PAVOption): cdouble; +function av_get_double(obj: pointer; name: {const} PAnsiChar; var o_out: {const} PAVOption): cdouble; cdecl; external av__codec; -function av_get_q(obj: pointer; name: {const} PAnsiChar; var o_out: PAVOption): TAVRational; +function av_get_q(obj: pointer; name: {const} PAnsiChar; var o_out: {const} PAVOption): TAVRational; cdecl; external av__codec; function av_get_int(obj: pointer; name: {const} PAnsiChar; var o_out: {const} PAVOption): cint64; diff --git a/cmake/src/lib/ffmpeg/rational.pas b/cmake/src/lib/ffmpeg/rational.pas index b940009d..6ca9c0d1 100644 --- a/cmake/src/lib/ffmpeg/rational.pas +++ b/cmake/src/lib/ffmpeg/rational.pas @@ -27,10 +27,8 @@ (* * Conversion of libavutil/rational.h - * revision 16912, Sun Feb 1 02:00:19 2009 UTC + * avutil max. version 50.15.2, revision 23059, Tue May 11 22:10:00 2010 CET * - * update, MiSchi, no code change - * Fri Jun 12 2009 22:20:00 UTC *) unit rational; diff --git a/cmake/src/lib/ffmpeg/src/MacOSX/MacOSXReadMe.txt b/cmake/src/lib/ffmpeg/src/MacOSX/MacOSXReadMe.txt deleted file mode 100644 index c2f5826a..00000000 --- a/cmake/src/lib/ffmpeg/src/MacOSX/MacOSXReadMe.txt +++ /dev/null @@ -1,24 +0,0 @@ -If you are using fink to install ffmpeg and friends, -you can skip the rest of this notes. - -How to download an build ffmpeg for UltraStar Deluxe on Mac OS X: - -1. Open a terminal. - -2. cd into the Game/Code/lib/ffmpeg/src/MacOSX directory - -3. Run the following command: - -svn checkout svn://svn.mplayerhq.hu/ffmpeg/trunk ffmpeg - -4. The compile ffmpeg. I made a script for this: - -./build_ffmpeg.sh - -5. On OS X you have to patch the the dylibs. Run the following - script. It patches the dylibs and copies them to the - lib/ffmpeg dir: - -./copy_and_patch_dylibs.sh - -You're done. diff --git a/cmake/src/lib/ffmpeg/src/MacOSX/build_ffmpeg.sh b/cmake/src/lib/ffmpeg/src/MacOSX/build_ffmpeg.sh deleted file mode 100755 index bcb3ca1e..00000000 --- a/cmake/src/lib/ffmpeg/src/MacOSX/build_ffmpeg.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/bash - -cd ffmpeg -./configure --enable-shared --disable-static --disable-mmx -make - diff --git a/cmake/src/lib/ffmpeg/src/MacOSX/copy_and_patch_dylibs.sh b/cmake/src/lib/ffmpeg/src/MacOSX/copy_and_patch_dylibs.sh deleted file mode 100755 index 064d2ecc..00000000 --- a/cmake/src/lib/ffmpeg/src/MacOSX/copy_and_patch_dylibs.sh +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/bash - -# Copy dylibs: -cp ffmpeg/libavcodec/libavcodec.51.dylib ../../libavcodec.dylib -cp ffmpeg/libavformat/libavformat.52.dylib ../../libavformat.dylib -cp ffmpeg/libavutil/libavutil.49.dylib ../../libavutil.dylib - -# Patching libavcodec: -install_name_tool -id @executable_path/libavcodec.dylib ../../libavcodec.dylib -install_name_tool -change /usr/local/lib/libavutil.dylib @executable_path/libavutil.dylib ../../libavcodec.dylib - -# Patching libavformat: -install_name_tool -id @executable_path/libavformat.dylib ../../libavformat.dylib -install_name_tool -change /usr/local/lib/libavutil.dylib @executable_path/libavutil.dylib ../../libavformat.dylib -install_name_tool -change /usr/local/lib/libavcodec.dylib @executable_path/libavcodec.dylib ../../libavformat.dylib - -# Patching libavcodec: -install_name_tool -id @executable_path/libavutil.dylib ../../libavutil.dylib - -# Printing result: -otool -L ../../libavutil.dylib -otool -L ../../libavcodec.dylib -otool -L ../../libavformat.dylib
\ No newline at end of file diff --git a/cmake/src/lib/ffmpeg/swscale.pas b/cmake/src/lib/ffmpeg/swscale.pas index c0aabf45..4f923f04 100644 --- a/cmake/src/lib/ffmpeg/swscale.pas +++ b/cmake/src/lib/ffmpeg/swscale.pas @@ -23,7 +23,7 @@ (* * Conversion of libswscale/swscale.h - * revision 27592, Fri Sep 12 21:46:53 2008 UTC + * Max. version: 0.10.0, revision 31050, Tue May 11 19:40:00 2010 CET *) unit swscale; @@ -49,10 +49,35 @@ uses UConfig; const + (* + * IMPORTANT: The official FFmpeg C headers change very quickly. Often some + * of the data structures are changed so that they become incompatible with + * older header files. The Pascal headers have to be adjusted to those changes, + * otherwise the application might crash randomly or strange bugs (not + * necessarily related to video or audio due to buffer overflows etc.) might + * occur. + * + * In the past users reported problems with USDX that took hours to fix and + * the problem was an unsupported version of FFmpeg. So we decided to disable + * support for future versions of FFmpeg until the headers are revised by us + * for that version as they otherwise most probably will break USDX. + * + * If the headers do not yet support your FFmpeg version you may want to + * adjust the max. version numbers manually but please note: it may work but + * in many cases it does not. The USDX team does NOT PROVIDE ANY SUPPORT + * for the game if the MAX. VERSION WAS CHANGED. + * + * The only safe way to support new versions of FFmpeg is to add the changes + * of the FFmpeg git repository C headers to the Pascal headers. + * You can accelerate this process by posting a patch with the git changes + * translated to Pascal to our bug tracker (please join our IRC chat before + * you start working on it). Simply adjusting the max. versions is NOT a valid + * fix. + *) (* Max. supported version by this header *) - LIBSWSCALE_MAX_VERSION_MAJOR = 0; - LIBSWSCALE_MAX_VERSION_MINOR = 7; - LIBSWSCALE_MAX_VERSION_RELEASE = 1; + LIBSWSCALE_MAX_VERSION_MAJOR = 0; + LIBSWSCALE_MAX_VERSION_MINOR = 10; + LIBSWSCALE_MAX_VERSION_RELEASE = 0; LIBSWSCALE_MAX_VERSION = (LIBSWSCALE_MAX_VERSION_MAJOR * VERSION_MAJOR) + (LIBSWSCALE_MAX_VERSION_MINOR * VERSION_MINOR) + (LIBSWSCALE_MAX_VERSION_RELEASE * VERSION_RELEASE); @@ -78,6 +103,20 @@ function swscale_version(): cuint; cdecl; external sw__scale; {$IFEND} +{$IF LIBSWSCALE_VERSION >= 000007002} // 0.7.2 +(** + * Returns the libswscale build-time configuration. + *) +function swscale_configuration(): PAnsiChar; + cdecl; external sw__scale; + +(** + * Returns the libswscale license. + *) +function swscale_license(): PAnsiChar; + cdecl; external sw__scale; +{$IFEND} + const (* values for the flags, the stuff on the command line is different *) SWS_FAST_BILINEAR = 1; @@ -124,6 +163,18 @@ const SWS_CS_SMPTE240M = 7; SWS_CS_DEFAULT = 5; +{$IF LIBSWSCALE_VERSION >= 000010000} // 0.10.0 +(** + * Returns a pointer to yuv<->rgb coefficients for the given colorspace + * suitable for sws_setColorspaceDetails(). + * + * @param colorspace One of the SWS_CS_* macros. If invalid, + * SWS_CS_DEFAULT is used. + *) + function sws_getCoefficients(colorspace: cint): Pcint; + cdecl; external sw__scale; +{$IFEND} + type // when used for filters they must have an odd number of elements @@ -148,6 +199,26 @@ type {internal structure} end; +{$IF LIBSWSCALE_VERSION >= 000008000} // 0.8.0 +(** + * Returns a positive value if pix_fmt is a supported input format, 0 + * otherwise. + *) + function sws_isSupportedInput(pix_fmt: TAVPixelFormat): cint; + cdecl; external sw__scale; + +(** + * Returns a positive value if pix_fmt is a supported output format, 0 + * otherwise. + *) + function sws_isSupportedOutput(pix_fmt: TAVPixelFormat): cint; + cdecl; external sw__scale; +{$IFEND} + +(** + * Frees the swscaler context swsContext. + * If swsContext is NULL, then does nothing. + *) procedure sws_freeContext(swsContext: PSwsContext); cdecl; external sw__scale; @@ -175,6 +246,10 @@ function sws_getContext(srcW: cint; srcH: cint; srcFormat: TAVPixelFormat; * slice in the image in dst. A slice is a sequence of consecutive * rows in an image. * + * Slices have to be provided in sequential order, either in + * top-bottom or bottom-top order. If slices are provided in + * non-sequential order the behavior of the function is undefined. + * * @param context the scaling context previously created with * sws_getContext() * @param srcSlice the array containing the pointers to the planes of @@ -192,14 +267,15 @@ function sws_getContext(srcW: cint; srcH: cint; srcFormat: TAVPixelFormat; * the destination image * @return the height of the output slice *) -function sws_scale(context: PSwsContext; srcSlice: PPCuint8Array; srcStride: PCintArray; - srcSliceY: cint; srcSliceH: cint; dst: PPCuint8Array; dstStride: PCintArray): cint; +function sws_scale(context: PSwsContext; {const} srcSlice: PPCuint8Array; {const} srcStride: PCintArray; + srcSliceY: cint; srcSliceH: cint; {const} dst: PPCuint8Array; {const} dstStride: PCintArray): cint; cdecl; external sw__scale; {$IF LIBSWSCALE_VERSION_MAJOR < 1} // deprecated. Use sws_scale() instead. -function sws_scale_ordered(context: PSwsContext; src: PPCuint8Array; srcStride: PCintArray; - srcSliceY: cint; srcSliceH: cint; dst: PPCuint8Array; dstStride: PCintArray): cint; +function sws_scale_ordered(context: PSwsContext; {const} src: PPCuint8Array; + srcStride: PCintArray; srcSliceY: cint; srcSliceH: cint; + dst: PPCuint8Array; dstStride: PCintArray): cint; cdecl; external sw__scale; deprecated; {$IFEND} diff --git a/cmake/src/lib/fft/UFFT.pas b/cmake/src/lib/fft/UFFT.pas index 6b094c98..5a056a8c 100644 --- a/cmake/src/lib/fft/UFFT.pas +++ b/cmake/src/lib/fft/UFFT.pas @@ -47,7 +47,7 @@ unit UFFT; {$IFDEF FPC} {$MODE Delphi} - {$H+} // Use AnsiString + {$H+} // Use long strings {$ENDIF} interface diff --git a/cmake/src/lib/freetype/demo/engine-test.bdsproj b/cmake/src/lib/freetype/demo/engine-test.bdsproj index 9547f18f..e5b3e97d 100644 --- a/cmake/src/lib/freetype/demo/engine-test.bdsproj +++ b/cmake/src/lib/freetype/demo/engine-test.bdsproj @@ -27,13 +27,13 @@ <Compiler Name="I">1</Compiler>
<Compiler Name="J">0</Compiler>
<Compiler Name="K">0</Compiler>
- <Compiler Name="L">1</Compiler>
- <Compiler Name="M">0</Compiler>
- <Compiler Name="N">1</Compiler>
- <Compiler Name="O">0</Compiler>
- <Compiler Name="P">1</Compiler>
- <Compiler Name="Q">0</Compiler>
- <Compiler Name="R">0</Compiler>
+ <Compiler Name="L">1</Compiler> + <Compiler Name="M">0</Compiler> + <Compiler Name="N">1</Compiler> + <Compiler Name="O">1</Compiler> + <Compiler Name="P">1</Compiler> + <Compiler Name="Q">0</Compiler> + <Compiler Name="R">0</Compiler> <Compiler Name="S">0</Compiler>
<Compiler Name="T">0</Compiler>
<Compiler Name="U">0</Compiler>
diff --git a/cmake/src/lib/freetype/demo/engine-test.dpr b/cmake/src/lib/freetype/demo/engine-test.dpr index 80177735..bbd7d890 100644 --- a/cmake/src/lib/freetype/demo/engine-test.dpr +++ b/cmake/src/lib/freetype/demo/engine-test.dpr @@ -27,7 +27,9 @@ uses ctypes in '../../ctypes/ctypes.pas', {$ENDIF} FreeType in '../freetype.pas', - UFont in '../../../base/UFont.pas', + UFont in 'UFont.pas', + //UFont in '../../../base/UFont.pas', + UUnicodeUtils in '../../../base/UUnicodeUtils.pas', math, sysutils; @@ -41,7 +43,7 @@ const //FONT_FILE = 'C:/Windows/Fonts/Arial.ttf'; //FONT_FILE = 'C:/Windows/Fonts/SimSun.ttf'; //FONT_FILE = 'eurostarregularextended.ttf'; - FONT_FILE = 'FreeSans.ttf'; + FONT_FILE = '../../../../game/fonts/FreeSans/FreeSans.ttf'; var OurFont: TScalableFont; @@ -129,11 +131,11 @@ begin // Really Nice Perspective Calculations glHint( GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST ); - //OurFont := TFTScalableFont.Create(FONT_FILE, 64); + OurFont := TFTScalableFont.Create(FONT_FILE, 64, 0.03); //OurFont := TFTFont.Create(FONT_FILE, 128); - OurFont := TFTScalableOutlineFont.Create(FONT_FILE, 64, 0.05); + //OurFont := TFTScalableOutlineFont.Create(FONT_FILE, 64, 0.03); //OurFont.UseKerning := false; - TFTScalableOutlineFont(OurFont).SetOutlineColor(1, 0, 0); + //TFTScalableOutlineFont(OurFont).SetOutlineColor(1, 0, 0, 1); //OurFont := TOutlineFont.Create(FONT_FILE, 32, 2); //OurFont.LineSpacing := OurFont.LineSpacing * 0.5; @@ -183,7 +185,7 @@ begin //OurFont.SetOutlineColor(0.5, 0.5, 0.5); //OurFont.ReflectionSpacing := -4; //OurFont.UseKerning := false; - OurFont.Height := 64;//cnt2; + OurFont.Height := 150;//cnt2; //OurFont.Reset; //OurFont.Aspect := 2; @@ -191,7 +193,7 @@ begin bounds := OurFont.BBox(msg); //glRectf(bounds.Left, OurFont.Ascender, bounds.Right, OurFont.Ascender-OurFont.Height); - glColor3f(1, 1, 1); + glColor4f(1, 1, 1, 1); //OurFont.ReflectionSpacing := 0; OurFont.Print(msg); diff --git a/cmake/src/lib/freetype/demo/engine-test.lpi b/cmake/src/lib/freetype/demo/engine-test.lpi index 6cbfe1eb..45483a56 100644 --- a/cmake/src/lib/freetype/demo/engine-test.lpi +++ b/cmake/src/lib/freetype/demo/engine-test.lpi @@ -28,14 +28,14 @@ </local>
</RunParams>
<Units Count="16">
- <Unit0>
- <Filename Value="engine-test.dpr"/>
- <IsPartOfProject Value="True"/>
- <CursorPos X="25" Y="135"/>
- <TopLine Value="118"/>
- <EditorIndex Value="0"/>
- <UsageCount Value="72"/>
- <Loaded Value="True"/>
+ <Unit0> + <Filename Value="engine-test.dpr"/> + <IsPartOfProject Value="True"/> + <CursorPos X="18" Y="25"/> + <TopLine Value="1"/> + <EditorIndex Value="0"/> + <UsageCount Value="72"/> + <Loaded Value="True"/> </Unit0>
<Unit1>
<Filename Value="JEDI-SDL\OpenGL\Pas\opengl12.pas"/>
@@ -139,13 +139,22 @@ <UnitName Value="UFont"/>
<CursorPos X="15" Y="1752"/>
<TopLine Value="1734"/>
- <UsageCount Value="10"/>
- </Unit15>
- </Units>
- <JumpHistory Count="0" HistoryIndex="-1"/>
- </ProjectOptions>
- <CompilerOptions>
- <Version Value="8"/>
+ <UsageCount Value="10"/> + </Unit15> + </Units> + <JumpHistory Count="2" HistoryIndex="1"> + <Position1> + <Filename Value="engine-test.dpr"/> + <Caret Line="52" Column="10" TopLine="37"/> + </Position1> + <Position2> + <Filename Value="engine-test.dpr"/> + <Caret Line="1" Column="1" TopLine="1"/> + </Position2> + </JumpHistory> + </ProjectOptions> + <CompilerOptions> + <Version Value="8"/> <PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="..\..\JEDI-SDL\SDL\Pas\"/>
diff --git a/cmake/src/lib/freetype/freetype.pas b/cmake/src/lib/freetype/freetype.pas index 6a9d2062..01f507bc 100644 --- a/cmake/src/lib/freetype/freetype.pas +++ b/cmake/src/lib/freetype/freetype.pas @@ -1,23 +1,42 @@ -//---------------------------------------------------------------------------- -// FreeType2 pascal header -//---------------------------------------------------------------------------- -// Anti-Grain Geometry - Version 2.4 (Public License) -// Copyright (C) 2002-2005 Maxim Shemanarev (http://www.antigrain.com) -// -// Anti-Grain Geometry - Version 2.4 Release Milano 3 (AggPas 2.4 RM3) -// Pascal Port By: Milan Marusinec alias Milano -// milan@marusinec.sk -// http://www.aggpas.org -// Copyright (c) 2005-2007 -// -// Permission to copy, use, modify, sell and distribute this software -// is granted provided this copyright notice appears in all copies. -// This software is provided "as is" without express or implied -// warranty, and with no claim as to its suitability for any purpose. -// -//---------------------------------------------------------------------------- -// Adapted by the UltraStar Deluxe Team -//---------------------------------------------------------------------------- +(***************************************************************************) +(* *) +(* freetype.h *) +(* *) +(* FreeType high-level API and common types (specification only). *) +(* *) +(* Copyright 1996-2001, 2002, 2003, 2004, 2005, 2006, 2007 by *) +(* David Turner, Robert Wilhelm, and Werner Lemberg. *) +(* *) +(* This file is part of the FreeType project, and may only be used, *) +(* modified, and distributed under the terms of the FreeType project *) +(* license, LICENSE.TXT. By continuing to use, modify, or distribute *) +(* this file you indicate that you have read the license and *) +(* understand and accept it fully. *) +(* *) +(***************************************************************************) + +(***************************************************************************) +(* Initial Pascal port by *) +(***************************************************************************) +(* Anti-Grain Geometry - Version 2.4 (Public License) *) +(* Copyright (C) 2002-2005 Maxim Shemanarev (http://www.antigrain.com) *) +(* *) +(* Anti-Grain Geometry - Version 2.4 Release Milano 3 (AggPas 2.4 RM3) *) +(* Pascal Port By: Milan Marusinec alias Milano *) +(* milan@marusinec.sk *) +(* http://www.aggpas.org *) +(* Copyright (c) 2005-2007 *) +(* *) +(* Permission to copy, use, modify, sell and distribute this software *) +(* is granted provided this copyright notice appears in all copies. *) +(* This software is provided "as is" without express or implied *) +(* warranty, and with no claim as to its suitability for any purpose. *) +(* *) +(***************************************************************************) + +(***************************************************************************) +(* Extended by the UltraStar Deluxe Team *) +(***************************************************************************) unit freetype; @@ -36,7 +55,7 @@ uses const {$IF Defined(MSWINDOWS)} - ft_lib = 'libfreetype-6.dll'; + ft_lib = 'freetype6.dll'; {$ELSEIF Defined(DARWIN)} ft_lib = 'libfreetype.dylib'; {$LINKLIB libfreetype} @@ -45,32 +64,24 @@ const {$IFEND} type - FT_Byte = cuchar; - FT_Short = csshort; - FT_UShort = cushort; - FT_Int = csint; - FT_UInt = cuint; - FT_Int16 = cint16; - FT_UInt16 = cuint16; - FT_Int32 = cint32; - FT_UInt32 = cuint32; - FT_Long = cslong; - FT_ULong = culong; - - FT_Fixed = cslong; - FT_Pos = cslong; - FT_Error = cint; - FT_F26Dot6 = cslong; - FT_String = cchar; - FT_Bool = cuchar; - - PFT_Byte = ^FT_Byte; - PFT_Short = ^FT_Short; - PFT_String = ^FT_String; - - - TByteArray = array [0 .. (MaxInt div SizeOf(byte))-1] of byte; - PByteArray = ^TByteArray; + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Library *) + (* *) + (* <Description> *) + (* A handle to a FreeType library instance. Each `library' is *) + (* completely independent from the others; it is the `root' of a set *) + (* of objects like fonts, faces, sizes, etc. *) + (* *) + (* It also embeds a memory manager (see @FT_Memory), as well as a *) + (* scan-line converter object (see @FT_Raster). *) + (* *) + (* <Note> *) + (* Library objects are normally created by @FT_Init_FreeType, and *) + (* destroyed with @FT_Done_FreeType. *) + (* *) + FT_Library = Pointer; (*************************************************************************) @@ -141,6 +152,34 @@ const (*************************************************************************) (* *) + (* <Macro> *) + (* FT_ENC_TAG *) + (* *) + (* <Description> *) + (* This macro converts four-letter tags into an unsigned long. It is *) + (* used to define `encoding' identifiers (see @FT_Encoding). *) + (* *) + (* <Note> *) + (* Since many 16-bit compilers don't like 32-bit enumerations, you *) + (* should redefine this macro in case of problems to something like *) + (* this: *) + (* *) + (* { *) + (* #define FT_ENC_TAG( value, a, b, c, d ) value *) + (* } *) + (* *) + (* to get a simple enumeration without assigning special numbers. *) + (* *) + { + #define FT_ENC_TAG( value, a, b, c, d ) \ + value = ( ( (FT_UInt32)(a) << 24 ) | \ + ( (FT_UInt32)(b) << 16 ) | \ + ( (FT_UInt32)(c) << 8 ) | \ + (FT_UInt32)(d) ) + } + + (*************************************************************************) + (* *) (* <Enum> *) (* FT_Encoding *) (* *) @@ -278,65 +317,47 @@ const (* *) type PFT_Encoding = ^FT_Encoding; - FT_Encoding = array[0..3] of char; -const - FT_ENCODING_NONE: FT_Encoding = (#0 ,#0 ,#0 ,#0 ); - FT_ENCODING_MS_SYMBOL: FT_Encoding = ('s', 'y', 'm', 'b' ); - FT_ENCODING_UNICODE: FT_Encoding = ('u', 'n', 'i', 'c' ); - - FT_ENCODING_SJIS: FT_Encoding = ('s', 'j', 'i', 's'); - FT_ENCODING_GB2312: FT_Encoding = ('g', 'b', ' ', ' '); - FT_ENCODING_BIG5: FT_Encoding = ('b', 'i', 'g', '5'); - FT_ENCODING_WANSUNG: FT_Encoding = ('w', 'a', 'n', 's'); - FT_ENCODING_JOHAB: FT_Encoding = ('j', 'o', 'h', 'a'); - - (*************************************************************************) - (* *) - (* <Enum> *) - (* FT_Glyph_Format *) - (* *) - (* <Description> *) - (* An enumeration type used to describe the format of a given glyph *) - (* image. Note that this version of FreeType only supports two image *) - (* formats, even though future font drivers will be able to register *) - (* their own format. *) - (* *) - (* <Values> *) - (* FT_GLYPH_FORMAT_NONE :: *) - (* The value 0 is reserved and does describe a glyph format. *) - (* *) - (* FT_GLYPH_FORMAT_COMPOSITE :: *) - (* The glyph image is a composite of several other images. This *) - (* format is _only_ used with @FT_LOAD_NO_RECURSE, and is used to *) - (* report compound glyphs (like accented characters). *) - (* *) - (* FT_GLYPH_FORMAT_BITMAP :: *) - (* The glyph image is a bitmap, and can be described as an *) - (* @FT_Bitmap. You generally need to access the `bitmap' field of *) - (* the @FT_GlyphSlotRec structure to read it. *) - (* *) - (* FT_GLYPH_FORMAT_OUTLINE :: *) - (* The glyph image is a vertorial outline made of line segments *) - (* and Bezier arcs; it can be described as an @FT_Outline; you *) - (* generally want to access the `outline' field of the *) - (* @FT_GlyphSlotRec structure to read it. *) - (* *) - (* FT_GLYPH_FORMAT_PLOTTER :: *) - (* The glyph image is a vectorial path with no inside/outside *) - (* contours. Some Type 1 fonts, like those in the Hershey family, *) - (* contain glyphs in this format. These are described as *) - (* @FT_Outline, but FreeType isn't currently capable of rendering *) - (* them correctly. *) - (* *) -type - FT_Glyph_Format = array[0..3] of char; + FT_Encoding = cint32; // 32 bit enum of FT_ENC_TAG const - FT_GLYPH_FORMAT_NONE: FT_Glyph_Format = (#0, #0, #0, #0 ); - - FT_GLYPH_FORMAT_COMPOSITE: FT_Glyph_Format = ('c', 'o', 'm', 'p' ); - FT_GLYPH_FORMAT_BITMAP: FT_Glyph_Format = ('b', 'i', 't', 's' ); - FT_GLYPH_FORMAT_OUTLINE: FT_Glyph_Format = ('o', 'u', 't', 'l' ); - FT_GLYPH_FORMAT_PLOTTER: FT_Glyph_Format = ('p', 'l', 'o', 't' ); + FT_ENCODING_NONE = (Ord(#0) shl 24) or + (Ord(#0) shl 16) or + (Ord(#0) shl 8) or + (Ord(#0) shl 0); + + FT_ENCODING_MS_SYMBOL = (Ord('s') shl 24) or + (Ord('y') shl 16) or + (Ord('m') shl 8) or + (Ord('b') shl 0); + + FT_ENCODING_UNICODE = (Ord('u') shl 24) or + (Ord('n') shl 16) or + (Ord('i') shl 8) or + (Ord('c') shl 0); + + FT_ENCODING_SJIS = (Ord('s') shl 24) or + (Ord('j') shl 16) or + (Ord('i') shl 8) or + (Ord('s') shl 0); + + FT_ENCODING_GB2312 = (Ord('g') shl 24) or + (Ord('b') shl 16) or + (Ord(' ') shl 8) or + (Ord(' ') shl 0); + + FT_ENCODING_BIG5 = (Ord('b') shl 24) or + (Ord('i') shl 16) or + (Ord('g') shl 8) or + (Ord('5') shl 0); + + FT_ENCODING_WANSUNG = (Ord('w') shl 24) or + (Ord('a') shl 16) or + (Ord('n') shl 8) or + (Ord('s') shl 0); + + FT_ENCODING_JOHAB = (Ord('j') shl 24) or + (Ord('o') shl 16) or + (Ord('h') shl 8) or + (Ord('a') shl 0); (*************************************************************************) @@ -358,7 +379,7 @@ const const FT_STYLE_FLAG_ITALIC = 1 shl 0; FT_STYLE_FLAG_BOLD = 1 shl 1; - + (*************************************************************************** * @@ -567,7 +588,7 @@ const (* perform this pass. *) (* *) type - FT_Render_Mode = FT_Int; + FT_Render_Mode = cint; const FT_RENDER_MODE_NORMAL = 0; FT_RENDER_MODE_LIGHT = FT_RENDER_MODE_NORMAL + 1; @@ -579,63 +600,34 @@ const (*************************************************************************) (* *) - (* <Enum> *) - (* FT_Pixel_Mode *) + (* <Type> *) + (* FT_GlyphSlot *) (* *) (* <Description> *) - (* An enumeration type used to describe the format of pixels in a *) - (* given bitmap. Note that additional formats may be added in the *) - (* future. *) + (* A handle to a given `glyph slot'. A slot is a container where it *) + (* is possible to load any one of the glyphs contained in its parent *) + (* face. *) (* *) - (* <Values> *) - (* FT_PIXEL_MODE_NONE :: *) - (* Value 0 is reserved. *) - (* *) - (* FT_PIXEL_MODE_MONO :: *) - (* A monochrome bitmap, using 1 bit per pixel. Note that pixels *) - (* are stored in most-significant order (MSB), which means that *) - (* the left-most pixel in a byte has value 128. *) - (* *) - (* FT_PIXEL_MODE_GRAY :: *) - (* An 8-bit bitmap, generally used to represent anti-aliased glyph *) - (* images. Each pixel is stored in one byte. Note that the number *) - (* of value `gray' levels is stored in the `num_bytes' field of *) - (* the @FT_Bitmap structure (it generally is 256). *) - (* *) - (* FT_PIXEL_MODE_GRAY2 :: *) - (* A 2-bit/pixel bitmap, used to represent embedded anti-aliased *) - (* bitmaps in font files according to the OpenType specification. *) - (* We haven't found a single font using this format, however. *) - (* *) - (* FT_PIXEL_MODE_GRAY4 :: *) - (* A 4-bit/pixel bitmap, used to represent embedded anti-aliased *) - (* bitmaps in font files according to the OpenType specification. *) - (* We haven't found a single font using this format, however. *) - (* *) - (* FT_PIXEL_MODE_LCD :: *) - (* An 8-bit bitmap, used to represent RGB or BGR decimated glyph *) - (* images used for display on LCD displays; the bitmap is three *) - (* times wider than the original glyph image. See also *) - (* @FT_RENDER_MODE_LCD. *) - (* *) - (* FT_PIXEL_MODE_LCD_V :: *) - (* An 8-bit bitmap, used to represent RGB or BGR decimated glyph *) - (* images used for display on rotated LCD displays; the bitmap *) - (* is three times taller than the original glyph image. See also *) - (* @FT_RENDER_MODE_LCD_V. *) + (* In other words, each time you call @FT_Load_Glyph or *) + (* @FT_Load_Char, the slot's content is erased by the new glyph data, *) + (* i.e. the glyph's metrics, its image (bitmap or outline), and *) + (* other control information. *) + (* *) + (* <Also> *) + (* @FT_GlyphSlotRec details the publicly accessible glyph fields. *) (* *) type - FT_Pixel_Mode = byte; -const - FT_PIXEL_MODE_NONE = 0; - FT_PIXEL_MODE_MONO = FT_PIXEL_MODE_NONE + 1; - FT_PIXEL_MODE_GRAY = FT_PIXEL_MODE_MONO + 1; - FT_PIXEL_MODE_GRAY2 = FT_PIXEL_MODE_GRAY + 1; - FT_PIXEL_MODE_GRAY4 = FT_PIXEL_MODE_GRAY2 + 1; - FT_PIXEL_MODE_LCD = FT_PIXEL_MODE_GRAY4 + 1; - FT_PIXEL_MODE_LCD_V = FT_PIXEL_MODE_LCD + 1; + FT_GlyphSlot = ^FT_GlyphSlotRec; - FT_PIXEL_MODE_MAX = FT_PIXEL_MODE_LCD_V + 1; (* do not remove *) + +{$DEFINE TYPE_DECL} +{$I ftconfig.inc} +{$I fttypes.inc} +{$I ftimage.inc} +{$I ftglyph.inc} +{$I ftstroke.inc} +{$I ftoutln.inc} +{$UNDEF TYPE_DECL} (*************************************************************************) @@ -674,7 +666,6 @@ const (* vertAdvance :: *) (* Advance height for vertical layout. *) (* *) -type FT_Glyph_Metrics = record width , height : FT_Pos; @@ -759,140 +750,6 @@ type (*************************************************************************) (* *) - (* <Struct> *) - (* FT_Vector *) - (* *) - (* <Description> *) - (* A simple structure used to store a 2D vector; coordinates are of *) - (* the FT_Pos type. *) - (* *) - (* <Fields> *) - (* x :: The horizontal coordinate. *) - (* y :: The vertical coordinate. *) - (* *) - PFT_Vector = ^FT_Vector; - FT_Vector = record - x , - y : FT_Pos; - end; - - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_Outline *) - (* *) - (* <Description> *) - (* This structure is used to describe an outline to the scan-line *) - (* converter. *) - (* *) - (* <Fields> *) - (* n_contours :: The number of contours in the outline. *) - (* *) - (* n_points :: The number of points in the outline. *) - (* *) - (* points :: A pointer to an array of `n_points' FT_Vector *) - (* elements, giving the outline's point coordinates. *) - (* *) - (* tags :: A pointer to an array of `n_points' chars, giving *) - (* each outline point's type. If bit 0 is unset, the *) - (* point is `off' the curve, i.e. a Bezier control *) - (* point, while it is `on' when set. *) - (* *) - (* Bit 1 is meaningful for `off' points only. If set, *) - (* it indicates a third-order Bezier arc control point; *) - (* and a second-order control point if unset. *) - (* *) - (* contours :: An array of `n_contours' shorts, giving the end *) - (* point of each contour within the outline. For *) - (* example, the first contour is defined by the points *) - (* `0' to `contours[0]', the second one is defined by *) - (* the points `contours[0]+1' to `contours[1]', etc. *) - (* *) - (* flags :: A set of bit flags used to characterize the outline *) - (* and give hints to the scan-converter and hinter on *) - (* how to convert/grid-fit it. See FT_Outline_Flags. *) - (* *) - PFT_Outline = ^FT_Outline; - FT_Outline = record - n_contours : FT_Short; - n_points : FT_Short; - - points : PFT_Vector; - tags : PChar; - contours : PFT_Short; - - flags : FT_Int; - end; - - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_Bitmap *) - (* *) - (* <Description> *) - (* A structure used to describe a bitmap or pixmap to the raster. *) - (* Note that we now manage pixmaps of various depths through the *) - (* `pixel_mode' field. *) - (* *) - (* <Fields> *) - (* rows :: The number of bitmap rows. *) - (* *) - (* width :: The number of pixels in bitmap row. *) - (* *) - (* pitch :: The pitch's absolute value is the number of bytes *) - (* taken by one bitmap row, including padding. *) - (* However, the pitch is positive when the bitmap has *) - (* a `down' flow, and negative when it has an `up' *) - (* flow. In all cases, the pitch is an offset to add *) - (* to a bitmap pointer in order to go down one row. *) - (* *) - (* buffer :: A typeless pointer to the bitmap buffer. This *) - (* value should be aligned on 32-bit boundaries in *) - (* most cases. *) - (* *) - (* num_grays :: This field is only used with *) - (* `FT_PIXEL_MODE_GRAY'; it gives the number of gray *) - (* levels used in the bitmap. *) - (* *) - (* pixel_mode :: The pixel mode, i.e., how pixel bits are stored. *) - (* See @FT_Pixel_Mode for possible values. *) - (* *) - (* palette_mode :: This field is only used with paletted pixel modes; *) - (* it indicates how the palette is stored. *) - (* *) - (* palette :: A typeless pointer to the bitmap palette; only *) - (* used for paletted pixel modes. *) - (* *) - (* <Note> *) - (* For now, the only pixel mode supported by FreeType are mono and *) - (* grays. However, drivers might be added in the future to support *) - (* more `colorful' options. *) - (* *) - (* When using pixel modes pal2, pal4 and pal8 with a void `palette' *) - (* field, a gray pixmap with respectively 4, 16, and 256 levels of *) - (* gray is assumed. This, in order to be compatible with some *) - (* embedded bitmap formats defined in the TrueType specification. *) - (* *) - (* Note that no font was found presenting such embedded bitmaps, so *) - (* this is currently completely unhandled by the library. *) - (* *) - PFT_Bitmap = ^FT_Bitmap; - FT_Bitmap = record - rows , - width : FT_Int; - pitch : FT_Int; - buffer : PByteArray; - num_grays : FT_Short; - pixel_mode , - palette_mode : byte; - palette : pointer; - end; - - - (*************************************************************************) - (* *) (* <Type> *) (* FT_Face *) (* *) @@ -950,183 +807,10 @@ type PAFT_CharMap = ^FT_CharMap; AFT_CharMap = array[0..High(Word)] of FT_CharMap; - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_Library *) - (* *) - (* <Description> *) - (* A handle to a FreeType library instance. Each `library' is *) - (* completely independent from the others; it is the `root' of a set *) - (* of objects like fonts, faces, sizes, etc. *) - (* *) - (* It also embeds a memory manager (see @FT_Memory), as well as a *) - (* scan-line converter object (see @FT_Raster). *) - (* *) - (* <Note> *) - (* Library objects are normally created by @FT_Init_FreeType, and *) - (* destroyed with @FT_Done_FreeType. *) - (* *) - FT_Library = ^FT_LibraryRec; - FT_LibraryRec = record // internal - end; - - (*************************************************************************) - (* *) - (* <Section> *) - (* glyph_management *) - (* *) - (* <Title> *) - (* Glyph Management *) - (* *) - (* <Abstract> *) - (* Generic interface to manage individual glyph data. *) - (* *) - (* <Description> *) - (* This section contains definitions used to manage glyph data *) - (* through generic FT_Glyph objects. Each of them can contain a *) - (* bitmap, a vector outline, or even images in other formats. *) - (* *) - (*************************************************************************) - - (* forward declaration to a private type *) - PFT_Glyph_Class = ^FT_Glyph_Class; - FT_Glyph_Class = record // internal - end; - - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_Glyph *) - (* *) - (* <Description> *) - (* Handle to an object used to model generic glyph images. It is a *) - (* pointer to the @FT_GlyphRec structure and can contain a glyph *) - (* bitmap or pointer. *) - (* *) - (* <Note> *) - (* Glyph objects are not owned by the library. You must thus release *) - (* them manually (through @FT_Done_Glyph) _before_ calling *) - (* @FT_Done_FreeType. *) - (* *) - FT_Glyph = ^FT_GlyphRec; - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_GlyphRec *) - (* *) - (* <Description> *) - (* The root glyph structure contains a given glyph image plus its *) - (* advance width in 16.16 fixed float format. *) - (* *) - (* <Fields> *) - (* library :: A handle to the FreeType library object. *) - (* *) - (* clazz :: A pointer to the glyph's class. Private. *) - (* *) - (* format :: The format of the glyph's image. *) - (* *) - (* advance :: A 16.16 vector that gives the glyph's advance width. *) - (* *) - FT_GlyphRec = record - library_: FT_Library; - clazz: PFT_Glyph_Class; - format: FT_Glyph_Format; - advance: FT_Vector; - end; - - - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_BitmapGlyph *) - (* *) - (* <Description> *) - (* A handle to an object used to model a bitmap glyph image. This is *) - (* a sub-class of @FT_Glyph, and a pointer to @FT_BitmapGlyphRec. *) - (* *) - FT_BitmapGlyph = ^FT_BitmapGlyphRec; - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_BitmapGlyphRec *) - (* *) - (* <Description> *) - (* A structure used for bitmap glyph images. This really is a *) - (* `sub-class' of `FT_GlyphRec'. *) - (* *) - (* <Fields> *) - (* root :: The root FT_Glyph fields. *) - (* *) - (* left :: The left-side bearing, i.e., the horizontal distance *) - (* from the current pen position to the left border of the *) - (* glyph bitmap. *) - (* *) - (* top :: The top-side bearing, i.e., the vertical distance from *) - (* the current pen position to the top border of the glyph *) - (* bitmap. This distance is positive for upwards-y! *) - (* *) - (* bitmap :: A descriptor for the bitmap. *) - (* *) - (* <Note> *) - (* You can typecast FT_Glyph to FT_BitmapGlyph if you have *) - (* glyph->format == FT_GLYPH_FORMAT_BITMAP. This lets you access *) - (* the bitmap's contents easily. *) - (* *) - (* The corresponding pixel buffer is always owned by the BitmapGlyph *) - (* and is thus created and destroyed with it. *) - (* *) - FT_BitmapGlyphRec = record - root: FT_GlyphRec; - left: FT_Int; - top: FT_Int; - bitmap: FT_Bitmap; - end; - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_OutlineGlyph *) - (* *) - (* <Description> *) - (* A handle to an object used to model an outline glyph image. This *) - (* is a sub-class of @FT_Glyph, and a pointer to @FT_OutlineGlyphRec. *) - (* *) - FT_OutlineGlyph = ^FT_OutlineGlyphRec; - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_OutlineGlyphRec *) - (* *) - (* <Description> *) - (* A structure used for outline (vectorial) glyph images. This *) - (* really is a `sub-class' of `FT_GlyphRec'. *) - (* *) - (* <Fields> *) - (* root :: The root FT_Glyph fields. *) - (* *) - (* outline :: A descriptor for the outline. *) - (* *) - (* <Note> *) - (* You can typecast FT_Glyph to FT_OutlineGlyph if you have *) - (* glyph->format == FT_GLYPH_FORMAT_OUTLINE. This lets you access *) - (* the outline's content easily. *) - (* *) - (* As the outline is extracted from a glyph slot, its coordinates are *) - (* expressed normally in 26.6 pixels, unless the flag *) - (* FT_LOAD_NO_SCALE was used in FT_Load_Glyph() or FT_Load_Char(). *) - (* *) - (* The outline's tables are always owned by the object and are *) - (* destroyed with it. *) - (* *) - FT_OutlineGlyphRec = record - root: FT_GlyphRec; - outline: FT_Outline; - end; (*************************************************************************) @@ -1149,101 +833,6 @@ type (*************************************************************************) (* *) - (* <FuncType> *) - (* FT_Generic_Finalizer *) - (* *) - (* <Description> *) - (* Describes a function used to destroy the `client' data of any *) - (* FreeType object. See the description of the FT_Generic type for *) - (* details of usage. *) - (* *) - (* <Input> *) - (* The address of the FreeType object which is under finalization. *) - (* Its client data is accessed through its `generic' field. *) - (* *) - FT_Generic_Finalizer = procedure(AnObject : pointer ); cdecl; - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_Generic *) - (* *) - (* <Description> *) - (* Client applications often need to associate their own data to a *) - (* variety of FreeType core objects. For example, a text layout API *) - (* might want to associate a glyph cache to a given size object. *) - (* *) - (* Most FreeType object contains a `generic' field, of type *) - (* FT_Generic, which usage is left to client applications and font *) - (* servers. *) - (* *) - (* It can be used to store a pointer to client-specific data, as well *) - (* as the address of a `finalizer' function, which will be called by *) - (* FreeType when the object is destroyed (for example, the previous *) - (* client example would put the address of the glyph cache destructor *) - (* in the `finalizer' field). *) - (* *) - (* <Fields> *) - (* data :: A typeless pointer to any client-specified data. This *) - (* field is completely ignored by the FreeType library. *) - (* *) - (* finalizer :: A pointer to a `generic finalizer' function, which *) - (* will be called when the object is destroyed. If this *) - (* field is set to NULL, no code will be called. *) - (* *) - FT_Generic = record - data : pointer; - finalizer : FT_Generic_Finalizer; - end; - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_BBox *) - (* *) - (* <Description> *) - (* A structure used to hold an outline's bounding box, i.e., the *) - (* coordinates of its extrema in the horizontal and vertical *) - (* directions. *) - (* *) - (* <Fields> *) - (* xMin :: The horizontal minimum (left-most). *) - (* *) - (* yMin :: The vertical minimum (bottom-most). *) - (* *) - (* xMax :: The horizontal maximum (right-most). *) - (* *) - (* yMax :: The vertical maximum (top-most). *) - (* *) - PFT_BBox = ^FT_BBox; - FT_BBox = record - xMin, yMin : FT_Pos; - xMax, yMax : FT_Pos; - end; - - - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_GlyphSlot *) - (* *) - (* <Description> *) - (* A handle to a given `glyph slot'. A slot is a container where it *) - (* is possible to load any one of the glyphs contained in its parent *) - (* face. *) - (* *) - (* In other words, each time you call @FT_Load_Glyph or *) - (* @FT_Load_Char, the slot's content is erased by the new glyph data, *) - (* i.e. the glyph's metrics, its image (bitmap or outline), and *) - (* other control information. *) - (* *) - (* <Also> *) - (* @FT_GlyphSlotRec details the publicly accessible glyph fields. *) - (* *) - FT_GlyphSlot = ^FT_GlyphSlotRec; - - (*************************************************************************) - (* *) (* <Struct> *) (* FT_GlyphSlotRec *) (* *) @@ -1432,7 +1021,7 @@ type subglyphs : FT_SubGlyph; control_data : pointer; - control_len : longint; + control_len : clong; lsb_delta: FT_Pos; rsb_delta: FT_Pos; @@ -1497,15 +1086,15 @@ type (* computations. *) (* *) FT_Size_Metrics = record - x_ppem , - y_ppem : FT_UShort; - x_scale , - y_scale : FT_Fixed; - - ascender , - descender : FT_Pos; - height : FT_Pos; - max_advance : FT_Pos; + x_ppem, (* horizontal pixels per EM *) + y_ppem: FT_UShort; (* vertical pixels per EM *) + x_scale, (* scaling values used to convert font *) + y_scale: FT_Fixed; (* units to 26.6 fractional pixels *) + + ascender, (* ascender in 26.6 frac. pixels *) + descender: FT_Pos; (* descender in 26.6 frac. pixels *) + height: FT_Pos; (* text height in 26.6 frac. pixels *) + max_advance: FT_Pos; (* max horizontal advance, in 26.6 pixels *) end; (*************************************************************************) @@ -1786,21 +1375,29 @@ type encoding_id : FT_UShort; end; + +{$I ftconfig.inc} +{$I fttypes.inc} +{$I ftimage.inc} +{$I ftglyph.inc} +{$I ftstroke.inc} +{$I ftoutln.inc} + + { GLOBAL PROCEDURES } (*************************************************************************) (* *) (* @macro: *) - (* FT_CURVE_TAG ( flag ) *) + (* FT_HAS_KERNING( face ) *) (* *) - function FT_CURVE_TAG(flag: byte): byte; - -const - FT_CURVE_TAG_ON = 1; - FT_CURVE_TAG_CONIC = 0; - FT_CURVE_TAG_CUBIC = 2; - + (* @description: *) + (* A macro that returns true whenever a face object contains kerning *) + (* data that can be accessed with @FT_Get_Kerning. *) + (* *) + function FT_HAS_KERNING(face : FT_Face ) : cbool; + (*************************************************************************) (* *) (* @macro: *) @@ -1813,16 +1410,6 @@ const (* *) function FT_IS_SCALABLE(face : FT_Face ) : cbool; - (*************************************************************************) - (* *) - (* @macro: *) - (* FT_HAS_KERNING( face ) *) - (* *) - (* @description: *) - (* A macro that returns true whenever a face object contains kerning *) - (* data that can be accessed with @FT_Get_Kerning. *) - (* *) - function FT_HAS_KERNING(face : FT_Face ) : cbool; (*************************************************************************) (* *) @@ -2284,216 +1871,12 @@ const pixel_height : FT_UInt ) : FT_Error; cdecl; external ft_lib name 'FT_Set_Pixel_Sizes'; - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Get_Glyph *) - (* *) - (* <Description> *) - (* A function used to extract a glyph image from a slot. *) - (* *) - (* <Input> *) - (* slot :: A handle to the source glyph slot. *) - (* *) - (* <Output> *) - (* aglyph :: A handle to the glyph object. *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - function FT_Get_Glyph( - slot: FT_GlyphSlot; - out aglyph: FT_Glyph ): FT_Error; - cdecl; external ft_lib name 'FT_Get_Glyph'; - - (*************************************************************************) - (* *) - (* <Enum> *) - (* FT_Glyph_BBox_Mode *) - (* *) - (* <Description> *) - (* The mode how the values of @FT_Glyph_Get_CBox are returned. *) - (* *) - (* <Values> *) - (* FT_GLYPH_BBOX_UNSCALED :: *) - (* Return unscaled font units. *) - (* *) - (* FT_GLYPH_BBOX_SUBPIXELS :: *) - (* Return unfitted 26.6 coordinates. *) - (* *) - (* FT_GLYPH_BBOX_GRIDFIT :: *) - (* Return grid-fitted 26.6 coordinates. *) - (* *) - (* FT_GLYPH_BBOX_TRUNCATE :: *) - (* Return coordinates in integer pixels. *) - (* *) - (* FT_GLYPH_BBOX_PIXELS :: *) - (* Return grid-fitted pixel coordinates. *) - (* *) -type - FT_Glyph_BBox_Mode = FT_UInt; const - FT_GLYPH_BBOX_UNSCALED = 0; - FT_GLYPH_BBOX_SUBPIXELS = 0; - FT_GLYPH_BBOX_GRIDFIT = 1; - FT_GLYPH_BBOX_TRUNCATE = 2; - FT_GLYPH_BBOX_PIXELS = 3; - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Glyph_Get_CBox *) - (* *) - (* <Description> *) - (* Return a glyph's `control box'. The control box encloses all the *) - (* outline's points, including Bézier control points. Though it *) - (* coincides with the exact bounding box for most glyphs, it can be *) - (* slightly larger in some situations (like when rotating an outline *) - (* which contains Bézier outside arcs). *) - (* *) - (* Computing the control box is very fast, while getting the bounding *) - (* box can take much more time as it needs to walk over all segments *) - (* and arcs in the outline. To get the latter, you can use the *) - (* `ftbbox' component which is dedicated to this single task. *) - (* *) - (* <Input> *) - (* glyph :: A handle to the source glyph object. *) - (* *) - (* mode :: The mode which indicates how to interpret the returned *) - (* bounding box values. *) - (* *) - (* <Output> *) - (* acbox :: The glyph coordinate bounding box. Coordinates are *) - (* expressed in 1/64th of pixels if it is grid-fitted. *) - (* *) - (* <Note> *) - (* Coordinates are relative to the glyph origin, using the Y-upwards *) - (* convention. *) - (* *) - (* If the glyph has been loaded with @FT_LOAD_NO_SCALE, `bbox_mode' *) - (* must be set to @FT_GLYPH_BBOX_UNSCALED to get unscaled font *) - (* units in 26.6 pixel format. The value @FT_GLYPH_BBOX_SUBPIXELS *) - (* is another name for this constant. *) - (* *) - (* Note that the maximum coordinates are exclusive, which means that *) - (* one can compute the width and height of the glyph image (be it in *) - (* integer or 26.6 pixels) as: *) - (* *) - (* { *) - (* width = bbox.xMax - bbox.xMin; *) - (* height = bbox.yMax - bbox.yMin; *) - (* } *) - (* *) - (* Note also that for 26.6 coordinates, if `bbox_mode' is set to *) - (* @FT_GLYPH_BBOX_GRIDFIT, the coordinates will also be grid-fitted, *) - (* which corresponds to: *) - (* *) - (* { *) - (* bbox.xMin = FLOOR(bbox.xMin); *) - (* bbox.yMin = FLOOR(bbox.yMin); *) - (* bbox.xMax = CEILING(bbox.xMax); *) - (* bbox.yMax = CEILING(bbox.yMax); *) - (* } *) - (* *) - (* To get the bbox in pixel coordinates, set `bbox_mode' to *) - (* @FT_GLYPH_BBOX_TRUNCATE. *) - (* *) - (* To get the bbox in grid-fitted pixel coordinates, set `bbox_mode' *) - (* to @FT_GLYPH_BBOX_PIXELS. *) - (* *) - procedure FT_Glyph_Get_CBox( glyph: FT_Glyph; - bbox_mode: FT_UInt; - out acbox: FT_BBox ); - cdecl; external ft_lib name 'FT_Glyph_Get_CBox'; - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Glyph_To_Bitmap *) - (* *) - (* <Description> *) - (* Converts a given glyph object to a bitmap glyph object. *) - (* *) - (* <InOut> *) - (* the_glyph :: A pointer to a handle to the target glyph. *) - (* *) - (* <Input> *) - (* render_mode :: An enumeration that describe how the data is *) - (* rendered. *) - (* *) - (* origin :: A pointer to a vector used to translate the glyph *) - (* image before rendering. Can be 0 (if no *) - (* translation). The origin is expressed in *) - (* 26.6 pixels. *) - (* *) - (* destroy :: A boolean that indicates that the original glyph *) - (* image should be destroyed by this function. It is *) - (* never destroyed in case of error. *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - (* <Note> *) - (* The glyph image is translated with the `origin' vector before *) - (* rendering. *) - (* *) - (* The first parameter is a pointer to a FT_Glyph handle, that will *) - (* be replaced by this function. Typically, you would use (omitting *) - (* error handling): *) - (* *) - (* *) - (* { *) - (* FT_Glyph glyph; *) - (* FT_BitmapGlyph glyph_bitmap; *) - (* *) - (* *) - (* // load glyph *) - (* error = FT_Load_Char( face, glyph_index, FT_LOAD_DEFAUT ); *) - (* *) - (* // extract glyph image *) - (* error = FT_Get_Glyph( face->glyph, &glyph ); *) - (* *) - (* // convert to a bitmap (default render mode + destroy old) *) - (* if ( glyph->format != FT_GLYPH_FORMAT_BITMAP ) *) - (* { *) - (* error = FT_Glyph_To_Bitmap( &glyph, FT_RENDER_MODE_DEFAULT, *) - (* 0, 1 ); *) - (* if ( error ) // glyph unchanged *) - (* ... *) - (* } *) - (* *) - (* // access bitmap content by typecasting *) - (* glyph_bitmap = (FT_BitmapGlyph)glyph; *) - (* *) - (* // do funny stuff with it, like blitting/drawing *) - (* ... *) - (* *) - (* // discard glyph image (bitmap or not) *) - (* FT_Done_Glyph( glyph ); *) - (* } *) - (* *) - (* *) - (* This function does nothing if the glyph format isn't scalable. *) - (* *) - function FT_Glyph_To_Bitmap(var the_glyph: FT_Glyph; - render_mode: FT_Render_Mode; - origin: PFT_Vector; - destroy: FT_Bool ): FT_Error; - cdecl; external ft_lib name 'FT_Glyph_To_Bitmap'; + FT_ANGLE_PI = 180 shl 16; + FT_ANGLE_2PI = FT_ANGLE_PI * 2; + FT_ANGLE_PI2 = FT_ANGLE_PI div 2; + FT_ANGLE_PI4 = FT_ANGLE_PI div 4; - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Done_Glyph *) - (* *) - (* <Description> *) - (* Destroys a given glyph. *) - (* *) - (* <Input> *) - (* glyph :: A handle to the target glyph object. *) - (* *) - procedure FT_Done_Glyph( glyph: FT_Glyph ); - cdecl; external ft_lib name 'FT_Done_Glyph'; implementation @@ -2504,17 +1887,17 @@ begin result := flag and 3; end; -{ FT_IS_SCALABLE } -function FT_IS_SCALABLE(face : FT_Face ) : cbool; -begin - result := cbool(face.face_flags and FT_FACE_FLAG_SCALABLE ); -end; - { FT_HAS_KERNING } function FT_HAS_KERNING(face : FT_Face ) : cbool; begin result := cbool(face.face_flags and FT_FACE_FLAG_KERNING ); end; +{ FT_IS_SCALABLE } +function FT_IS_SCALABLE(face : FT_Face ) : cbool; +begin + result := cbool(face.face_flags and FT_FACE_FLAG_SCALABLE ); +end; + end. diff --git a/cmake/src/lib/freetype/ftconfig.inc b/cmake/src/lib/freetype/ftconfig.inc new file mode 100644 index 00000000..100fb2e0 --- /dev/null +++ b/cmake/src/lib/freetype/ftconfig.inc @@ -0,0 +1,35 @@ +(***************************************************************************) +(* *) +(* ftconfig.h *) +(* *) +(* ANSI-specific configuration file (specification only). *) +(* *) +(* Copyright 1996-2001, 2002, 2003, 2004, 2006, 2007 by *) +(* David Turner, Robert Wilhelm, and Werner Lemberg. *) +(* *) +(* This file is part of the FreeType project, and may only be used, *) +(* modified, and distributed under the terms of the FreeType project *) +(* license, LICENSE.TXT. By continuing to use, modify, or distribute *) +(* this file you indicate that you have read the license and *) +(* understand and accept it fully. *) +(* *) +(***************************************************************************) +(***************************************************************************) +(* Pascal port by the UltraStar Deluxe Team *) +(***************************************************************************) + +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* IntN types *) + (* *) + (* Used to guarantee the size of some specific integers. *) + (* *) + FT_Int16 = cint16; + FT_UInt16 = cuint16; + FT_Int32 = cint32; + FT_UInt32 = cuint32; + +{$ENDIF TYPE_DECL} + diff --git a/cmake/src/lib/freetype/ftglyph.inc b/cmake/src/lib/freetype/ftglyph.inc new file mode 100644 index 00000000..0d4acc99 --- /dev/null +++ b/cmake/src/lib/freetype/ftglyph.inc @@ -0,0 +1,435 @@ +(***************************************************************************) +(* *) +(* ftglyph.h *) +(* *) +(* FreeType convenience functions to handle glyphs (specification). *) +(* *) +(* Copyright 1996-2001, 2002, 2003, 2006 by *) +(* David Turner, Robert Wilhelm, and Werner Lemberg. *) +(* *) +(* This file is part of the FreeType project, and may only be used, *) +(* modified, and distributed under the terms of the FreeType project *) +(* license, LICENSE.TXT. By continuing to use, modify, or distribute *) +(* this file you indicate that you have read the license and *) +(* understand and accept it fully. *) +(* *) +(***************************************************************************) +(***************************************************************************) +(* Pascal port by the UltraStar Deluxe Team *) +(***************************************************************************) + + + (*************************************************************************) + (* *) + (* This file contains the definition of several convenience functions *) + (* that can be used by client applications to easily retrieve glyph *) + (* bitmaps and outlines from a given face. *) + (* *) + (* These functions should be optional if you are writing a font server *) + (* or text layout engine on top of FreeType. However, they are pretty *) + (* handy for many other simple uses of the library. *) + (* *) + (*************************************************************************) + + (*************************************************************************) + (* *) + (* <Section> *) + (* glyph_management *) + (* *) + (* <Title> *) + (* Glyph Management *) + (* *) + (* <Abstract> *) + (* Generic interface to manage individual glyph data. *) + (* *) + (* <Description> *) + (* This section contains definitions used to manage glyph data *) + (* through generic FT_Glyph objects. Each of them can contain a *) + (* bitmap, a vector outline, or even images in other formats. *) + (* *) + (*************************************************************************) + +{$IFDEF TYPE_DECL} + + (* forward declaration to a private type *) + PFT_Glyph_Class = Pointer; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Glyph *) + (* *) + (* <Description> *) + (* Handle to an object used to model generic glyph images. It is a *) + (* pointer to the @FT_GlyphRec structure and can contain a glyph *) + (* bitmap or pointer. *) + (* *) + (* <Note> *) + (* Glyph objects are not owned by the library. You must thus release *) + (* them manually (through @FT_Done_Glyph) _before_ calling *) + (* @FT_Done_FreeType. *) + (* *) + FT_Glyph = ^FT_GlyphRec; + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_GlyphRec *) + (* *) + (* <Description> *) + (* The root glyph structure contains a given glyph image plus its *) + (* advance width in 16.16 fixed float format. *) + (* *) + (* <Fields> *) + (* library :: A handle to the FreeType library object. *) + (* *) + (* clazz :: A pointer to the glyph's class. Private. *) + (* *) + (* format :: The format of the glyph's image. *) + (* *) + (* advance :: A 16.16 vector that gives the glyph's advance width. *) + (* *) + FT_GlyphRec = record + library_: FT_Library; + clazz: PFT_Glyph_Class; + format: FT_Glyph_Format; + advance: FT_Vector; + end; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_BitmapGlyph *) + (* *) + (* <Description> *) + (* A handle to an object used to model a bitmap glyph image. This is *) + (* a sub-class of @FT_Glyph, and a pointer to @FT_BitmapGlyphRec. *) + (* *) + FT_BitmapGlyph = ^FT_BitmapGlyphRec; + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_BitmapGlyphRec *) + (* *) + (* <Description> *) + (* A structure used for bitmap glyph images. This really is a *) + (* `sub-class' of `FT_GlyphRec'. *) + (* *) + (* <Fields> *) + (* root :: The root FT_Glyph fields. *) + (* *) + (* left :: The left-side bearing, i.e., the horizontal distance *) + (* from the current pen position to the left border of the *) + (* glyph bitmap. *) + (* *) + (* top :: The top-side bearing, i.e., the vertical distance from *) + (* the current pen position to the top border of the glyph *) + (* bitmap. This distance is positive for upwards-y! *) + (* *) + (* bitmap :: A descriptor for the bitmap. *) + (* *) + (* <Note> *) + (* You can typecast FT_Glyph to FT_BitmapGlyph if you have *) + (* glyph->format == FT_GLYPH_FORMAT_BITMAP. This lets you access *) + (* the bitmap's contents easily. *) + (* *) + (* The corresponding pixel buffer is always owned by the BitmapGlyph *) + (* and is thus created and destroyed with it. *) + (* *) + FT_BitmapGlyphRec = record + root: FT_GlyphRec; + left: FT_Int; + top: FT_Int; + bitmap: FT_Bitmap; + end; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_OutlineGlyph *) + (* *) + (* <Description> *) + (* A handle to an object used to model an outline glyph image. This *) + (* is a sub-class of @FT_Glyph, and a pointer to @FT_OutlineGlyphRec. *) + (* *) + FT_OutlineGlyph = ^FT_OutlineGlyphRec; + + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_OutlineGlyphRec *) + (* *) + (* <Description> *) + (* A structure used for outline (vectorial) glyph images. This *) + (* really is a `sub-class' of `FT_GlyphRec'. *) + (* *) + (* <Fields> *) + (* root :: The root FT_Glyph fields. *) + (* *) + (* outline :: A descriptor for the outline. *) + (* *) + (* <Note> *) + (* You can typecast FT_Glyph to FT_OutlineGlyph if you have *) + (* glyph->format == FT_GLYPH_FORMAT_OUTLINE. This lets you access *) + (* the outline's content easily. *) + (* *) + (* As the outline is extracted from a glyph slot, its coordinates are *) + (* expressed normally in 26.6 pixels, unless the flag *) + (* FT_LOAD_NO_SCALE was used in FT_Load_Glyph() or FT_Load_Char(). *) + (* *) + (* The outline's tables are always owned by the object and are *) + (* destroyed with it. *) + (* *) + FT_OutlineGlyphRec = record + root: FT_GlyphRec; + outline: FT_Outline; + end; + +{$ELSE TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Get_Glyph *) + (* *) + (* <Description> *) + (* A function used to extract a glyph image from a slot. *) + (* *) + (* <Input> *) + (* slot :: A handle to the source glyph slot. *) + (* *) + (* <Output> *) + (* aglyph :: A handle to the glyph object. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + function FT_Get_Glyph( + slot: FT_GlyphSlot; + out aglyph: FT_Glyph ): FT_Error; + cdecl; external ft_lib name 'FT_Get_Glyph'; + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Glyph_Copy *) + (* *) + (* <Description> *) + (* A function used to copy a glyph image. Note that the created *) + (* @FT_Glyph object must be released with @FT_Done_Glyph. *) + (* *) + (* <Input> *) + (* source :: A handle to the source glyph object. *) + (* *) + (* <Output> *) + (* target :: A handle to the target glyph object. 0~in case of *) + (* error. *) + (* *) + (* <Return> *) + (* FreeType error code. 0~means success. *) + (* *) + function FT_Glyph_Copy(source: FT_Glyph; + var target: FT_Glyph ): FT_Error; + cdecl; external ft_lib name 'FT_Glyph_Copy'; + +{$ENDIF TYPE_DECL} +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Enum> *) + (* FT_Glyph_BBox_Mode *) + (* *) + (* <Description> *) + (* The mode how the values of @FT_Glyph_Get_CBox are returned. *) + (* *) + (* <Values> *) + (* FT_GLYPH_BBOX_UNSCALED :: *) + (* Return unscaled font units. *) + (* *) + (* FT_GLYPH_BBOX_SUBPIXELS :: *) + (* Return unfitted 26.6 coordinates. *) + (* *) + (* FT_GLYPH_BBOX_GRIDFIT :: *) + (* Return grid-fitted 26.6 coordinates. *) + (* *) + (* FT_GLYPH_BBOX_TRUNCATE :: *) + (* Return coordinates in integer pixels. *) + (* *) + (* FT_GLYPH_BBOX_PIXELS :: *) + (* Return grid-fitted pixel coordinates. *) + (* *) + FT_Glyph_BBox_Mode = cint; +{$ELSE TYPE_DECL} +const + FT_GLYPH_BBOX_UNSCALED = 0; + FT_GLYPH_BBOX_SUBPIXELS = 0; + FT_GLYPH_BBOX_GRIDFIT = 1; + FT_GLYPH_BBOX_TRUNCATE = 2; + FT_GLYPH_BBOX_PIXELS = 3; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Glyph_Get_CBox *) + (* *) + (* <Description> *) + (* Return a glyph's `control box'. The control box encloses all the *) + (* outline's points, including Bézier control points. Though it *) + (* coincides with the exact bounding box for most glyphs, it can be *) + (* slightly larger in some situations (like when rotating an outline *) + (* which contains Bézier outside arcs). *) + (* *) + (* Computing the control box is very fast, while getting the bounding *) + (* box can take much more time as it needs to walk over all segments *) + (* and arcs in the outline. To get the latter, you can use the *) + (* `ftbbox' component which is dedicated to this single task. *) + (* *) + (* <Input> *) + (* glyph :: A handle to the source glyph object. *) + (* *) + (* mode :: The mode which indicates how to interpret the returned *) + (* bounding box values. *) + (* *) + (* <Output> *) + (* acbox :: The glyph coordinate bounding box. Coordinates are *) + (* expressed in 1/64th of pixels if it is grid-fitted. *) + (* *) + (* <Note> *) + (* Coordinates are relative to the glyph origin, using the Y-upwards *) + (* convention. *) + (* *) + (* If the glyph has been loaded with @FT_LOAD_NO_SCALE, `bbox_mode' *) + (* must be set to @FT_GLYPH_BBOX_UNSCALED to get unscaled font *) + (* units in 26.6 pixel format. The value @FT_GLYPH_BBOX_SUBPIXELS *) + (* is another name for this constant. *) + (* *) + (* Note that the maximum coordinates are exclusive, which means that *) + (* one can compute the width and height of the glyph image (be it in *) + (* integer or 26.6 pixels) as: *) + (* *) + (* { *) + (* width = bbox.xMax - bbox.xMin; *) + (* height = bbox.yMax - bbox.yMin; *) + (* } *) + (* *) + (* Note also that for 26.6 coordinates, if `bbox_mode' is set to *) + (* @FT_GLYPH_BBOX_GRIDFIT, the coordinates will also be grid-fitted, *) + (* which corresponds to: *) + (* *) + (* { *) + (* bbox.xMin = FLOOR(bbox.xMin); *) + (* bbox.yMin = FLOOR(bbox.yMin); *) + (* bbox.xMax = CEILING(bbox.xMax); *) + (* bbox.yMax = CEILING(bbox.yMax); *) + (* } *) + (* *) + (* To get the bbox in pixel coordinates, set `bbox_mode' to *) + (* @FT_GLYPH_BBOX_TRUNCATE. *) + (* *) + (* To get the bbox in grid-fitted pixel coordinates, set `bbox_mode' *) + (* to @FT_GLYPH_BBOX_PIXELS. *) + (* *) + procedure FT_Glyph_Get_CBox( glyph: FT_Glyph; + bbox_mode: FT_UInt; + out acbox: FT_BBox ); + cdecl; external ft_lib name 'FT_Glyph_Get_CBox'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Glyph_To_Bitmap *) + (* *) + (* <Description> *) + (* Converts a given glyph object to a bitmap glyph object. *) + (* *) + (* <InOut> *) + (* the_glyph :: A pointer to a handle to the target glyph. *) + (* *) + (* <Input> *) + (* render_mode :: An enumeration that describe how the data is *) + (* rendered. *) + (* *) + (* origin :: A pointer to a vector used to translate the glyph *) + (* image before rendering. Can be 0 (if no *) + (* translation). The origin is expressed in *) + (* 26.6 pixels. *) + (* *) + (* destroy :: A boolean that indicates that the original glyph *) + (* image should be destroyed by this function. It is *) + (* never destroyed in case of error. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + (* <Note> *) + (* The glyph image is translated with the `origin' vector before *) + (* rendering. *) + (* *) + (* The first parameter is a pointer to a FT_Glyph handle, that will *) + (* be replaced by this function. Typically, you would use (omitting *) + (* error handling): *) + (* *) + (* *) + (* { *) + (* FT_Glyph glyph; *) + (* FT_BitmapGlyph glyph_bitmap; *) + (* *) + (* *) + (* // load glyph *) + (* error = FT_Load_Char( face, glyph_index, FT_LOAD_DEFAUT ); *) + (* *) + (* // extract glyph image *) + (* error = FT_Get_Glyph( face->glyph, &glyph ); *) + (* *) + (* // convert to a bitmap (default render mode + destroy old) *) + (* if ( glyph->format != FT_GLYPH_FORMAT_BITMAP ) *) + (* { *) + (* error = FT_Glyph_To_Bitmap( &glyph, FT_RENDER_MODE_DEFAULT, *) + (* 0, 1 ); *) + (* if ( error ) // glyph unchanged *) + (* ... *) + (* } *) + (* *) + (* // access bitmap content by typecasting *) + (* glyph_bitmap = (FT_BitmapGlyph)glyph; *) + (* *) + (* // do funny stuff with it, like blitting/drawing *) + (* ... *) + (* *) + (* // discard glyph image (bitmap or not) *) + (* FT_Done_Glyph( glyph ); *) + (* } *) + (* *) + (* *) + (* This function does nothing if the glyph format isn't scalable. *) + (* *) + function FT_Glyph_To_Bitmap(var the_glyph: FT_Glyph; + render_mode: FT_Render_Mode; + origin: PFT_Vector; + destroy: FT_Bool ): FT_Error; + cdecl; external ft_lib name 'FT_Glyph_To_Bitmap'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Done_Glyph *) + (* *) + (* <Description> *) + (* Destroys a given glyph. *) + (* *) + (* <Input> *) + (* glyph :: A handle to the target glyph object. *) + (* *) + procedure FT_Done_Glyph( glyph: FT_Glyph ); + cdecl; external ft_lib name 'FT_Done_Glyph'; + +{$ENDIF TYPE_DECL} diff --git a/cmake/src/lib/freetype/ftimage.inc b/cmake/src/lib/freetype/ftimage.inc new file mode 100644 index 00000000..d16d52a2 --- /dev/null +++ b/cmake/src/lib/freetype/ftimage.inc @@ -0,0 +1,849 @@ +(***************************************************************************) +(* *) +(* ftimage.h *) +(* *) +(* FreeType glyph image formats and default raster interface *) +(* (specification). *) +(* *) +(* Copyright 1996-2001, 2002, 2003, 2004, 2005, 2006, 2007 by *) +(* David Turner, Robert Wilhelm, and Werner Lemberg. *) +(* *) +(* This file is part of the FreeType project, and may only be used, *) +(* modified, and distributed under the terms of the FreeType project *) +(* license, LICENSE.TXT. By continuing to use, modify, or distribute *) +(* this file you indicate that you have read the license and *) +(* understand and accept it fully. *) +(* *) +(***************************************************************************) +(***************************************************************************) +(* Pascal port by the UltraStar Deluxe Team *) +(***************************************************************************) + + (*************************************************************************) + (* *) + (* Note: A `raster' is simply a scan-line converter, used to render *) + (* FT_Outlines into FT_Bitmaps. *) + (* *) + (*************************************************************************) + +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Pos *) + (* *) + (* <Description> *) + (* The type FT_Pos is a 32-bit integer used to store vectorial *) + (* coordinates. Depending on the context, these can represent *) + (* distances in integer font units, or 16,16, or 26.6 fixed float *) + (* pixel coordinates. *) + (* *) + FT_Pos = cslong; + + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Vector *) + (* *) + (* <Description> *) + (* A simple structure used to store a 2D vector; coordinates are of *) + (* the FT_Pos type. *) + (* *) + (* <Fields> *) + (* x :: The horizontal coordinate. *) + (* y :: The vertical coordinate. *) + (* *) + PFT_Vector = ^FT_Vector; + FT_Vector = record + x , + y : FT_Pos; + end; + + PFT_VectorArray = ^FT_VectorArray; + FT_VectorArray = array[0 .. (MaxInt div SizeOf(FT_Vector))-1] of FT_Vector; + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_BBox *) + (* *) + (* <Description> *) + (* A structure used to hold an outline's bounding box, i.e., the *) + (* coordinates of its extrema in the horizontal and vertical *) + (* directions. *) + (* *) + (* <Fields> *) + (* xMin :: The horizontal minimum (left-most). *) + (* *) + (* yMin :: The vertical minimum (bottom-most). *) + (* *) + (* xMax :: The horizontal maximum (right-most). *) + (* *) + (* yMax :: The vertical maximum (top-most). *) + (* *) + PFT_BBox = ^FT_BBox; + FT_BBox = record + xMin, yMin : FT_Pos; + xMax, yMax : FT_Pos; + end; + + + (*************************************************************************) + (* *) + (* <Enum> *) + (* FT_Pixel_Mode *) + (* *) + (* <Description> *) + (* An enumeration type used to describe the format of pixels in a *) + (* given bitmap. Note that additional formats may be added in the *) + (* future. *) + (* *) + (* <Values> *) + (* FT_PIXEL_MODE_NONE :: *) + (* Value 0 is reserved. *) + (* *) + (* FT_PIXEL_MODE_MONO :: *) + (* A monochrome bitmap, using 1 bit per pixel. Note that pixels *) + (* are stored in most-significant order (MSB), which means that *) + (* the left-most pixel in a byte has value 128. *) + (* *) + (* FT_PIXEL_MODE_GRAY :: *) + (* An 8-bit bitmap, generally used to represent anti-aliased glyph *) + (* images. Each pixel is stored in one byte. Note that the number *) + (* of value `gray' levels is stored in the `num_bytes' field of *) + (* the @FT_Bitmap structure (it generally is 256). *) + (* *) + (* FT_PIXEL_MODE_GRAY2 :: *) + (* A 2-bit/pixel bitmap, used to represent embedded anti-aliased *) + (* bitmaps in font files according to the OpenType specification. *) + (* We haven't found a single font using this format, however. *) + (* *) + (* FT_PIXEL_MODE_GRAY4 :: *) + (* A 4-bit/pixel bitmap, used to represent embedded anti-aliased *) + (* bitmaps in font files according to the OpenType specification. *) + (* We haven't found a single font using this format, however. *) + (* *) + (* FT_PIXEL_MODE_LCD :: *) + (* An 8-bit bitmap, used to represent RGB or BGR decimated glyph *) + (* images used for display on LCD displays; the bitmap is three *) + (* times wider than the original glyph image. See also *) + (* @FT_RENDER_MODE_LCD. *) + (* *) + (* FT_PIXEL_MODE_LCD_V :: *) + (* An 8-bit bitmap, used to represent RGB or BGR decimated glyph *) + (* images used for display on rotated LCD displays; the bitmap *) + (* is three times taller than the original glyph image. See also *) + (* @FT_RENDER_MODE_LCD_V. *) + (* *) + FT_Pixel_Mode = cint; +{$ELSE TYPE_DECL} +const + FT_PIXEL_MODE_NONE = 0; + FT_PIXEL_MODE_MONO = FT_PIXEL_MODE_NONE + 1; + FT_PIXEL_MODE_GRAY = FT_PIXEL_MODE_MONO + 1; + FT_PIXEL_MODE_GRAY2 = FT_PIXEL_MODE_GRAY + 1; + FT_PIXEL_MODE_GRAY4 = FT_PIXEL_MODE_GRAY2 + 1; + FT_PIXEL_MODE_LCD = FT_PIXEL_MODE_GRAY4 + 1; + FT_PIXEL_MODE_LCD_V = FT_PIXEL_MODE_LCD + 1; + + FT_PIXEL_MODE_MAX = FT_PIXEL_MODE_LCD_V + 1; (* do not remove *) +{$ENDIF TYPE_DECL} +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Bitmap *) + (* *) + (* <Description> *) + (* A structure used to describe a bitmap or pixmap to the raster. *) + (* Note that we now manage pixmaps of various depths through the *) + (* `pixel_mode' field. *) + (* *) + (* <Fields> *) + (* rows :: The number of bitmap rows. *) + (* *) + (* width :: The number of pixels in bitmap row. *) + (* *) + (* pitch :: The pitch's absolute value is the number of bytes *) + (* taken by one bitmap row, including padding. *) + (* However, the pitch is positive when the bitmap has *) + (* a `down' flow, and negative when it has an `up' *) + (* flow. In all cases, the pitch is an offset to add *) + (* to a bitmap pointer in order to go down one row. *) + (* *) + (* buffer :: A typeless pointer to the bitmap buffer. This *) + (* value should be aligned on 32-bit boundaries in *) + (* most cases. *) + (* *) + (* num_grays :: This field is only used with *) + (* `FT_PIXEL_MODE_GRAY'; it gives the number of gray *) + (* levels used in the bitmap. *) + (* *) + (* pixel_mode :: The pixel mode, i.e., how pixel bits are stored. *) + (* See @FT_Pixel_Mode for possible values. *) + (* *) + (* palette_mode :: This field is only used with paletted pixel modes; *) + (* it indicates how the palette is stored. *) + (* *) + (* palette :: A typeless pointer to the bitmap palette; only *) + (* used for paletted pixel modes. *) + (* *) + (* <Note> *) + (* For now, the only pixel mode supported by FreeType are mono and *) + (* grays. However, drivers might be added in the future to support *) + (* more `colorful' options. *) + (* *) + (* When using pixel modes pal2, pal4 and pal8 with a void `palette' *) + (* field, a gray pixmap with respectively 4, 16, and 256 levels of *) + (* gray is assumed. This, in order to be compatible with some *) + (* embedded bitmap formats defined in the TrueType specification. *) + (* *) + (* Note that no font was found presenting such embedded bitmaps, so *) + (* this is currently completely unhandled by the library. *) + (* *) + PFT_Bitmap = ^FT_Bitmap; + FT_Bitmap = record + rows: FT_Int; + width: FT_Int; + pitch: FT_Int; + buffer: PByteArray; + num_grays: FT_Short; + pixel_mode: byte; + palette_mode: byte; + palette: pointer; + end; + + + (*************************************************************************) + (* *) + (* <Section> *) + (* outline_processing *) + (* *) + (*************************************************************************) + + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Outline *) + (* *) + (* <Description> *) + (* This structure is used to describe an outline to the scan-line *) + (* converter. *) + (* *) + (* <Fields> *) + (* n_contours :: The number of contours in the outline. *) + (* *) + (* n_points :: The number of points in the outline. *) + (* *) + (* points :: A pointer to an array of `n_points' FT_Vector *) + (* elements, giving the outline's point coordinates. *) + (* *) + (* tags :: A pointer to an array of `n_points' chars, giving *) + (* each outline point's type. If bit 0 is unset, the *) + (* point is `off' the curve, i.e. a Bezier control *) + (* point, while it is `on' when set. *) + (* *) + (* Bit 1 is meaningful for `off' points only. If set, *) + (* it indicates a third-order Bezier arc control point; *) + (* and a second-order control point if unset. *) + (* *) + (* contours :: An array of `n_contours' shorts, giving the end *) + (* point of each contour within the outline. For *) + (* example, the first contour is defined by the points *) + (* `0' to `contours[0]', the second one is defined by *) + (* the points `contours[0]+1' to `contours[1]', etc. *) + (* *) + (* flags :: A set of bit flags used to characterize the outline *) + (* and give hints to the scan-converter and hinter on *) + (* how to convert/grid-fit it. See FT_Outline_Flags. *) + (* *) + PFT_Outline = ^FT_Outline; + FT_Outline = record + n_contours: FT_Short; (* number of contours in glyph *) + n_points: FT_Short; (* number of points in the glyph *) + + points: PFT_VectorArray; (* the outline's points *) + tags: PByteArray; (* the points flags *) + contours: PFT_ShortArray; (* the contour end points *) + + flags: FT_Int; (* outline masks *) + end; + +{$ELSE TYPE_DECL} + + (*************************************************************************) + (* *) + (* @macro: *) + (* FT_CURVE_TAG ( flag ) *) + (* *) + function FT_CURVE_TAG(flag: byte): byte; + +const + FT_CURVE_TAG_ON = 1; + FT_CURVE_TAG_CONIC = 0; + FT_CURVE_TAG_CUBIC = 2; + + FT_CURVE_TAG_TOUCH_X = 8; // reserved for the TrueType hinter + FT_CURVE_TAG_TOUCH_Y = 16; // reserved for the TrueType hinter + + FT_CURVE_TAG_TOUCH_BOTH = ( FT_CURVE_TAG_TOUCH_X or + FT_CURVE_TAG_TOUCH_Y ); +{$ENDIF TYPE_DECL} +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_Outline_MoveToFunc *) + (* *) + (* <Description> *) + (* A function pointer type used to describe the signature of a `move *) + (* to' function during outline walking/decomposition. *) + (* *) + (* A `move to' is emitted to start a new contour in an outline. *) + (* *) + (* <Input> *) + (* to :: A pointer to the target point of the `move to'. *) + (* *) + (* user :: A typeless pointer which is passed from the caller of the *) + (* decomposition function. *) + (* *) + (* <Return> *) + (* Error code. 0 means success. *) + (* *) + FT_Outline_MoveToFunc = function(to_: {const} PFT_Vector; + user: Pointer): cint; cdecl; + + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_Outline_LineToFunc *) + (* *) + (* <Description> *) + (* A function pointer type used to describe the signature of a `line *) + (* to' function during outline walking/decomposition. *) + (* *) + (* A `line to' is emitted to indicate a segment in the outline. *) + (* *) + (* <Input> *) + (* to :: A pointer to the target point of the `line to'. *) + (* *) + (* user :: A typeless pointer which is passed from the caller of the *) + (* decomposition function. *) + (* *) + (* <Return> *) + (* Error code. 0 means success. *) + (* *) + FT_Outline_LineToFunc = function(to_: {const} PFT_Vector; + user: Pointer): cint; cdecl; + + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_Outline_ConicToFunc *) + (* *) + (* <Description> *) + (* A function pointer type use to describe the signature of a `conic *) + (* to' function during outline walking/decomposition. *) + (* *) + (* A `conic to' is emitted to indicate a second-order Bézier arc in *) + (* the outline. *) + (* *) + (* <Input> *) + (* control :: An intermediate control point between the last position *) + (* and the new target in `to'. *) + (* *) + (* to :: A pointer to the target end point of the conic arc. *) + (* *) + (* user :: A typeless pointer which is passed from the caller of *) + (* the decomposition function. *) + (* *) + (* <Return> *) + (* Error code. 0 means success. *) + (* *) + FT_Outline_ConicToFunc = function(control: {const} PFT_Vector; + to_: {const} PFT_Vector; + user: Pointer): cint; cdecl; + + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_Outline_CubicToFunc *) + (* *) + (* <Description> *) + (* A function pointer type used to describe the signature of a `cubic *) + (* to' function during outline walking/decomposition. *) + (* *) + (* A `cubic to' is emitted to indicate a third-order Bézier arc. *) + (* *) + (* <Input> *) + (* control1 :: A pointer to the first Bézier control point. *) + (* *) + (* control2 :: A pointer to the second Bézier control point. *) + (* *) + (* to :: A pointer to the target end point. *) + (* *) + (* user :: A typeless pointer which is passed from the caller of *) + (* the decomposition function. *) + (* *) + (* <Return> *) + (* Error code. 0 means success. *) + (* *) + FT_Outline_CubicToFunc = function( control1: {const} PFT_Vector; + control2: {const} PFT_Vector; + to_: {const} PFT_Vector; + user: Pointer ): cint; cdecl; + + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Outline_Funcs *) + (* *) + (* <Description> *) + (* A structure to hold various function pointers used during outline *) + (* decomposition in order to emit segments, conic, and cubic Béziers, *) + (* as well as `move to' and `close to' operations. *) + (* *) + (* <Fields> *) + (* move_to :: The `move to' emitter. *) + (* *) + (* line_to :: The segment emitter. *) + (* *) + (* conic_to :: The second-order Bézier arc emitter. *) + (* *) + (* cubic_to :: The third-order Bézier arc emitter. *) + (* *) + (* shift :: The shift that is applied to coordinates before they *) + (* are sent to the emitter. *) + (* *) + (* delta :: The delta that is applied to coordinates before they *) + (* are sent to the emitter, but after the shift. *) + (* *) + (* <Note> *) + (* The point coordinates sent to the emitters are the transformed *) + (* version of the original coordinates (this is important for high *) + (* accuracy during scan-conversion). The transformation is simple: *) + (* *) + (* { *) + (* x' = (x << shift) - delta *) + (* y' = (x << shift) - delta *) + (* } *) + (* *) + (* Set the value of `shift' and `delta' to 0 to get the original *) + (* point coordinates. *) + (* *) + PFT_Outline_Funcs = ^FT_Outline_Funcs; + FT_Outline_Funcs = record + move_to: FT_Outline_MoveToFunc; + line_to: FT_Outline_LineToFunc; + conic_to: FT_Outline_ConicToFunc; + cubic_to: FT_Outline_CubicToFunc; + + shift: cint; + delta: FT_Pos; + end; + + + (*************************************************************************) + (* *)
+ (* <Macro> *)
+ (* FT_IMAGE_TAG *)
+ (* *)
+ (* <Description> *)
+ (* This macro converts four-letter tags to an unsigned long type. *)
+ (* *)
+ (* <Note> *)
+ (* Since many 16-bit compilers don't like 32-bit enumerations, you *)
+ (* should redefine this macro in case of problems to something like *)
+ (* this: *)
+ (* *)
+ (* { *)
+ (* #define FT_IMAGE_TAG( value, _x1, _x2, _x3, _x4 ) value *)
+ (* } *)
+ (* *)
+ (* to get a simple enumeration without assigning special numbers. *)
+ (* *)
+ {
+ #define FT_IMAGE_TAG( value, _x1, _x2, _x3, _x4 ) \
+ value = ( ( (unsigned long)_x1 << 24 ) | \
+ ( (unsigned long)_x2 << 16 ) | \
+ ( (unsigned long)_x3 << 8 ) | \
+ (unsigned long)_x4 )
+ }
+
+ (*************************************************************************) + (* *) + (* <Enum> *) + (* FT_Glyph_Format *) + (* *) + (* <Description> *) + (* An enumeration type used to describe the format of a given glyph *) + (* image. Note that this version of FreeType only supports two image *) + (* formats, even though future font drivers will be able to register *) + (* their own format. *) + (* *) + (* <Values> *) + (* FT_GLYPH_FORMAT_NONE :: *) + (* The value 0 is reserved and does describe a glyph format. *) + (* *) + (* FT_GLYPH_FORMAT_COMPOSITE :: *) + (* The glyph image is a composite of several other images. This *) + (* format is _only_ used with @FT_LOAD_NO_RECURSE, and is used to *) + (* report compound glyphs (like accented characters). *) + (* *) + (* FT_GLYPH_FORMAT_BITMAP :: *) + (* The glyph image is a bitmap, and can be described as an *) + (* @FT_Bitmap. You generally need to access the `bitmap' field of *) + (* the @FT_GlyphSlotRec structure to read it. *) + (* *) + (* FT_GLYPH_FORMAT_OUTLINE :: *) + (* The glyph image is a vertorial outline made of line segments *) + (* and Bezier arcs; it can be described as an @FT_Outline; you *) + (* generally want to access the `outline' field of the *) + (* @FT_GlyphSlotRec structure to read it. *) + (* *) + (* FT_GLYPH_FORMAT_PLOTTER :: *) + (* The glyph image is a vectorial path with no inside/outside *) + (* contours. Some Type 1 fonts, like those in the Hershey family, *) + (* contain glyphs in this format. These are described as *) + (* @FT_Outline, but FreeType isn't currently capable of rendering *) + (* them correctly. *) + (* *) + // Note: enums are 32 bit on x86 AND x86_64 + FT_Glyph_Format = cuint32; // 32 bit enum of FT_IMAGE_TAG +{$ELSE TYPE_DECL} +const + FT_GLYPH_FORMAT_NONE = (Ord(#0) shl 24) or + (Ord(#0) shl 16) or
+ (Ord(#0) shl 8) or
+ (Ord(#0) shl 0); + + FT_GLYPH_FORMAT_COMPOSITE = (Ord('c') shl 24) or + (Ord('o') shl 16) or
+ (Ord('m') shl 8) or
+ (Ord('p') shl 0); + + FT_GLYPH_FORMAT_BITMAP = (Ord('b') shl 24) or + (Ord('i') shl 16) or
+ (Ord('t') shl 8) or
+ (Ord('s') shl 0); + + FT_GLYPH_FORMAT_OUTLINE = (Ord('o') shl 24) or + (Ord('u') shl 16) or
+ (Ord('t') shl 8) or
+ (Ord('l') shl 0); + + FT_GLYPH_FORMAT_PLOTTER = (Ord('p') shl 24) or + (Ord('l') shl 16) or
+ (Ord('o') shl 8) or
+ (Ord('t') shl 0); + +{$ENDIF TYPE_DECL} + + (*************************************************************************) + (*************************************************************************) + (*************************************************************************) + (***** *****) + (***** R A S T E R D E F I N I T I O N S *****) + (***** *****) + (*************************************************************************) + (*************************************************************************) + (*************************************************************************) + + + (*************************************************************************) + (* *) + (* A raster is a scan converter, in charge of rendering an outline into *) + (* a a bitmap. This section contains the public API for rasters. *) + (* *) + (* Note that in FreeType 2, all rasters are now encapsulated within *) + (* specific modules called `renderers'. See `freetype/ftrender.h' for *) + (* more details on renderers. *) + (* *) + (*************************************************************************) + + + (*************************************************************************) + (* *) + (* <Section> *) + (* raster *) + (* *) + (* <Title> *) + (* Scanline Converter *) + (* *) + (* <Abstract> *) + (* How vectorial outlines are converted into bitmaps and pixmaps. *) + (* *) + (* <Description> *) + (* This section contains technical definitions. *) + (* *) + (*************************************************************************) + +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Raster *) + (* *) + (* <Description> *) + (* A handle (pointer) to a raster object. Each object can be used *) + (* independently to convert an outline into a bitmap or pixmap. *) + (* *) + FT_Raster = Pointer; + + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Span *) + (* *) + (* <Description> *) + (* A structure used to model a single span of gray (or black) pixels *) + (* when rendering a monochrome or anti-aliased bitmap. *) + (* *) + (* <Fields> *) + (* x :: The span's horizontal start position. *) + (* *) + (* len :: The span's length in pixels. *) + (* *) + (* coverage :: The span color/coverage, ranging from 0 (background) *) + (* to 255 (foreground). Only used for anti-aliased *) + (* rendering. *) + (* *) + (* <Note> *) + (* This structure is used by the span drawing callback type named *) + (* @FT_SpanFunc which takes the y-coordinate of the span as a *) + (* a parameter. *) + (* *) + (* The coverage value is always between 0 and 255. *) + (* *) + PFT_Span = ^FT_Span; + FT_Span = record + x: cshort; + len: cushort; + coverage: cuchar; + end; + + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_SpanFunc *) + (* *) + (* <Description> *) + (* A function used as a call-back by the anti-aliased renderer in *) + (* order to let client applications draw themselves the gray pixel *) + (* spans on each scan line. *) + (* *) + (* <Input> *) + (* y :: The scanline's y-coordinate. *) + (* *) + (* count :: The number of spans to draw on this scanline. *) + (* *) + (* spans :: A table of `count' spans to draw on the scanline. *) + (* *) + (* user :: User-supplied data that is passed to the callback. *) + (* *) + (* <Note> *) + (* This callback allows client applications to directly render the *) + (* gray spans of the anti-aliased bitmap to any kind of surfaces. *) + (* *) + (* This can be used to write anti-aliased outlines directly to a *) + (* given background bitmap, and even perform translucency. *) + (* *) + (* Note that the `count' field cannot be greater than a fixed value *) + (* defined by the `FT_MAX_GRAY_SPANS' configuration macro in *) + (* `ftoption.h'. By default, this value is set to 32, which means *) + (* that if there are more than 32 spans on a given scanline, the *) + (* callback is called several times with the same `y' parameter in *) + (* order to draw all callbacks. *) + (* *) + (* Otherwise, the callback is only called once per scan-line, and *) + (* only for those scanlines that do have `gray' pixels on them. *) + (* *) + FT_SpanFunc = procedure(y: cint; + count: cint; + spans: {const} PFT_Span; + user: Pointer ); cdecl; + + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_Raster_BitTest_Func *) + (* *) + (* <Description> *) + (* THIS TYPE IS DEPRECATED. DO NOT USE IT. *) + (* *) + (* A function used as a call-back by the monochrome scan-converter *) + (* to test whether a given target pixel is already set to the drawing *) + (* `color'. These tests are crucial to implement drop-out control *) + (* per-se the TrueType spec. *) + (* *) + (* <Input> *) + (* y :: The pixel's y-coordinate. *) + (* *) + (* x :: The pixel's x-coordinate. *) + (* *) + (* user :: User-supplied data that is passed to the callback. *) + (* *) + (* <Return> *) + (* 1 if the pixel is `set', 0 otherwise. *) + (* *) + FT_Raster_BitTest_Func = function(y: cint; + x: cint; + user: Pointer): cint; cdecl; + + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_Raster_BitSet_Func *) + (* *) + (* <Description> *) + (* THIS TYPE IS DEPRECATED. DO NOT USE IT. *) + (* *) + (* A function used as a call-back by the monochrome scan-converter *) + (* to set an individual target pixel. This is crucial to implement *) + (* drop-out control according to the TrueType specification. *) + (* *) + (* <Input> *) + (* y :: The pixel's y-coordinate. *) + (* *) + (* x :: The pixel's x-coordinate. *) + (* *) + (* user :: User-supplied data that is passed to the callback. *) + (* *) + (* <Return> *) + (* 1 if the pixel is `set', 0 otherwise. *) + (* *) + FT_Raster_BitSet_Func = procedure(y: cint; + x: cint; + user: Pointer ); cdecl; + + + (*************************************************************************) + (* *) + (* <Enum> *) + (* FT_RASTER_FLAG_XXX *) + (* *) + (* <Description> *) + (* A list of bit flag constants as used in the `flags' field of a *) + (* @FT_Raster_Params structure. *) + (* *) + (* <Values> *) + (* FT_RASTER_FLAG_DEFAULT :: This value is 0. *) + (* *) + (* FT_RASTER_FLAG_AA :: This flag is set to indicate that an *) + (* anti-aliased glyph image should be *) + (* generated. Otherwise, it will be *) + (* monochrome (1-bit). *) + (* *) + (* FT_RASTER_FLAG_DIRECT :: This flag is set to indicate direct *) + (* rendering. In this mode, client *) + (* applications must provide their own span *) + (* callback. This lets them directly *) + (* draw or compose over an existing bitmap. *) + (* If this bit is not set, the target *) + (* pixmap's buffer _must_ be zeroed before *) + (* rendering. *) + (* *) + (* Note that for now, direct rendering is *) + (* only possible with anti-aliased glyphs. *) + (* *) + (* FT_RASTER_FLAG_CLIP :: This flag is only used in direct *) + (* rendering mode. If set, the output will *) + (* be clipped to a box specified in the *) + (* `clip_box' field of the *) + (* @FT_Raster_Params structure. *) + (* *) + (* Note that by default, the glyph bitmap *) + (* is clipped to the target pixmap, except *) + (* in direct rendering mode where all spans *) + (* are generated if no clipping box is set. *) + (* *) +{$ELSE TYPE_DECL} +const + FT_RASTER_FLAG_DEFAULT = $0; + FT_RASTER_FLAG_AA = $1; + FT_RASTER_FLAG_DIRECT = $2; + FT_RASTER_FLAG_CLIP = $4; + +{$ENDIF TYPE_DECL} +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Raster_Params *) + (* *) + (* <Description> *) + (* A structure to hold the arguments used by a raster's render *) + (* function. *) + (* *) + (* <Fields> *) + (* target :: The target bitmap. *) + (* *) + (* source :: A pointer to the source glyph image (e.g., an *) + (* @FT_Outline). *) + (* *) + (* flags :: The rendering flags. *) + (* *) + (* gray_spans :: The gray span drawing callback. *) + (* *) + (* black_spans :: The black span drawing callback. *) + (* *) + (* bit_test :: The bit test callback. UNIMPLEMENTED! *) + (* *) + (* bit_set :: The bit set callback. UNIMPLEMENTED! *) + (* *) + (* user :: User-supplied data that is passed to each drawing *) + (* callback. *) + (* *) + (* clip_box :: An optional clipping box. It is only used in *) + (* direct rendering mode. Note that coordinates here *) + (* should be expressed in _integer_ pixels (and not in *) + (* 26.6 fixed-point units). *) + (* *) + (* <Note> *) + (* An anti-aliased glyph bitmap is drawn if the @FT_RASTER_FLAG_AA *) + (* bit flag is set in the `flags' field, otherwise a monochrome *) + (* bitmap is generated. *) + (* *) + (* If the @FT_RASTER_FLAG_DIRECT bit flag is set in `flags', the *) + (* raster will call the `gray_spans' callback to draw gray pixel *) + (* spans, in the case of an aa glyph bitmap, it will call *) + (* `black_spans', and `bit_test' and `bit_set' in the case of a *) + (* monochrome bitmap. This allows direct composition over a *) + (* pre-existing bitmap through user-provided callbacks to perform the *) + (* span drawing/composition. *) + (* *) + (* Note that the `bit_test' and `bit_set' callbacks are required when *) + (* rendering a monochrome bitmap, as they are crucial to implement *) + (* correct drop-out control as defined in the TrueType specification. *) + (* *) + PFT_Raster_Params = ^FT_Raster_Params; + FT_Raster_Params = record + target: {const} PFT_Bitmap; + source: {const} Pointer; + flags: cint; + gray_spans: FT_SpanFunc; + black_spans: FT_SpanFunc; + bit_test: FT_Raster_BitTest_Func; (* doesn't work! *) + bit_set: FT_Raster_BitSet_Func; (* doesn't work! *) + user: Pointer; + clip_box: FT_BBox; + end; + +{$ENDIF TYPE_DECL} + + diff --git a/cmake/src/lib/freetype/ftoutln.inc b/cmake/src/lib/freetype/ftoutln.inc new file mode 100644 index 00000000..997c6cb3 --- /dev/null +++ b/cmake/src/lib/freetype/ftoutln.inc @@ -0,0 +1,497 @@ +(***************************************************************************) +(* *) +(* ftoutln.h *) +(* *) +(* Support for the FT_Outline type used to store glyph shapes of *) +(* most scalable font formats (specification). *) +(* *) +(* Copyright 1996-2001, 2002, 2003, 2005, 2006, 2007 by *) +(* David Turner, Robert Wilhelm, and Werner Lemberg. *) +(* *) +(* This file is part of the FreeType project, and may only be used, *) +(* modified, and distributed under the terms of the FreeType project *) +(* license, LICENSE.TXT. By continuing to use, modify, or distribute *) +(* this file you indicate that you have read the license and *) +(* understand and accept it fully. *) +(* *) +(***************************************************************************) +(***************************************************************************) +(* Pascal port by the UltraStar Deluxe Team *) +(***************************************************************************) + + + (*************************************************************************) + (* *) + (* <Section> *) + (* outline_processing *) + (* *) + (* <Title> *) + (* Outline Processing *) + (* *) + (* <Abstract> *) + (* Functions to create, transform, and render vectorial glyph images. *) + (* *) + (* <Description> *) + (* This section contains routines used to create and destroy scalable *) + (* glyph images known as `outlines'. These can also be measured, *) + (* transformed, and converted into bitmaps and pixmaps. *) + (* *) + (* <Order> *) + (* FT_Outline *) + (* FT_OUTLINE_FLAGS *) + (* FT_Outline_New *) + (* FT_Outline_Done *) + (* FT_Outline_Copy *) + (* FT_Outline_Translate *) + (* FT_Outline_Transform *) + (* FT_Outline_Embolden *) + (* FT_Outline_Reverse *) + (* FT_Outline_Check *) + (* *) + (* FT_Outline_Get_CBox *) + (* FT_Outline_Get_BBox *) + (* *) + (* FT_Outline_Get_Bitmap *) + (* FT_Outline_Render *) + (* *) + (* FT_Outline_Decompose *) + (* FT_Outline_Funcs *) + (* FT_Outline_MoveTo_Func *) + (* FT_Outline_LineTo_Func *) + (* FT_Outline_ConicTo_Func *) + (* FT_Outline_CubicTo_Func *) + (* *) + (*************************************************************************) + +{$IFNDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Decompose *) + (* *) + (* <Description> *) + (* Walks over an outline's structure to decompose it into individual *) + (* segments and Bézier arcs. This function is also able to emit *) + (* `move to' and `close to' operations to indicate the start and end *) + (* of new contours in the outline. *) + (* *) + (* <Input> *) + (* outline :: A pointer to the source target. *) + (* *) + (* func_interface :: A table of `emitters', i.e,. function pointers *) + (* called during decomposition to indicate path *) + (* operations. *) + (* *) + (* <InOut> *) + (* user :: A typeless pointer which is passed to each *) + (* emitter during the decomposition. It can be *) + (* used to store the state during the *) + (* decomposition. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + function FT_Outline_Decompose( + outline: PFT_Outline; + func_interface: {const} PFT_Outline_Funcs; + user: Pointer): FT_Error; + cdecl; external ft_lib name 'FT_Outline_Decompose'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_New *) + (* *) + (* <Description> *) + (* Creates a new outline of a given size. *) + (* *) + (* <Input> *) + (* library :: A handle to the library object from where the *) + (* outline is allocated. Note however that the new *) + (* outline will *not* necessarily be *freed*, when *) + (* destroying the library, by @FT_Done_FreeType. *) + (* *) + (* numPoints :: The maximal number of points within the outline. *) + (* *) + (* numContours :: The maximal number of contours within the outline. *) + (* *) + (* <Output> *) + (* anoutline :: A handle to the new outline. NULL in case of *) + (* error. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + (* <Note> *) + (* The reason why this function takes a `library' parameter is simply *) + (* to use the library's memory allocator. *) + (* *) + function FT_Outline_New( + library_: FT_Library; + numPoints: FT_UInt; + numContours: FT_Int; + anoutline: PFT_Outline): FT_Error; + cdecl; external ft_lib name 'FT_Outline_New'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Done *) + (* *) + (* <Description> *) + (* Destroys an outline created with @FT_Outline_New. *) + (* *) + (* <Input> *) + (* library :: A handle of the library object used to allocate the *) + (* outline. *) + (* *) + (* outline :: A pointer to the outline object to be discarded. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + (* <Note> *) + (* If the outline's `owner' field is not set, only the outline *) + (* descriptor will be released. *) + (* *) + (* The reason why this function takes an `library' parameter is *) + (* simply to use ft_mem_free(). *) + (* *) + function FT_Outline_Done(library_: FT_Library; + outline: PFT_Outline): FT_Error; + cdecl; external ft_lib name 'FT_Outline_Done'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Check *) + (* *) + (* <Description> *) + (* Check the contents of an outline descriptor. *) + (* *) + (* <Input> *) + (* outline :: A handle to a source outline. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + function FT_Outline_Check( outline: PFT_Outline ): FT_Error; + cdecl; external ft_lib name 'FT_Outline_Check'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Get_CBox *) + (* *) + (* <Description> *) + (* Returns an outline's `control box'. The control box encloses all *) + (* the outline's points, including Bézier control points. Though it *) + (* coincides with the exact bounding box for most glyphs, it can be *) + (* slightly larger in some situations (like when rotating an outline *) + (* which contains Bézier outside arcs). *) + (* *) + (* Computing the control box is very fast, while getting the bounding *) + (* box can take much more time as it needs to walk over all segments *) + (* and arcs in the outline. To get the latter, you can use the *) + (* `ftbbox' component which is dedicated to this single task. *) + (* *) + (* <Input> *) + (* outline :: A pointer to the source outline descriptor. *) + (* *) + (* <Output> *) + (* acbox :: The outline's control box. *) + (* *) + procedure FT_Outline_Get_CBox( + outline: {const} PFT_Outline; + acbox: PFT_BBox); + cdecl; external ft_lib name 'FT_Outline_Get_CBox'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Translate *) + (* *) + (* <Description> *) + (* Applies a simple translation to the points of an outline. *) + (* *) + (* <InOut> *) + (* outline :: A pointer to the target outline descriptor. *) + (* *) + (* <Input> *) + (* xOffset :: The horizontal offset. *) + (* *) + (* yOffset :: The vertical offset. *) + (* *) + procedure FT_Outline_Translate( + outline: {const} PFT_Outline; + xOffset: FT_Pos; + yOffset: FT_Pos); + cdecl; external ft_lib name 'FT_Outline_Translate'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Copy *) + (* *) + (* <Description> *) + (* Copies an outline into another one. Both objects must have the *) + (* same sizes (number of points & number of contours) when this *) + (* function is called. *) + (* *) + (* <Input> *) + (* source :: A handle to the source outline. *) + (* *) + (* <Output> *) + (* target :: A handle to the target outline. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + function FT_Outline_Copy( + source: {const} PFT_Outline; + target: PFT_Outline): FT_Error; + cdecl; external ft_lib name 'FT_Outline_Copy'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Transform *) + (* *) + (* <Description> *) + (* Applies a simple 2x2 matrix to all of an outline's points. Useful *) + (* for applying rotations, slanting, flipping, etc. *) + (* *) + (* <InOut> *) + (* outline :: A pointer to the target outline descriptor. *) + (* *) + (* <Input> *) + (* matrix :: A pointer to the transformation matrix. *) + (* *) + (* <Note> *) + (* You can use @FT_Outline_Translate if you need to translate the *) + (* outline's points. *) + (* *) + procedure FT_Outline_Transform( + outline: {const} PFT_Outline; + matrix: {const} PFT_Matrix); + cdecl; external ft_lib name 'FT_Outline_Transform'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Embolden *) + (* *) + (* <Description> *) + (* Emboldens an outline. The new outline will be at most 4 times *) + (* `strength' pixels wider and higher. You may think of the left and *) + (* bottom borders as unchanged. *) + (* *) + (* Negative `strength' values to reduce the outline thickness are *) + (* possible also. *) + (* *) + (* <InOut> *) + (* outline :: A handle to the target outline. *) + (* *) + (* <Input> *) + (* strength :: How strong the glyph is emboldened. Expressed in *) + (* 26.6 pixel format. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + (* <Note> *) + (* The used algorithm to increase or decrease the thickness of the *) + (* glyph doesn't change the number of points; this means that certain *) + (* situations like acute angles or intersections are sometimes *) + (* handled incorrectly. *) + (* *) + (* Example call: *) + (* *) + (* { *) + (* FT_Load_Glyph( face, index, FT_LOAD_DEFAULT ); *) + (* if ( face->slot->format == FT_GLYPH_FORMAT_OUTLINE ) *) + (* FT_Outline_Embolden( &face->slot->outline, strength ); *) + (* } *) + (* *) + function FT_Outline_Embolden( + outline: PFT_Outline; + strength: FT_Pos): FT_Error; + cdecl; external ft_lib name 'FT_Outline_Embolden'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Reverse *) + (* *) + (* <Description> *) + (* Reverses the drawing direction of an outline. This is used to *) + (* ensure consistent fill conventions for mirrored glyphs. *) + (* *) + (* <InOut> *) + (* outline :: A pointer to the target outline descriptor. *) + (* *) + (* <Note> *) + (* This functions toggles the bit flag @FT_OUTLINE_REVERSE_FILL in *) + (* the outline's `flags' field. *) + (* *) + (* It shouldn't be used by a normal client application, unless it *) + (* knows what it is doing. *) + (* *) + procedure FT_Outline_Reverse( outline: PFT_Outline ); + cdecl; external ft_lib name 'FT_Outline_Reverse'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Get_Bitmap *) + (* *) + (* <Description> *) + (* Renders an outline within a bitmap. The outline's image is simply *) + (* OR-ed to the target bitmap. *) + (* *) + (* <Input> *) + (* library :: A handle to a FreeType library object. *) + (* *) + (* outline :: A pointer to the source outline descriptor. *) + (* *) + (* <InOut> *) + (* abitmap :: A pointer to the target bitmap descriptor. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + (* <Note> *) + (* This function does NOT CREATE the bitmap, it only renders an *) + (* outline image within the one you pass to it! *) + (* *) + (* It will use the raster corresponding to the default glyph format. *) + (* *) + function FT_Outline_Get_Bitmap( + library_: FT_Library; + outline: PFT_Outline; + abitmap: {const} PFT_Bitmap): FT_Error; + cdecl; external ft_lib name 'FT_Outline_Get_Bitmap'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Render *) + (* *) + (* <Description> *) + (* Renders an outline within a bitmap using the current scan-convert. *) + (* This functions uses an @FT_Raster_Params structure as an argument, *) + (* allowing advanced features like direct composition, translucency, *) + (* etc. *) + (* *) + (* <Input> *) + (* library :: A handle to a FreeType library object. *) + (* *) + (* outline :: A pointer to the source outline descriptor. *) + (* *) + (* <InOut> *) + (* params :: A pointer to an @FT_Raster_Params structure used to *) + (* describe the rendering operation. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + (* <Note> *) + (* You should know what you are doing and how @FT_Raster_Params works *) + (* to use this function. *) + (* *) + (* The field `params.source' will be set to `outline' before the scan *) + (* converter is called, which means that the value you give to it is *) + (* actually ignored. *) + (* *) + function FT_Outline_Render( + library_: FT_Library; + outline: PFT_Outline; + params: PFT_Raster_Params): FT_Error; + cdecl; external ft_lib name 'FT_Outline_Render'; + +{$ENDIF TYPE_DECL} + + (************************************************************************** + * + * @enum: + * FT_Orientation + * + * @description: + * A list of values used to describe an outline's contour orientation. + * + * The TrueType and Postscript specifications use different conventions + * to determine whether outline contours should be filled or unfilled. + * + * @values: + * FT_ORIENTATION_TRUETYPE :: + * According to the TrueType specification, clockwise contours must + * be filled, and counter-clockwise ones must be unfilled. + * + * FT_ORIENTATION_POSTSCRIPT :: + * According to the Postscript specification, counter-clockwise contours + * must be filled, and clockwise ones must be unfilled. + * + * FT_ORIENTATION_FILL_RIGHT :: + * This is identical to @FT_ORIENTATION_TRUETYPE, but is used to + * remember that in TrueType, everything that is to the right of + * the drawing direction of a contour must be filled. + * + * FT_ORIENTATION_FILL_LEFT :: + * This is identical to @FT_ORIENTATION_POSTSCRIPT, but is used to + * remember that in Postscript, everything that is to the left of + * the drawing direction of a contour must be filled. + * + * FT_ORIENTATION_NONE :: + * The orientation cannot be determined. That is, different parts of + * the glyph have different orientation. + * + *) +{$IFDEF TYPE_DECL} + FT_Orientation = cint; +{$ELSE TYPE_DECL} +const + FT_ORIENTATION_TRUETYPE = 0; + FT_ORIENTATION_POSTSCRIPT = 1; + FT_ORIENTATION_FILL_RIGHT = FT_ORIENTATION_TRUETYPE; + FT_ORIENTATION_FILL_LEFT = FT_ORIENTATION_POSTSCRIPT; + FT_ORIENTATION_NONE = FT_ORIENTATION_FILL_LEFT+1; + + (************************************************************************** + * + * @function: + * FT_Outline_Get_Orientation + * + * @description: + * This function analyzes a glyph outline and tries to compute its + * fill orientation (see @FT_Orientation). This is done by computing + * the direction of each global horizontal and/or vertical extrema + * within the outline. + * + * Note that this will return @FT_ORIENTATION_TRUETYPE for empty + * outlines. + * + * @input: + * outline :: + * A handle to the source outline. + * + * @return: + * The orientation. + * + *) + function FT_Outline_Get_Orientation( outline: PFT_Outline ): FT_Orientation; + cdecl; external ft_lib name 'FT_Outline_Get_Orientation'; + +{$ENDIF TYPE_DECL} + diff --git a/cmake/src/lib/freetype/ftstroke.inc b/cmake/src/lib/freetype/ftstroke.inc new file mode 100644 index 00000000..bf8a00ae --- /dev/null +++ b/cmake/src/lib/freetype/ftstroke.inc @@ -0,0 +1,711 @@ +{***************************************************************************} +{* *} +{* ftstroke.h *} +{* *} +{* FreeType path stroker (specification). *} +{* *} +{* Copyright 2002, 2003, 2004, 2005, 2006 by *} +{* David Turner, Robert Wilhelm, and Werner Lemberg. *} +{* *} +{* This file is part of the FreeType project, and may only be used, *} +{* modified, and distributed under the terms of the FreeType project *} +{* license, LICENSE.TXT. By continuing to use, modify, or distribute *} +{* this file you indicate that you have read the license and *} +{* understand and accept it fully. *} +{* *} +{***************************************************************************} +(***************************************************************************) +(* Pascal port by the UltraStar Deluxe Team *) +(***************************************************************************) + + {************************************************************************ + * + * @section: + * glyph_stroker + * + * @title: + * Glyph Stroker + * + * @abstract: + * Generating bordered and stroked glyphs. + * + * @description: + * This component generates stroked outlines of a given vectorial + * glyph. It also allows you to retrieve the `outside' and/or the + * `inside' borders of the stroke. + * + * This can be useful to generate `bordered' glyph, i.e., glyphs + * displayed with a coloured (and anti-aliased) border around their + * shape. + *} + +{$IFDEF TYPE_DECL} + + {************************************************************** + * + * @type: + * FT_Stroker + * + * @description: + * Opaque handler to a path stroker object. + *} + FT_Stroker = Pointer; + + + {************************************************************** + * + * @enum: + * FT_Stroker_LineJoin + * + * @description: + * These values determine how two joining lines are rendered + * in a stroker. + * + * @values: + * FT_STROKER_LINEJOIN_ROUND :: + * Used to render rounded line joins. Circular arcs are used + * to join two lines smoothly. + * + * FT_STROKER_LINEJOIN_BEVEL :: + * Used to render beveled line joins; i.e., the two joining lines + * are extended until they intersect. + * + * FT_STROKER_LINEJOIN_MITER :: + * Same as beveled rendering, except that an additional line + * break is added if the angle between the two joining lines + * is too closed (this is useful to avoid unpleasant spikes + * in beveled rendering). + *} + FT_Stroker_LineJoin = cint; +{$ELSE TYPE_DECL} +const + FT_STROKER_LINEJOIN_ROUND = 0; + FT_STROKER_LINEJOIN_BEVEL = 1; + FT_STROKER_LINEJOIN_MITER = 2; + +{$ENDIF TYPE_DECL} +{$IFDEF TYPE_DECL} + + {************************************************************** + * + * @enum: + * FT_Stroker_LineCap + * + * @description: + * These values determine how the end of opened sub-paths are + * rendered in a stroke. + * + * @values: + * FT_STROKER_LINECAP_BUTT :: + * The end of lines is rendered as a full stop on the last + * point itself. + * + * FT_STROKER_LINECAP_ROUND :: + * The end of lines is rendered as a half-circle around the + * last point. + * + * FT_STROKER_LINECAP_SQUARE :: + * The end of lines is rendered as a square around the + * last point. + *} + FT_Stroker_LineCap = cint; +{$ELSE TYPE_DECL} +const + FT_STROKER_LINECAP_BUTT = 0; + FT_STROKER_LINECAP_ROUND = 1; + FT_STROKER_LINECAP_SQUARE = 2; + +{$ENDIF TYPE_DECL} +{$IFDEF TYPE_DECL} + + {************************************************************** + * + * @enum: + * FT_StrokerBorder + * + * @description: + * These values are used to select a given stroke border + * in @FT_Stroker_GetBorderCounts and @FT_Stroker_ExportBorder. + * + * @values: + * FT_STROKER_BORDER_LEFT :: + * Select the left border, relative to the drawing direction. + * + * FT_STROKER_BORDER_RIGHT :: + * Select the right border, relative to the drawing direction. + * + * @note: + * Applications are generally interested in the `inside' and `outside' + * borders. However, there is no direct mapping between these and the + * `left' and `right' ones, since this really depends on the glyph's + * drawing orientation, which varies between font formats. + * + * You can however use @FT_Outline_GetInsideBorder and + * @FT_Outline_GetOutsideBorder to get these. + *} + FT_StrokerBorder = cint; +{$ELSE TYPE_DECL} +const + FT_STROKER_BORDER_LEFT = 0; + FT_STROKER_BORDER_RIGHT = 1; + + + {************************************************************** + * + * @function: + * FT_Outline_GetInsideBorder + * + * @description: + * Retrieve the @FT_StrokerBorder value corresponding to the + * `inside' borders of a given outline. + * + * @input: + * outline :: + * The source outline handle. + * + * @return: + * The border index. @FT_STROKER_BORDER_LEFT for empty or invalid + * outlines. + *} + function FT_Outline_GetInsideBorder( outline: PFT_Outline ): FT_StrokerBorder; + cdecl; external ft_lib name 'FT_Outline_GetInsideBorder'; + + + {************************************************************** + * + * @function: + * FT_Outline_GetOutsideBorder + * + * @description: + * Retrieve the @FT_StrokerBorder value corresponding to the + * `outside' borders of a given outline. + * + * @input: + * outline :: + * The source outline handle. + * + * @return: + * The border index. @FT_STROKER_BORDER_LEFT for empty or invalid + * outlines. + *} + function FT_Outline_GetOutsideBorder( outline: PFT_Outline ): FT_StrokerBorder; + cdecl; external ft_lib name 'FT_Outline_GetOutsideBorder'; + + + {************************************************************** + * + * @function: + * FT_Stroker_New + * + * @description: + * Create a new stroker object. + * + * @input: + * library :: + * FreeType library handle. + * + * @output: + * astroker :: + * A new stroker object handle. NULL in case of error. + * + * @return: + * FreeType error code. 0 means success. + *} + function FT_Stroker_New( + library_: FT_Library; + out astroker: FT_Stroker ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_New'; + + + {************************************************************** + * + * @function: + * FT_Stroker_Set + * + * @description: + * Reset a stroker object's attributes. + * + * @input: + * stroker :: + * The target stroker handle. + * + * radius :: + * The border radius. + * + * line_cap :: + * The line cap style. + * + * line_join :: + * The line join style. + * + * miter_limit :: + * The miter limit for the FT_STROKER_LINEJOIN_MITER style, + * expressed as 16.16 fixed point value. + * + * @note: + * The radius is expressed in the same units that the outline + * coordinates. + *} + procedure FT_Stroker_Set( + stroker: FT_Stroker; + radius: FT_Fixed; + line_cap: FT_Stroker_LineCap; + line_join: FT_Stroker_LineJoin; + miter_limit: FT_Fixed ); + cdecl; external ft_lib name 'FT_Stroker_Set'; + + + {************************************************************** + * + * @function: + * FT_Stroker_Rewind + * + * @description: + * Reset a stroker object without changing its attributes. + * You should call this function before beginning a new + * series of calls to @FT_Stroker_BeginSubPath or + * @FT_Stroker_EndSubPath. + * + * @input: + * stroker :: + * The target stroker handle. + *} + procedure FT_Stroker_Rewind( stroker: FT_Stroker ); + cdecl; external ft_lib name 'FT_Stroker_Rewind'; + + + {************************************************************** + * + * @function: + * FT_Stroker_ParseOutline + * + * @description: + * A convenience function used to parse a whole outline with + * the stroker. The resulting outline(s) can be retrieved + * later by functions like @FT_Stroker_GetCounts and @FT_Stroker_Export. + * + * @input: + * stroker :: + * The target stroker handle. + * + * outline :: + * The source outline. + * + * opened :: + * A boolean. If 1, the outline is treated as an open path instead + * of a closed one. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * If `opened' is 0 (the default), the outline is treated as a closed + * path, and the stroker will generate two distinct `border' outlines. + * + * If `opened' is 1, the outline is processed as an open path, and the + * stroker will generate a single `stroke' outline. + * + * This function calls @FT_Stroker_Rewind automatically. + *} + function FT_Stroker_ParseOutline( + stroker: FT_Stroker; + outline: PFT_Outline; + opened: FT_Bool): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_ParseOutline'; + + + {************************************************************** + * + * @function: + * FT_Stroker_BeginSubPath + * + * @description: + * Start a new sub-path in the stroker. + * + * @input: + * stroker :: + * The target stroker handle. + * + * to :: + * A pointer to the start vector. + * + * open :: + * A boolean. If 1, the sub-path is treated as an open one. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * This function is useful when you need to stroke a path that is + * not stored as an @FT_Outline object. + *} + function FT_Stroker_BeginSubPath( + stroker: FT_Stroker; + to_: PFT_Vector; + open: FT_Bool ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_BeginSubPath'; + + + {************************************************************** + * + * @function: + * FT_Stroker_EndSubPath + * + * @description: + * Close the current sub-path in the stroker. + * + * @input: + * stroker :: + * The target stroker handle. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * You should call this function after @FT_Stroker_BeginSubPath. + * If the subpath was not `opened', this function will `draw' a + * single line segment to the start position when needed. + *} + function FT_Stroker_EndSubPath( stroker: FT_Stroker ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_EndSubPath'; + + + {************************************************************** + * + * @function: + * FT_Stroker_LineTo + * + * @description: + * `Draw' a single line segment in the stroker's current sub-path, + * from the last position. + * + * @input: + * stroker :: + * The target stroker handle. + * + * to :: + * A pointer to the destination point. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * You should call this function between @FT_Stroker_BeginSubPath and + * @FT_Stroker_EndSubPath. + *} + function FT_Stroker_LineTo( + stroker: FT_Stroker; + to_: PFT_Vector ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_LineTo'; + + + {************************************************************** + * + * @function: + * FT_Stroker_ConicTo + * + * @description: + * `Draw' a single quadratic Bézier in the stroker's current sub-path, + * from the last position. + * + * @input: + * stroker :: + * The target stroker handle. + * + * control :: + * A pointer to a Bézier control point. + * + * to :: + * A pointer to the destination point. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * You should call this function between @FT_Stroker_BeginSubPath and + * @FT_Stroker_EndSubPath. + *} + function FT_Stroker_ConicTo( + stroker: FT_Stroker; + control: PFT_Vector; + to_: PFT_Vector ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_ConicTo'; + + + {************************************************************** + * + * @function: + * FT_Stroker_CubicTo + * + * @description: + * `Draw' a single cubic Bézier in the stroker's current sub-path, + * from the last position. + * + * @input: + * stroker :: + * The target stroker handle. + * + * control1 :: + * A pointer to the first Bézier control point. + * + * control2 :: + * A pointer to second Bézier control point. + * + * to :: + * A pointer to the destination point. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * You should call this function between @FT_Stroker_BeginSubPath and + * @FT_Stroker_EndSubPath. + *} + function FT_Stroker_CubicTo( + stroker: FT_Stroker; + control1: PFT_Vector; + control2: PFT_Vector; + to_: PFT_Vector ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_CubicTo'; + + + {************************************************************** + * + * @function: + * FT_Stroker_GetBorderCounts + * + * @description: + * Call this function once you have finished parsing your paths + * with the stroker. It will return the number of points and + * contours necessary to export one of the `border' or `stroke' + * outlines generated by the stroker. + * + * @input: + * stroker :: + * The target stroker handle. + * + * border :: + * The border index. + * + * @output: + * anum_points :: + * The number of points. + * + * anum_contours :: + * The number of contours. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * When an outline, or a sub-path, is `closed', the stroker generates + * two independent `border' outlines, named `left' and `right'. + * + * When the outline, or a sub-path, is `opened', the stroker merges + * the `border' outlines with caps. The `left' border receives all + * points, while the `right' border becomes empty. + * + * Use the function @FT_Stroker_GetCounts instead if you want to + * retrieve the counts associated to both borders. + *} + function FT_Stroker_GetBorderCounts( + stroker: FT_Stroker; + border: FT_StrokerBorder; + out anum_points: FT_UInt; + out anum_contours: FT_UInt ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_GetBorderCounts'; + + + {************************************************************** + * + * @function: + * FT_Stroker_ExportBorder + * + * @description: + * Call this function after @FT_Stroker_GetBorderCounts to + * export the corresponding border to your own @FT_Outline + * structure. + * + * Note that this function will append the border points and + * contours to your outline, but will not try to resize its + * arrays. + * + * @input: + * stroker :: + * The target stroker handle. + * + * border :: + * The border index. + * + * outline :: + * The target outline handle. + * + * @note: + * Always call this function after @FT_Stroker_GetBorderCounts to + * get sure that there is enough room in your @FT_Outline object to + * receive all new data. + * + * When an outline, or a sub-path, is `closed', the stroker generates + * two independent `border' outlines, named `left' and `right' + * + * When the outline, or a sub-path, is `opened', the stroker merges + * the `border' outlines with caps. The `left' border receives all + * points, while the `right' border becomes empty. + * + * Use the function @FT_Stroker_Export instead if you want to + * retrieve all borders at once. + *} + procedure FT_Stroker_ExportBorder( + stroker: FT_Stroker; + border: FT_StrokerBorder; + outline: PFT_Outline ); + cdecl; external ft_lib name 'FT_Stroker_ExportBorder'; + + + {************************************************************** + * + * @function: + * FT_Stroker_GetCounts + * + * @description: + * Call this function once you have finished parsing your paths + * with the stroker. It returns the number of points and + * contours necessary to export all points/borders from the stroked + * outline/path. + * + * @input: + * stroker :: + * The target stroker handle. + * + * @output: + * anum_points :: + * The number of points. + * + * anum_contours :: + * The number of contours. + * + * @return: + * FreeType error code. 0 means success. + *} + function FT_Stroker_GetCounts( + stroker: FT_Stroker; + out anum_points: FT_UInt; + out anum_contours: FT_UInt ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_GetCounts'; + + + {************************************************************** + * + * @function: + * FT_Stroker_Export + * + * @description: + * Call this function after @FT_Stroker_GetBorderCounts to + * export the all borders to your own @FT_Outline structure. + * + * Note that this function will append the border points and + * contours to your outline, but will not try to resize its + * arrays. + * + * @input: + * stroker :: + * The target stroker handle. + * + * outline :: + * The target outline handle. + *} + procedure FT_Stroker_Export( + stroker: FT_Stroker; + outline: PFT_Outline ); + cdecl; external ft_lib name 'FT_Stroker_Export'; + + + {************************************************************** + * + * @function: + * FT_Stroker_Done + * + * @description: + * Destroy a stroker object. + * + * @input: + * stroker :: + * A stroker handle. Can be NULL. + *} + procedure FT_Stroker_Done( stroker: FT_Stroker ); + cdecl; external ft_lib name 'FT_Stroker_Done'; + + + {************************************************************** + * + * @function: + * FT_Glyph_Stroke + * + * @description: + * Stroke a given outline glyph object with a given stroker. + * + * @inout: + * pglyph :: + * Source glyph handle on input, new glyph handle on output. + * + * @input: + * stroker :: + * A stroker handle. + * + * destroy :: + * A Boolean. If 1, the source glyph object is destroyed + * on success. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * The source glyph is untouched in case of error. + *} + function FT_Glyph_Stroke( + var glyph: FT_Glyph; + stroker: FT_Stroker; + destroy: FT_Bool ): FT_Error; + cdecl; external ft_lib name 'FT_Glyph_Stroke'; + + + {************************************************************** + * + * @function: + * FT_Glyph_StrokeBorder + * + * @description: + * Stroke a given outline glyph object with a given stroker, but + * only return either its inside or outside border. + * + * @inout: + * pglyph :: + * Source glyph handle on input, new glyph handle on output. + * + * @input: + * stroker :: + * A stroker handle. + * + * inside :: + * A Boolean. If 1, return the inside border, otherwise + * the outside border. + * + * destroy :: + * A Boolean. If 1, the source glyph object is destroyed + * on success. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * The source glyph is untouched in case of error. + *} + function FT_Glyph_StrokeBorder( + var glyph: FT_Glyph; + stroker: FT_Stroker; + inside: FT_Bool; + destroy: FT_Bool ): FT_Error; + cdecl; external ft_lib name 'FT_Glyph_StrokeBorder'; + +{$ENDIF TYPE_DECL} + diff --git a/cmake/src/lib/freetype/fttypes.inc b/cmake/src/lib/freetype/fttypes.inc new file mode 100644 index 00000000..a64432e6 --- /dev/null +++ b/cmake/src/lib/freetype/fttypes.inc @@ -0,0 +1,311 @@ +(***************************************************************************) +(* *) +(* fttypes.h *) +(* *) +(* FreeType simple types definitions (specification only). *) +(* *) +(* Copyright 1996-2001, 2002, 2004, 2006, 2007 by *) +(* David Turner, Robert Wilhelm, and Werner Lemberg. *) +(* *) +(* This file is part of the FreeType project, and may only be used, *) +(* modified, and distributed under the terms of the FreeType project *) +(* license, LICENSE.TXT. By continuing to use, modify, or distribute *) +(* this file you indicate that you have read the license and *) +(* understand and accept it fully. *) +(* *) +(***************************************************************************) +(***************************************************************************) +(* Pascal port by the UltraStar Deluxe Team *) +(***************************************************************************) + + (*************************************************************************) + (* *) + (* <Section> *) + (* basic_types *) + (* *) + (* <Title> *) + (* Basic Data Types *) + (* *) + (* <Abstract> *) + (* The basic data types defined by the library. *) + (* *) + (* <Description> *) + (* This section contains the basic data types defined by FreeType 2, *) + (* ranging from simple scalar types to bitmap descriptors. More *) + (* font-specific structures are defined in a different section. *) + (* *) + (* <Order> *) + (* FT_Byte *) + (* FT_Bytes *) + (* FT_Char *) + (* FT_Int *) + (* FT_UInt *) + (* FT_Short *) + (* FT_UShort *) + (* FT_Long *) + (* FT_ULong *) + (* FT_Bool *) + (* FT_Offset *) + (* FT_PtrDist *) + (* FT_String *) + (* FT_Tag *) + (* FT_Error *) + (* FT_Fixed *) + (* FT_Pointer *) + (* FT_Pos *) + (* FT_Vector *) + (* FT_BBox *) + (* FT_Matrix *) + (* FT_FWord *) + (* FT_UFWord *) + (* FT_F2Dot14 *) + (* FT_UnitVector *) + (* FT_F26Dot6 *) + (* *) + (* *) + (* FT_Generic *) + (* FT_Generic_Finalizer *) + (* *) + (* FT_Bitmap *) + (* FT_Pixel_Mode *) + (* FT_Palette_Mode *) + (* FT_Glyph_Format *) + (* FT_IMAGE_TAG *) + (* *) + (*************************************************************************) + +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Bool *) + (* *) + (* <Description> *) + (* A typedef of unsigned char, used for simple booleans. As usual, *) + (* values 1 and 0 represent true and false, respectively. *) + (* *) + FT_Bool = cuchar; +{$ENDIF TYPE_DECL} +{$IFNDEF TYPE_DECL} +const + FT_FALSE = 0; + FT_TRUE = 1; +{$ENDIF !TYPE_DECL} +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Byte *) + (* *) + (* <Description> *) + (* A simple typedef for the _unsigned_ char type. *) + (* *) + FT_Byte = cuchar; + PFT_Byte = ^FT_Byte; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_String *) + (* *) + (* <Description> *) + (* A simple typedef for the char type, usually used for strings. *) + (* *) + FT_String = cchar; + PFT_String = ^FT_String; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Short *) + (* *) + (* <Description> *) + (* A typedef for signed short. *) + (* *) + FT_Short = csshort; + PFT_Short = ^FT_Short; + + PFT_ShortArray = ^FT_ShortArray; + FT_ShortArray = array[0 .. (MaxInt div SizeOf(FT_Short))-1] of FT_Short; + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_UShort *) + (* *) + (* <Description> *) + (* A typedef for unsigned short. *) + (* *) + FT_UShort = cushort; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Int *) + (* *) + (* <Description> *) + (* A typedef for the int type. *) + (* *) + FT_Int = csint; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_UInt *) + (* *) + (* <Description> *) + (* A typedef for the unsigned int type. *) + (* *) + FT_UInt = cuint; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Long *) + (* *) + (* <Description> *) + (* A typedef for signed long. *) + (* *) + FT_Long = cslong; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_ULong *) + (* *) + (* <Description> *) + (* A typedef for unsigned long. *) + (* *) + FT_ULong = culong; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_F26Dot6 *) + (* *) + (* <Description> *) + (* A signed 26.6 fixed float type used for vectorial pixel *) + (* coordinates. *) + (* *) + FT_F26Dot6 = cslong; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Fixed *) + (* *) + (* <Description> *) + (* This type is used to store 16.16 fixed float values, like scaling *) + (* values or matrix coefficients. *) + (* *) + FT_Fixed = cslong; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Error *) + (* *) + (* <Description> *) + (* The FreeType error code type. A value of 0 is always interpreted *) + (* as a successful operation. *) + (* *) + FT_Error = cint; + + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Matrix *) + (* *) + (* <Description> *) + (* A simple structure used to store a 2x2 matrix. Coefficients are *) + (* in 16.16 fixed float format. The computation performed is: *) + (* *) + (* { *) + (* x' = x*xx + y*xy *) + (* y' = x*yx + y*yy *) + (* } *) + (* *) + (* <Fields> *) + (* xx :: Matrix coefficient. *) + (* *) + (* xy :: Matrix coefficient. *) + (* *) + (* yx :: Matrix coefficient. *) + (* *) + (* yy :: Matrix coefficient. *) + (* *) + PFT_Matrix = ^FT_Matrix; + FT_Matrix = record + xx, xy: FT_Fixed; + yx, yy: FT_Fixed; + end; + + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_Generic_Finalizer *) + (* *) + (* <Description> *) + (* Describes a function used to destroy the `client' data of any *) + (* FreeType object. See the description of the FT_Generic type for *) + (* details of usage. *) + (* *) + (* <Input> *) + (* The address of the FreeType object which is under finalization. *) + (* Its client data is accessed through its `generic' field. *) + (* *) + FT_Generic_Finalizer = procedure(AnObject : pointer ); cdecl; + + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Generic *) + (* *) + (* <Description> *) + (* Client applications often need to associate their own data to a *) + (* variety of FreeType core objects. For example, a text layout API *) + (* might want to associate a glyph cache to a given size object. *) + (* *) + (* Most FreeType object contains a `generic' field, of type *) + (* FT_Generic, which usage is left to client applications and font *) + (* servers. *) + (* *) + (* It can be used to store a pointer to client-specific data, as well *) + (* as the address of a `finalizer' function, which will be called by *) + (* FreeType when the object is destroyed (for example, the previous *) + (* client example would put the address of the glyph cache destructor *) + (* in the `finalizer' field). *) + (* *) + (* <Fields> *) + (* data :: A typeless pointer to any client-specified data. This *) + (* field is completely ignored by the FreeType library. *) + (* *) + (* finalizer :: A pointer to a `generic finalizer' function, which *) + (* will be called when the object is destroyed. If this *) + (* field is set to NULL, no code will be called. *) + (* *) + FT_Generic = record + data: pointer; + finalizer: FT_Generic_Finalizer; + end; + + + TByteArray = array [0 .. (MaxInt div SizeOf(byte))-1] of byte; + PByteArray = ^TByteArray; + +{$ENDIF TYPE_DECL} + diff --git a/cmake/src/lib/lib-info.txt b/cmake/src/lib/lib-info.txt index 59502c7a..0a184568 100644 --- a/cmake/src/lib/lib-info.txt +++ b/cmake/src/lib/lib-info.txt @@ -1,60 +1,60 @@ -bass:
-http://www.un4seen.com/ (2.4.2.1)
-- FPC Mac OS X compatibility fixes
-
-fft:
-translation of audacity's FFT.cpp by hennymcc (maybe replace this with FFTW?)
-
-ffmpeg:
-- http://www.iversenit.dk/dev/ffmpeg-headers/: 2006-10
-- several bugs were fixed
-- many IFDEFS were added to the header to support multiple versions of ffmpeg (starting with end of 2006) and not only one specific version. This is necessary as we cannot control which version is used on linux. We could ship the ffmpeg lib with USDX and link statically but a stripped down ffmpeg is 15MB in size and takes 5 minutes to compile (so static linkage is not a good option).
-- the headers were updated to reflect the changes in the ffmpeg C-headers (http://svn.mplayerhq.hu/ffmpeg/trunk/ and http://svn.mplayerhq.hu/mplayer/trunk/libswscale/)
-
-freeimage:
-- inserted by eddie. Some compatibility fixes for platforms different than mac os x.
-- not used anymore
-
-freetype:
-- based on the AggPas (http://aggpas.org/) headers
-- just a minimal header that contains only some of the freetype functions and types. Some functions and structures/constants/types needed for USDX were added.
-- some comments added
-
-jedi-sdl:
-JEDI-SDL v1.0 Final RC 2 (http://jedi-sdl.pascalgamedevelopment.com/)
-- 64bit compatibility patch (http://sourceforge.net/tracker/index.php?func=detail&aid=1902924&group_id=43805&atid=437446)
-- some Mac OS X patches from freepascal trunk
-- some additional patched (see *.patch)
-
-midi:
-taken from http://www.torry.net/authorsmore.php?id=1615 (TMidiPlayer)
-- FPC (Win32) compatibility fixes
-- Win32 only. Maybe use some timidity stuff under linux.
-
-libpng:
-autocreated H2Pas file taken from freepascal trunk
-- bug fixes (especially H2Pas related stuff like wrong file types)
-- delphi compatibility
-- comments added
-
-portaudio:
-translation of the (patched) audacity C headers by hennymcc.
-See http://audacity.cvs.sourceforge.net/viewvc/audacity/lib-src/portaudio-v19/include/?sortdir=down
-
-portmixer:
-translation of the (patched) audacity C headers by hennymcc.
-- Unlike portaudio portmixer is part of audacity and there is no linux package for it. If we want to use it for linux, we have to link it statically. Unfortunately it requires a patched version of portaudio (which is part of audacity and statically linked to) so we have to statically link portaudio too :(.
-
-projectM:
-translation of the original C++ headers and C-wrapper by hennymcc
-
-samplerate:
-translation of the original C headers by profoX/hennymcc
-
-sqlite:
-taken from http://www.itwriting.com/blog/a-simple-delphi-wrapper-for-sqlite-3
-- slightly patched: see *.patch files for what has been patched (e.g. Binding)
-
-zlib:
-taken from freepascal (slightly patched)
+bass: +http://www.un4seen.com/ (2.4.2.1) +- FPC Mac OS X compatibility fixes + +fft: +translation of audacity's FFT.cpp by hennymcc (maybe replace this with FFTW?) + +ffmpeg: +- http://www.iversenit.dk/dev/ffmpeg-headers/: 2006-10 +- several bugs were fixed +- many IFDEFS were added to the header to support multiple versions of ffmpeg (starting with end of 2006) and not only one specific version. This is necessary as we cannot control which version is used on linux. We could ship the ffmpeg lib with USDX and link statically but a stripped down ffmpeg is 15MB in size and takes 5 minutes to compile (so static linkage is not a good option). +- the headers were updated to reflect the changes in the ffmpeg C-headers (http://svn.mplayerhq.hu/ffmpeg/trunk/ and http://svn.mplayerhq.hu/mplayer/trunk/libswscale/) + +freeimage: +- inserted by eddie. Some compatibility fixes for platforms different than mac os x. +- not used anymore + +freetype: +- based on the AggPas (http://aggpas.org/) headers +- just a minimal header that contains only some of the freetype functions and types. Some functions and structures/constants/types needed for USDX were added. +- some comments added + +jedi-sdl: +JEDI-SDL v1.0 Final RC 2 (http://jedi-sdl.pascalgamedevelopment.com/) +- 64bit compatibility patch (http://sourceforge.net/tracker/index.php?func=detail&aid=1902924&group_id=43805&atid=437446) +- some Mac OS X patches from freepascal trunk +- some additional patched (see *.patch) + +midi: +taken from http://www.torry.net/authorsmore.php?id=1615 (TMidiPlayer) +- FPC (Win32) compatibility fixes +- Win32 only. Maybe use some timidity stuff under linux. + +libpng: +autocreated H2Pas file taken from freepascal trunk +- bug fixes (especially H2Pas related stuff like wrong file types) +- delphi compatibility +- comments added + +portaudio: +translation of the (patched) audacity C headers by hennymcc. +See http://audacity.cvs.sourceforge.net/viewvc/audacity/lib-src/portaudio-v19/include/?sortdir=down + +portmixer: +translation of the (patched) audacity C headers by hennymcc. +- Unlike portaudio portmixer is part of audacity and there is no linux package for it. If we want to use it for linux, we have to link it statically. Unfortunately it requires a patched version of portaudio (which is part of audacity and statically linked to) so we have to statically link portaudio too :(. + +projectM: +translation of the original C++ headers and C-wrapper by hennymcc + +samplerate: +translation of the original C headers by profoX/hennymcc + +sqlite: +taken from http://www.itwriting.com/blog/a-simple-delphi-wrapper-for-sqlite-3 +- slightly patched: see *.patch files for what has been patched (e.g. Binding) + +zlib: +taken from freepascal (slightly patched) - delphi compatibility
\ No newline at end of file diff --git a/cmake/src/lib/midi/CIRCBUF.PAS b/cmake/src/lib/midi/CIRCBUF.PAS index 77cb3643..3ceb4c6e 100644 --- a/cmake/src/lib/midi/CIRCBUF.PAS +++ b/cmake/src/lib/midi/CIRCBUF.PAS @@ -23,7 +23,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} Uses diff --git a/cmake/src/lib/midi/DELPHMCB.PAS b/cmake/src/lib/midi/DELPHMCB.PAS index e607627d..ef0d5451 100644 --- a/cmake/src/lib/midi/DELPHMCB.PAS +++ b/cmake/src/lib/midi/DELPHMCB.PAS @@ -13,7 +13,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses diff --git a/cmake/src/lib/midi/MIDIDEFS.PAS b/cmake/src/lib/midi/MIDIDEFS.PAS index fc8eed26..4afe56ef 100644 --- a/cmake/src/lib/midi/MIDIDEFS.PAS +++ b/cmake/src/lib/midi/MIDIDEFS.PAS @@ -13,7 +13,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses diff --git a/cmake/src/lib/midi/MIDITYPE.PAS b/cmake/src/lib/midi/MIDITYPE.PAS index b1ec1bdd..45b50820 100644 --- a/cmake/src/lib/midi/MIDITYPE.PAS +++ b/cmake/src/lib/midi/MIDITYPE.PAS @@ -10,7 +10,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses diff --git a/cmake/src/lib/midi/MidiFile.pas b/cmake/src/lib/midi/MidiFile.pas index 11b1ca0b..acf44c04 100644 --- a/cmake/src/lib/midi/MidiFile.pas +++ b/cmake/src/lib/midi/MidiFile.pas @@ -92,18 +92,18 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses Windows, - //Forms, Messages, Classes, {$IFDEF FPC} WinAllocation, {$ENDIF} - SysUtils; + SysUtils, + UPath; type TChunkType = (illegal, header, track); @@ -162,7 +162,7 @@ type procedure WndProc(var Msg : TMessage); protected { Protected declarations } - midiFile: file of byte; + midiFile: TBinaryFileStream; chunkType: TChunkType; chunkLength: integer; chunkData: PByte; @@ -177,7 +177,7 @@ type FBpm: integer; FBeatsPerMeasure: integer; FusPerTick: double; - FFilename: string; + FFilename: IPath; Tracks: TList; currentTrack: TMidiTrack; @@ -191,7 +191,7 @@ type currentPos: Double; // Current Position in ticks procedure OnTrackReady; - procedure setFilename(val: string); + procedure SetFilename(val: IPath); procedure ReadChunkHeader; procedure ReadChunkContent; procedure ReadChunk; @@ -221,7 +221,7 @@ type function Ready: boolean; published { Published declarations } - property Filename: string read FFilename write setFilename; + property Filename: IPath read FFilename write SetFilename; property NumberOfTracks: integer read numberTracks; property TicksPerQuarter: integer read deltaTicks; property FileFormat: TFileFormat read FFileFormat; @@ -463,7 +463,7 @@ begin result := Tracks.Items[index]; end; -procedure TMidifile.setFilename(val: string); +procedure TMidifile.SetFilename(val: IPath); begin FFilename := val; // ReadFile; @@ -586,7 +586,7 @@ procedure TMidifile.ReadChunkHeader; var theByte: array[0..7] of byte; begin - BlockRead(midiFile, theByte, 8); + midiFile.Read(theByte[0], 8); if (theByte[0] = $4D) and (theByte[1] = $54) then begin if (theByte[2] = $68) and (theByte[3] = $64) then @@ -608,7 +608,7 @@ begin if not (chunkData = nil) then FreeMem(chunkData); GetMem(chunkData, chunkLength + 10); - BlockRead(midiFile, chunkData^, chunkLength); + midiFile.Read(chunkData^, chunkLength); chunkIndex := chunkData; chunkEnd := PByte(integer(chunkIndex) + integer(chunkLength) - 1); end; @@ -848,12 +848,10 @@ begin Tracks.Clear; chunkType := illegal; - AssignFile(midiFile, FFilename); - FileMode := 0; - Reset(midiFile); - while not eof(midiFile) do + midiFile := TBinaryFileStream.Create(FFilename, fmOpenRead); + while (midiFile.Position < midiFile.Size) do ReadChunk; - CloseFile(midiFile); + FreeAndNil(midiFile); numberTracks := Tracks.Count; end; diff --git a/cmake/src/lib/midi/MidiScope.pas b/cmake/src/lib/midi/MidiScope.pas index 42fc65fc..afc20b0f 100644 --- a/cmake/src/lib/midi/MidiScope.pas +++ b/cmake/src/lib/midi/MidiScope.pas @@ -20,7 +20,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses diff --git a/cmake/src/lib/midi/Midicons.pas b/cmake/src/lib/midi/Midicons.pas index 35dbb5f3..72259beb 100644 --- a/cmake/src/lib/midi/Midicons.pas +++ b/cmake/src/lib/midi/Midicons.pas @@ -11,7 +11,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses Messages; diff --git a/cmake/src/lib/midi/Midiin.pas b/cmake/src/lib/midi/Midiin.pas index 21db0298..a055669a 100644 --- a/cmake/src/lib/midi/Midiin.pas +++ b/cmake/src/lib/midi/Midiin.pas @@ -103,7 +103,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses @@ -237,20 +237,13 @@ uses Controls, There are special requirements and restrictions for this callback procedure (see midiInOpen in MMSYSTEM.HLP) so it's impractical to make it an object method } -{$IFDEF WIN32} +{$IFDEF MSWINDOWS} function midiHandler( hMidiIn: HMidiIn; wMsg: UINT; dwInstance: DWORD; dwParam1: DWORD; dwParam2: DWORD): Boolean; stdcall; external 'DELMID32.DLL'; -{$ELSE} -procedure midiHandler( - hMidiIn: HMidiIn; - wMsg: Word; - dwInstance: DWORD; - dwParam1: DWORD; - dwParam2: DWORD); far; external 'DELPHMID'; {$ENDIF} *) {-------------------------------------------------------------------} diff --git a/cmake/src/lib/midi/Midiout.pas b/cmake/src/lib/midi/Midiout.pas index 606d0dae..7ce385eb 100644 --- a/cmake/src/lib/midi/Midiout.pas +++ b/cmake/src/lib/midi/Midiout.pas @@ -98,7 +98,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses @@ -234,20 +234,13 @@ implementation There are special requirements and restrictions for this callback procedure (see midioutOpen in MMSYSTEM.HLP) so it's impractical to make it an object method } -{$IFDEF WIN32} +{$IFDEF MSWINDOWS} function midiHandler( hMidiIn: HMidiIn; wMsg: UINT; dwInstance: DWORD; dwParam1: DWORD; dwParam2: DWORD): Boolean; stdcall; external 'DELMID32.DLL'; -{$ELSE} -function midiHandler( - hMidiIn: HMidiIn; - wMsg: Word; - dwInstance: DWORD; - dwParam1: DWORD; - dwParam2: DWORD): Boolean; far; external 'DELPHMID.DLL'; {$ENDIF} *) diff --git a/cmake/src/lib/other/DirWatch.pas b/cmake/src/lib/other/DirWatch.pas index 9d395840..1e00ec5d 100644 --- a/cmake/src/lib/other/DirWatch.pas +++ b/cmake/src/lib/other/DirWatch.pas @@ -25,7 +25,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses diff --git a/cmake/src/lib/pcre/pcre.pas b/cmake/src/lib/pcre/pcre.pas new file mode 100644 index 00000000..50e3371a --- /dev/null +++ b/cmake/src/lib/pcre/pcre.pas @@ -0,0 +1,852 @@ +{**************************************************************************************************} +{ } +{ Project JEDI Code Library (JCL) } +{ } +{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); } +{ you may not use this file except in compliance with the License. You may obtain a copy of the } +{ License at http://www.mozilla.org/MPL/ } +{ } +{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF } +{ ANY KIND, either express or implied. See the License for the specific language governing rights } +{ and limitations under the License. } +{ } +{ The Original Code is JclPRCE.pas. } +{ } +{ The Initial Developer of the Original Code is Peter Thornqvist. } +{ Portions created by Peter Thornqvist are Copyright (C) of Peter Thornqvist. All rights reserved. } +{ Portions created by University of Cambridge are } +{ Copyright (C) 1997-2001 by University of Cambridge. } +{ } +{ Contributor(s): } +{ Robert Rossmair (rrossmair) } +{ Mario R. Carro } +{ Florent Ouchet (outchy) } +{ } +{ The latest release of PCRE is always available from } +{ ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre/pcre-xxx.tar.gz } +{ } +{**************************************************************************************************} +{ } +{ Header conversion of pcre.h } +{ } +{ } +{**************************************************************************************************} +{ } +{ Last modified: $Date:: $ } +{ Revision: $Rev:: $ } +{ Author: $Author:: $ } +{ } +{**************************************************************************************************} + +unit pcre; + +interface + +(************************************************* +* Perl-Compatible Regular Expressions * +*************************************************) + +{$IFDEF FPC} + {$MODE DELPHI} + {$PACKENUM 4} (* use 4-byte enums *) + {$PACKRECORDS C} (* C/C++-compatible record packing *) +{$ELSE} + {$MINENUMSIZE 4} (* use 4-byte enums *) +{$ENDIF} + +{$WEAKPACKAGEUNIT ON} + +(*$HPPEMIT '#include "pcre.h"'*) + +const + MAX_PATTERN_LENGTH = $10003; + {$EXTERNALSYM MAX_PATTERN_LENGTH} + MAX_QUANTIFY_REPEAT = $10000; + {$EXTERNALSYM MAX_QUANTIFY_REPEAT} + MAX_CAPTURE_COUNT = $FFFF; + {$EXTERNALSYM MAX_CAPTURE_COUNT} + MAX_NESTING_DEPTH = 200; + {$EXTERNALSYM MAX_NESTING_DEPTH} + +const + (* Options *) + PCRE_CASELESS = $00000001; + {$EXTERNALSYM PCRE_CASELESS} + PCRE_MULTILINE = $00000002; + {$EXTERNALSYM PCRE_MULTILINE} + PCRE_DOTALL = $00000004; + {$EXTERNALSYM PCRE_DOTALL} + PCRE_EXTENDED = $00000008; + {$EXTERNALSYM PCRE_EXTENDED} + PCRE_ANCHORED = $00000010; + {$EXTERNALSYM PCRE_ANCHORED} + PCRE_DOLLAR_ENDONLY = $00000020; + {$EXTERNALSYM PCRE_DOLLAR_ENDONLY} + PCRE_EXTRA = $00000040; + {$EXTERNALSYM PCRE_EXTRA} + PCRE_NOTBOL = $00000080; + {$EXTERNALSYM PCRE_NOTBOL} + PCRE_NOTEOL = $00000100; + {$EXTERNALSYM PCRE_NOTEOL} + PCRE_UNGREEDY = $00000200; + {$EXTERNALSYM PCRE_UNGREEDY} + PCRE_NOTEMPTY = $00000400; + {$EXTERNALSYM PCRE_NOTEMPTY} + PCRE_UTF8 = $00000800; + {$EXTERNALSYM PCRE_UTF8} + PCRE_NO_AUTO_CAPTURE = $00001000; + {$EXTERNALSYM PCRE_NO_AUTO_CAPTURE} + PCRE_NO_UTF8_CHECK = $00002000; + {$EXTERNALSYM PCRE_NO_UTF8_CHECK} + PCRE_AUTO_CALLOUT = $00004000; + {$EXTERNALSYM PCRE_AUTO_CALLOUT} + PCRE_PARTIAL_SOFT = $00008000; + {$EXTERNALSYM PCRE_PARTIAL_SOFT} + PCRE_PARTIAL = PCRE_PARTIAL_SOFT; // Backwards compatible synonym + {$EXTERNALSYM PCRE_PARTIAL} + PCRE_DFA_SHORTEST = $00010000; + {$EXTERNALSYM PCRE_DFA_SHORTEST} + PCRE_DFA_RESTART = $00020000; + {$EXTERNALSYM PCRE_DFA_RESTART} + PCRE_FIRSTLINE = $00040000; + {$EXTERNALSYM PCRE_FIRSTLINE} + PCRE_DUPNAMES = $00080000; + {$EXTERNALSYM PCRE_DUPNAMES} + PCRE_NEWLINE_CR = $00100000; + {$EXTERNALSYM PCRE_NEWLINE_CR} + PCRE_NEWLINE_LF = $00200000; + {$EXTERNALSYM PCRE_NEWLINE_LF} + PCRE_NEWLINE_CRLF = $00300000; + {$EXTERNALSYM PCRE_NEWLINE_CRLF} + PCRE_NEWLINE_ANY = $00400000; + {$EXTERNALSYM PCRE_NEWLINE_ANY} + PCRE_NEWLINE_ANYCRLF = $00500000; + {$EXTERNALSYM PCRE_NEWLINE_ANYCRLF} + PCRE_BSR_ANYCRLF = $00800000; + {$EXTERNALSYM PCRE_BSR_ANYCRLF} + PCRE_BSR_UNICODE = $01000000; + {$EXTERNALSYM PCRE_BSR_UNICODE} + PCRE_JAVASCRIPT_COMPAT = $02000000; + {$EXTERNALSYM PCRE_JAVASCRIPT_COMPAT} + PCRE_NO_START_OPTIMIZE = $04000000; + {$EXTERNALSYM PCRE_NO_START_OPTIMIZE} + PCRE_NO_START_OPTIMISE = $04000000; + {$EXTERNALSYM PCRE_NO_START_OPTIMISE} + PCRE_PARTIAL_HARD = $08000000; + {$EXTERNALSYM PCRE_PARTIAL_HARD} + PCRE_NOTEMPTY_ATSTART = $10000000; + {$EXTERNALSYM PCRE_NOTEMPTY_ATSTART} + + (* Exec-time and get-time error codes *) + + PCRE_ERROR_NOMATCH = -1; + {$EXTERNALSYM PCRE_ERROR_NOMATCH} + PCRE_ERROR_NULL = -2; + {$EXTERNALSYM PCRE_ERROR_NULL} + PCRE_ERROR_BADOPTION = -3; + {$EXTERNALSYM PCRE_ERROR_BADOPTION} + PCRE_ERROR_BADMAGIC = -4; + {$EXTERNALSYM PCRE_ERROR_BADMAGIC} + PCRE_ERROR_UNKNOWN_NODE = -5; + {$EXTERNALSYM PCRE_ERROR_UNKNOWN_NODE} + PCRE_ERROR_NOMEMORY = -6; + {$EXTERNALSYM PCRE_ERROR_NOMEMORY} + PCRE_ERROR_NOSUBSTRING = -7; + {$EXTERNALSYM PCRE_ERROR_NOSUBSTRING} + PCRE_ERROR_MATCHLIMIT = -8; + {$EXTERNALSYM PCRE_ERROR_MATCHLIMIT} + PCRE_ERROR_CALLOUT = -9; (* Never used by PCRE itself *) + {$EXTERNALSYM PCRE_ERROR_CALLOUT} + PCRE_ERROR_BADUTF8 = -10; + {$EXTERNALSYM PCRE_ERROR_BADUTF8} + PCRE_ERROR_BADUTF8_OFFSET = -11; + {$EXTERNALSYM PCRE_ERROR_BADUTF8_OFFSET} + PCRE_ERROR_PARTIAL = -12; + {$EXTERNALSYM PCRE_ERROR_PARTIAL} + PCRE_ERROR_BADPARTIAL = -13; + {$EXTERNALSYM PCRE_ERROR_BADPARTIAL} + PCRE_ERROR_INTERNAL = -14; + {$EXTERNALSYM PCRE_ERROR_INTERNAL} + PCRE_ERROR_BADCOUNT = -15; + {$EXTERNALSYM PCRE_ERROR_BADCOUNT} + PCRE_ERROR_DFA_UITEM = -16; + {$EXTERNALSYM PCRE_ERROR_DFA_UITEM} + PCRE_ERROR_DFA_UCOND = -17; + {$EXTERNALSYM PCRE_ERROR_DFA_UCOND} + PCRE_ERROR_DFA_UMLIMIT = -18; + {$EXTERNALSYM PCRE_ERROR_DFA_UMLIMIT} + PCRE_ERROR_DFA_WSSIZE = -19; + {$EXTERNALSYM PCRE_ERROR_DFA_WSSIZE} + PCRE_ERROR_DFA_RECURSE = -20; + {$EXTERNALSYM PCRE_ERROR_DFA_RECURSE} + PCRE_ERROR_RECURSIONLIMIT = -21; + {$EXTERNALSYM PCRE_ERROR_RECURSIONLIMIT} + PCRE_ERROR_NULLWSLIMIT = -22; (* No longer actually used *) + {$EXTERNALSYM PCRE_ERROR_NULLWSLIMIT} + PCRE_ERROR_BADNEWLINE = -23; + {$EXTERNALSYM PCRE_ERROR_BADNEWLINE} + + (* Request types for pcre_fullinfo() *) + + PCRE_INFO_OPTIONS = 0; + {$EXTERNALSYM PCRE_INFO_OPTIONS} + PCRE_INFO_SIZE = 1; + {$EXTERNALSYM PCRE_INFO_SIZE} + PCRE_INFO_CAPTURECOUNT = 2; + {$EXTERNALSYM PCRE_INFO_CAPTURECOUNT} + PCRE_INFO_BACKREFMAX = 3; + {$EXTERNALSYM PCRE_INFO_BACKREFMAX} + PCRE_INFO_FIRSTCHAR = 4; + {$EXTERNALSYM PCRE_INFO_FIRSTCHAR} + PCRE_INFO_FIRSTTABLE = 5; + {$EXTERNALSYM PCRE_INFO_FIRSTTABLE} + PCRE_INFO_LASTLITERAL = 6; + {$EXTERNALSYM PCRE_INFO_LASTLITERAL} + PCRE_INFO_NAMEENTRYSIZE = 7; + {$EXTERNALSYM PCRE_INFO_NAMEENTRYSIZE} + PCRE_INFO_NAMECOUNT = 8; + {$EXTERNALSYM PCRE_INFO_NAMECOUNT} + PCRE_INFO_NAMETABLE = 9; + {$EXTERNALSYM PCRE_INFO_NAMETABLE} + PCRE_INFO_STUDYSIZE = 10; + {$EXTERNALSYM PCRE_INFO_STUDYSIZE} + PCRE_INFO_DEFAULT_TABLES = 11; + {$EXTERNALSYM PCRE_INFO_DEFAULT_TABLES} + PCRE_INFO_OKPARTIAL = 12; + {$EXTERNALSYM PCRE_INFO_OKPARTIAL} + PCRE_INFO_JCHANGED = 13; + {$EXTERNALSYM PCRE_INFO_JCHANGED} + PCRE_INFO_HASCRORLF = 14; + {$EXTERNALSYM PCRE_INFO_HASCRORLF} + PCRE_INFO_MINLENGTH = 15; + {$EXTERNALSYM PCRE_INFO_MINLENGTH} + + (* Request types for pcre_config() *) + PCRE_CONFIG_UTF8 = 0; + {$EXTERNALSYM PCRE_CONFIG_UTF8} + PCRE_CONFIG_NEWLINE = 1; + {$EXTERNALSYM PCRE_CONFIG_NEWLINE} + PCRE_CONFIG_LINK_SIZE = 2; + {$EXTERNALSYM PCRE_CONFIG_LINK_SIZE} + PCRE_CONFIG_POSIX_MALLOC_THRESHOLD = 3; + {$EXTERNALSYM PCRE_CONFIG_POSIX_MALLOC_THRESHOLD} + PCRE_CONFIG_MATCH_LIMIT = 4; + {$EXTERNALSYM PCRE_CONFIG_MATCH_LIMIT} + PCRE_CONFIG_STACKRECURSE = 5; + {$EXTERNALSYM PCRE_CONFIG_STACKRECURSE} + PCRE_CONFIG_UNICODE_PROPERTIES = 6; + {$EXTERNALSYM PCRE_CONFIG_UNICODE_PROPERTIES} + PCRE_CONFIG_MATCH_LIMIT_RECURSION = 7; + {$EXTERNALSYM PCRE_CONFIG_MATCH_LIMIT_RECURSION} + PCRE_CONFIG_BSR = 8; + {$EXTERNALSYM PCRE_CONFIG_BSR} + + (* Bit flags for the pcre_extra structure *) + + PCRE_EXTRA_STUDY_DATA = $0001; + {$EXTERNALSYM PCRE_EXTRA_STUDY_DATA} + PCRE_EXTRA_MATCH_LIMIT = $0002; + {$EXTERNALSYM PCRE_EXTRA_MATCH_LIMIT} + PCRE_EXTRA_CALLOUT_DATA = $0004; + {$EXTERNALSYM PCRE_EXTRA_CALLOUT_DATA} + PCRE_EXTRA_TABLES = $0008; + {$EXTERNALSYM PCRE_EXTRA_TABLES} + PCRE_EXTRA_MATCH_LIMIT_RECURSION = $0010; + {$EXTERNALSYM PCRE_EXTRA_MATCH_LIMIT_RECURSION} + +type + {$IFNDEF FPC} + {$IFDEF CPU64} + SizeInt = Int64; + {$ELSE ~CPU64} + SizeInt = Integer; + {$ENDIF ~CPU64} + PPAnsiChar = ^PAnsiChar; + {$ENDIF ~FPC} + PPPAnsiChar = ^PPAnsiChar; + + real_pcre = packed record + {magic_number: Longword; + size: Integer; + tables: PAnsiChar; + options: Longword; + top_bracket: Word; + top_backref: word; + first_char: PAnsiChar; + req_char: PAnsiChar; + code: array [0..0] of AnsiChar;} + end; + TPCRE = real_pcre; + PPCRE = ^TPCRE; + + real_pcre_extra = packed record + {options: PAnsiChar; + start_bits: array [0..31] of AnsiChar;} + flags: Cardinal; (* Bits for which fields are set *) + study_data: Pointer; (* Opaque data from pcre_study() *) + match_limit: Cardinal; (* Maximum number of calls to match() *) + callout_data: Pointer; (* Data passed back in callouts *) + tables: PAnsiChar; (* Pointer to character tables *) + match_limit_recursion: Cardinal; (* Max recursive calls to match() *) + end; + TPCREExtra = real_pcre_extra; + PPCREExtra = ^TPCREExtra; + + pcre_callout_block = packed record + version: Integer; (* Identifies version of block *) + (* ------------------------ Version 0 ------------------------------- *) + callout_number: Integer; (* Number compiled into pattern *) + offset_vector: PInteger; (* The offset vector *) + subject: PAnsiChar; (* The subject being matched *) + subject_length: Integer; (* The length of the subject *) + start_match: Integer; (* Offset to start of this match attempt *) + current_position: Integer; (* Where we currently are in the subject *) + capture_top: Integer; (* Max current capture *) + capture_last: Integer; (* Most recently closed capture *) + callout_data: Pointer; (* Data passed in with the call *) + (* ------------------- Added for Version 1 -------------------------- *) + pattern_position: Integer; (* Offset to next item in the pattern *) + next_item_length: Integer; (* Length of next item in the pattern *) + (* ------------------------------------------------------------------ *) + end; + + pcre_malloc_callback = function(Size: SizeInt): Pointer; cdecl; + {$EXTERNALSYM pcre_malloc_callback} + pcre_free_callback = procedure(P: Pointer); cdecl; + {$EXTERNALSYM pcre_free_callback} + pcre_stack_malloc_callback = function(Size: SizeInt): Pointer; cdecl; + {$EXTERNALSYM pcre_stack_malloc_callback} + pcre_stack_free_callback = procedure(P: Pointer); cdecl; + {$EXTERNALSYM pcre_stack_free_callback} + pcre_callout_callback = function(var callout_block: pcre_callout_block): Integer; cdecl; + {$EXTERNALSYM pcre_callout_callback} + +var + // renamed from "pcre_X" to "pcre_X_func" to allow functions with name "pcre_X" to be + // declared in implementation when static linked + pcre_malloc_func: ^pcre_malloc_callback = nil; + {$EXTERNALSYM pcre_malloc_func} + pcre_free_func: ^pcre_free_callback = nil; + {$EXTERNALSYM pcre_free_func} + pcre_stack_malloc_func: ^pcre_stack_malloc_callback = nil; + {$EXTERNALSYM pcre_stack_malloc_func} + pcre_stack_free_func: ^pcre_stack_free_callback = nil; + {$EXTERNALSYM pcre_stack_free_func} + pcre_callout_func: ^pcre_callout_callback = nil; + {$EXTERNALSYM pcre_callout_func} + +procedure SetPCREMallocCallback(const Value: pcre_malloc_callback); +{$EXTERNALSYM SetPCREMallocCallback} +function GetPCREMallocCallback: pcre_malloc_callback; +{$EXTERNALSYM GetPCREMallocCallback} +function CallPCREMalloc(Size: SizeInt): Pointer; +{$EXTERNALSYM CallPCREMalloc} + +procedure SetPCREFreeCallback(const Value: pcre_free_callback); +{$EXTERNALSYM SetPCREFreeCallback} +function GetPCREFreeCallback: pcre_free_callback; +{$EXTERNALSYM GetPCREFreeCallback} +procedure CallPCREFree(P: Pointer); +{$EXTERNALSYM CallPCREFree} + +procedure SetPCREStackMallocCallback(const Value: pcre_stack_malloc_callback); +{$EXTERNALSYM SetPCREStackMallocCallback} +function GetPCREStackMallocCallback: pcre_stack_malloc_callback; +{$EXTERNALSYM GetPCREStackMallocCallback} +function CallPCREStackMalloc(Size: SizeInt): Pointer; +{$EXTERNALSYM CallPCREStackMalloc} + +procedure SetPCREStackFreeCallback(const Value: pcre_stack_free_callback); +{$EXTERNALSYM SetPCREStackFreeCallback} +function GetPCREStackFreeCallback: pcre_stack_free_callback; +{$EXTERNALSYM GetPCREStackFreeCallback} +procedure CallPCREStackFree(P: Pointer); +{$EXTERNALSYM CallPCREStackFree} + +procedure SetPCRECalloutCallback(const Value: pcre_callout_callback); +{$EXTERNALSYM SetPCRECalloutCallback} +function GetPCRECalloutCallback: pcre_callout_callback; +{$EXTERNALSYM GetPCRECalloutCallback} +function CallPCRECallout(var callout_block: pcre_callout_block): Integer; +{$EXTERNALSYM CallPCRECallout} + +type + TPCRELibNotLoadedHandler = procedure; cdecl; + +var + // Value to initialize function pointers below with, in case LoadPCRE fails + // or UnloadPCRE is called. Typically the handler will raise an exception. + LibNotLoadedHandler: TPCRELibNotLoadedHandler = nil; + +(* Functions *) + +// dynamic dll import +type + pcre_compile_func = function(const pattern: PAnsiChar; options: Integer; + const errptr: PPAnsiChar; erroffset: PInteger; const tableptr: PAnsiChar): PPCRE; + cdecl; + {$EXTERNALSYM pcre_compile_func} + pcre_compile2_func = function(const pattern: PAnsiChar; options: Integer; + const errorcodeptr: PInteger; const errorptr: PPAnsiChar; erroroffset: PInteger; + const tables: PAnsiChar): PPCRE; cdecl; + {$EXTERNALSYM pcre_compile2_func} + pcre_config_func = function(what: Integer; where: Pointer): Integer; + cdecl; + {$EXTERNALSYM pcre_config_func} + pcre_copy_named_substring_func = function(const code: PPCRE; const subject: PAnsiChar; + ovector: PInteger; stringcount: Integer; const stringname: PAnsiChar; + buffer: PAnsiChar; size: Integer): Integer; cdecl; + {$EXTERNALSYM pcre_copy_named_substring_func} + pcre_copy_substring_func = function(const subject: PAnsiChar; ovector: PInteger; + stringcount, stringnumber: Integer; buffer: PAnsiChar; buffersize: Integer): Integer; + cdecl; + {$EXTERNALSYM pcre_copy_substring_func} + pcre_dfa_exec_func = function(const argument_re: PPCRE; const extra_data: PPCREExtra; + const subject: PAnsiChar; length: Integer; start_offset: Integer; + options: Integer; offsets: PInteger; offsetcount: Integer; workspace: PInteger; + wscount: Integer): Integer; cdecl; + {$EXTERNALSYM pcre_dfa_exec_func} + pcre_exec_func = function(const code: PPCRE; const extra: PPCREExtra; const subject: PAnsiChar; + length, startoffset, options: Integer; ovector: PInteger; ovecsize: Integer): Integer; + cdecl; + {$EXTERNALSYM pcre_exec_func} + pcre_free_substring_func = procedure(stringptr: PAnsiChar); + cdecl; + {$EXTERNALSYM pcre_free_substring_func} + pcre_free_substring_list_func = procedure(stringptr: PPAnsiChar); + cdecl; + {$EXTERNALSYM pcre_free_substring_list_func} + pcre_fullinfo_func = function(const code: PPCRE; const extra: PPCREExtra; + what: Integer; where: Pointer): Integer; + cdecl; + {$EXTERNALSYM pcre_fullinfo_func} + pcre_get_named_substring_func = function(const code: PPCRE; const subject: PAnsiChar; + ovector: PInteger; stringcount: Integer; const stringname: PAnsiChar; + const stringptr: PPAnsiChar): Integer; cdecl; + {$EXTERNALSYM pcre_get_named_substring_func} + pcre_get_stringnumber_func = function(const code: PPCRE; + const stringname: PAnsiChar): Integer; cdecl; + {$EXTERNALSYM pcre_get_stringnumber_func} + pcre_get_stringtable_entries_func = function(const code: PPCRE; const stringname: PAnsiChar; + firstptr: PPAnsiChar; lastptr: PPAnsiChar): Integer; + cdecl; + {$EXTERNALSYM pcre_get_stringtable_entries_func} + pcre_get_substring_func = function(const subject: PAnsiChar; ovector: PInteger; + stringcount, stringnumber: Integer; const stringptr: PPAnsiChar): Integer; + cdecl; + {$EXTERNALSYM pcre_get_substring_func} + pcre_get_substring_list_func = function(const subject: PAnsiChar; ovector: PInteger; + stringcount: Integer; listptr: PPPAnsiChar): Integer; + cdecl; + {$EXTERNALSYM pcre_get_substring_list_func} + pcre_info_func = function(const code: PPCRE; optptr, firstcharptr: PInteger): Integer; + cdecl; + {$EXTERNALSYM pcre_info_func} + pcre_maketables_func = function: PAnsiChar; cdecl; + {$EXTERNALSYM pcre_maketables_func} + pcre_refcount_func = function(argument_re: PPCRE; adjust: Integer): Integer; + cdecl; + {$EXTERNALSYM pcre_refcount_func} + pcre_study_func = function(const code: PPCRE; options: Integer; const errptr: PPAnsiChar): PPCREExtra; + cdecl; + {$EXTERNALSYM pcre_study_func} + pcre_version_func = function: PAnsiChar; cdecl; + {$EXTERNALSYM pcre_version_func} + +var + pcre_compile: pcre_compile_func = nil; + {$EXTERNALSYM pcre_compile} + pcre_compile2: pcre_compile2_func = nil; + {$EXTERNALSYM pcre_compile2} + pcre_config: pcre_config_func = nil; + {$EXTERNALSYM pcre_config} + pcre_copy_named_substring: pcre_copy_named_substring_func = nil; + {$EXTERNALSYM pcre_copy_named_substring} + pcre_copy_substring: pcre_copy_substring_func = nil; + {$EXTERNALSYM pcre_copy_substring} + pcre_dfa_exec: pcre_dfa_exec_func = nil; + {$EXTERNALSYM pcre_dfa_exec} + pcre_exec: pcre_exec_func = nil; + {$EXTERNALSYM pcre_exec} + pcre_free_substring: pcre_free_substring_func = nil; + {$EXTERNALSYM pcre_free_substring} + pcre_free_substring_list: pcre_free_substring_list_func = nil; + {$EXTERNALSYM pcre_free_substring_list} + pcre_fullinfo: pcre_fullinfo_func = nil; + {$EXTERNALSYM pcre_fullinfo} + pcre_get_named_substring: pcre_get_named_substring_func = nil; + {$EXTERNALSYM pcre_get_named_substring} + pcre_get_stringnumber: pcre_get_stringnumber_func = nil; + {$EXTERNALSYM pcre_get_stringnumber} + pcre_get_stringtable_entries: pcre_get_stringtable_entries_func = nil; + {$EXTERNALSYM pcre_get_stringtable_entries} + pcre_get_substring: pcre_get_substring_func = nil; + {$EXTERNALSYM pcre_get_substring} + pcre_get_substring_list: pcre_get_substring_list_func = nil; + {$EXTERNALSYM pcre_get_substring_list} + pcre_info: pcre_info_func = nil; + {$EXTERNALSYM pcre_info} + pcre_maketables: pcre_maketables_func = nil; + {$EXTERNALSYM pcre_maketables} + pcre_refcount: pcre_refcount_func = nil; + {$EXTERNALSYM pcre_refcount} + pcre_study: pcre_study_func = nil; + {$EXTERNALSYM pcre_study} + pcre_version: pcre_version_func = nil; + {$EXTERNALSYM pcre_version} + +function IsPCRELoaded: Boolean; +function LoadPCRE: Boolean; +procedure UnloadPCRE; + +implementation + +uses + SysUtils, + {$IFDEF MSWINDOWS} + Windows; + {$ENDIF MSWINDOWS} + {$IFDEF UNIX} + {$IFDEF HAS_UNIT_TYPES} + Types, + {$ENDIF HAS_UNIT_TYPES} + {$IFDEF HAS_UNIT_LIBC} + Libc; + {$ELSE ~HAS_UNIT_LIBC} + dl; + {$ENDIF ~HAS_UNIT_LIBC} + {$ENDIF UNIX} + +type + {$IFDEF MSWINDOWS} + TModuleHandle = HINST; + {$ENDIF MSWINDOWS} + {$IFDEF LINUX} + TModuleHandle = Pointer; + {$ENDIF LINUX} + {$IFDEF DARWIN} + TModuleHandle = Pointer; + {$ENDIF DARWIN} + +const + {$IFDEF MSWINDOWS} + libpcremodulename = 'pcre3.dll'; + {$ENDIF MSWINDOWS} + {$IFDEF LINUX} + libpcremodulename = 'libpcre.so.0'; + {$ENDIF LINUX} + {$IFDEF DARWIN} + libpcremodulename = 'libpcre.dylib'; + {$ENDIF DARWIN} + PCRECompileExportName = 'pcre_compile'; + PCRECompile2ExportName = 'pcre_compile2'; + PCREConfigExportName = 'pcre_config'; + PCRECopyNamedSubstringExportName = 'pcre_copy_named_substring'; + PCRECopySubStringExportName = 'pcre_copy_substring'; + PCREDfaExecExportName = 'pcre_dfa_exec'; + PCREExecExportName = 'pcre_exec'; + PCREFreeSubStringExportName = 'pcre_free_substring'; + PCREFreeSubStringListExportName = 'pcre_free_substring_list'; + PCREFullInfoExportName = 'pcre_fullinfo'; + PCREGetNamedSubstringExportName = 'pcre_get_named_substring'; + PCREGetStringNumberExportName = 'pcre_get_stringnumber'; + PCREGetStringTableEntriesExportName = 'pcre_get_stringtable_entries'; + PCREGetSubStringExportName = 'pcre_get_substring'; + PCREGetSubStringListExportName = 'pcre_get_substring_list'; + PCREInfoExportName = 'pcre_info'; + PCREMakeTablesExportName = 'pcre_maketables'; + PCRERefCountExportName = 'pcre_refcount'; + PCREStudyExportName = 'pcre_study'; + PCREVersionExportName = 'pcre_version'; + PCREMallocExportName = 'pcre_malloc'; + PCREFreeExportName = 'pcre_free'; + PCREStackMallocExportName = 'pcre_stack_malloc'; + PCREStackFreeExportName = 'pcre_stack_free'; + PCRECalloutExportName = 'pcre_callout'; + INVALID_MODULEHANDLE_VALUE = TModuleHandle(0); + +var + PCRELib: TModuleHandle = INVALID_MODULEHANDLE_VALUE; + +procedure SetPCREMallocCallback(const Value: pcre_malloc_callback); +begin + if not Assigned(pcre_malloc_func) then + LoadPCRE; + + if Assigned(pcre_malloc_func) then + pcre_malloc_func^ := Value + else if Assigned(LibNotLoadedHandler) then + LibNotLoadedHandler; +end; + +function GetPCREMallocCallback: pcre_malloc_callback; +begin + if not Assigned(pcre_malloc_func) then + LoadPCRE; + + if not Assigned(pcre_malloc_func) then + begin + Result := nil; + if Assigned(LibNotLoadedHandler) then + LibNotLoadedHandler; + end + else + Result := pcre_malloc_func^; +end; + +function CallPCREMalloc(Size: SizeInt): Pointer; +begin + Result := pcre_malloc_func^(Size); +end; + +procedure SetPCREFreeCallback(const Value: pcre_free_callback); +begin + if not Assigned(pcre_free_func) then + LoadPCRE; + + if Assigned(pcre_free_func) then + pcre_free_func^ := Value + else if Assigned(LibNotLoadedHandler) then + LibNotLoadedHandler; +end; + +function GetPCREFreeCallback: pcre_free_callback; +begin + if not Assigned(pcre_free_func) then + LoadPCRE; + + if not Assigned(pcre_free_func) then + begin + Result := nil; + if Assigned(LibNotLoadedHandler) then + LibNotLoadedHandler; + end + else + Result := pcre_free_func^ +end; + +procedure CallPCREFree(P: Pointer); +begin + pcre_free_func^(P); +end; + +procedure SetPCREStackMallocCallback(const Value: pcre_stack_malloc_callback); +begin + if not Assigned(pcre_stack_malloc_func) then + LoadPCRE; + + if Assigned(pcre_stack_malloc_func) then + pcre_stack_malloc_func^ := Value + else if Assigned(LibNotLoadedHandler) then + LibNotLoadedHandler; +end; + +function GetPCREStackMallocCallback: pcre_stack_malloc_callback; +begin + if not Assigned(pcre_stack_malloc_func) then + LoadPCRE; + + if not Assigned(pcre_stack_malloc_func) then + begin + Result := nil; + if Assigned(LibNotLoadedHandler) then + LibNotLoadedHandler; + end + else + Result := pcre_stack_malloc_func^; +end; + +function CallPCREStackMalloc(Size: SizeInt): Pointer; +begin + Result := pcre_stack_malloc_func^(Size); +end; + +procedure SetPCREStackFreeCallback(const Value: pcre_stack_free_callback); +begin + if not Assigned(pcre_stack_free_func) then + LoadPCRE; + + if Assigned(pcre_stack_free_func) then + pcre_stack_free_func^ := Value + else if Assigned(LibNotLoadedHandler) then + LibNotLoadedHandler; +end; + +function GetPCREStackFreeCallback: pcre_stack_free_callback; +begin + if not Assigned(pcre_stack_free_func) then + LoadPCRE; + + if not Assigned(pcre_stack_free_func) then + begin + Result := nil; + if Assigned(LibNotLoadedHandler) then + LibNotLoadedHandler; + end + else + Result := pcre_stack_free_func^; +end; + +procedure CallPCREStackFree(P: Pointer); +begin + pcre_stack_free_func^(P); +end; + +procedure SetPCRECalloutCallback(const Value: pcre_callout_callback); +begin + if not Assigned(pcre_callout_func) then + LoadPCRE; + + if Assigned(pcre_callout_func) then + pcre_callout_func^ := Value + else if Assigned(LibNotLoadedHandler) then + LibNotLoadedHandler; +end; + +function GetPCRECalloutCallback: pcre_callout_callback; +begin + if not Assigned(pcre_callout_func) then + LoadPCRE; + + if not Assigned(pcre_callout_func) then + begin + Result := nil; + if Assigned(LibNotLoadedHandler) then + LibNotLoadedHandler; + end + else + Result := pcre_callout_func^; +end; + +function CallPCRECallout(var callout_block: pcre_callout_block): Integer; +begin + Result := pcre_callout_func^(callout_block); +end; + +procedure InitPCREFuncPtrs(const Value: Pointer); +begin + @pcre_compile := Value; + @pcre_compile2 := Value; + @pcre_config := Value; + @pcre_copy_named_substring := Value; + @pcre_copy_substring := Value; + @pcre_dfa_exec := Value; + @pcre_exec := Value; + @pcre_free_substring := Value; + @pcre_free_substring_list := Value; + @pcre_fullinfo := Value; + @pcre_get_named_substring := Value; + @pcre_get_stringnumber := Value; + @pcre_get_stringtable_entries := Value; + @pcre_get_substring := Value; + @pcre_get_substring_list := Value; + @pcre_info := Value; + @pcre_maketables := Value; + @pcre_refcount := Value; + @pcre_study := Value; + @pcre_version := Value; + pcre_malloc_func := nil; + pcre_free_func := nil; + pcre_stack_malloc_func := nil; + pcre_stack_free_func := nil; + pcre_callout_func := nil; +end; + +function IsPCRELoaded: Boolean; +begin + Result := PCRELib <> INVALID_MODULEHANDLE_VALUE; +end; + +function LoadPCRE: Boolean; + function GetSymbol(SymbolName: PAnsiChar): Pointer; + begin + {$IFDEF MSWINDOWS} + Result := GetProcAddress(PCRELib, SymbolName); + {$ENDIF MSWINDOWS} + {$IFDEF UNIX} + Result := dlsym(PCRELib, SymbolName); + {$ENDIF UNIX} + end; + +begin + Result := PCRELib <> INVALID_MODULEHANDLE_VALUE; + if Result then + Exit; + + if PCRELib = INVALID_MODULEHANDLE_VALUE then + {$IFDEF MSWINDOWS} + PCRELib := SafeLoadLibrary(libpcremodulename); + {$ENDIF MSWINDOWS} + {$IFDEF UNIX} + PCRELib := dlopen(PAnsiChar(libpcremodulename), RTLD_NOW); + {$ENDIF UNIX} + Result := PCRELib <> INVALID_MODULEHANDLE_VALUE; + if Result then + begin + @pcre_compile := GetSymbol(PCRECompileExportName); + @pcre_compile2 := GetSymbol(PCRECompile2ExportName); + @pcre_config := GetSymbol(PCREConfigExportName); + @pcre_copy_named_substring := GetSymbol(PCRECopyNamedSubstringExportName); + @pcre_copy_substring := GetSymbol(PCRECopySubStringExportName); + @pcre_dfa_exec := GetSymbol(PCREDfaExecExportName); + @pcre_exec := GetSymbol(PCREExecExportName); + @pcre_free_substring := GetSymbol(PCREFreeSubStringExportName); + @pcre_free_substring_list := GetSymbol(PCREFreeSubStringListExportName); + @pcre_fullinfo := GetSymbol(PCREFullInfoExportName); + @pcre_get_named_substring := GetSymbol(PCREGetNamedSubstringExportName); + @pcre_get_stringnumber := GetSymbol(PCREGetStringNumberExportName); + @pcre_get_stringtable_entries := GetSymbol(PCREGetStringTableEntriesExportName); + @pcre_get_substring := GetSymbol(PCREGetSubStringExportName); + @pcre_get_substring_list := GetSymbol(PCREGetSubStringListExportName); + @pcre_info := GetSymbol(PCREInfoExportName); + @pcre_maketables := GetSymbol(PCREMakeTablesExportName); + @pcre_refcount := GetSymbol(PCRERefCountExportName); + @pcre_study := GetSymbol(PCREStudyExportName); + @pcre_version := GetSymbol(PCREVersionExportName); + pcre_malloc_func := GetSymbol(PCREMallocExportName); + pcre_free_func := GetSymbol(PCREFreeExportName); + pcre_stack_malloc_func := GetSymbol(PCREStackMallocExportName); + pcre_stack_free_func := GetSymbol(PCREStackFreeExportName); + pcre_callout_func := GetSymbol(PCRECalloutExportName); + end + else + InitPCREFuncPtrs(@LibNotLoadedHandler); +end; + +procedure UnloadPCRE; +begin + if PCRELib <> INVALID_MODULEHANDLE_VALUE then + {$IFDEF MSWINDOWS} + FreeLibrary(PCRELib); + {$ENDIF MSWINDOWS} + {$IFDEF UNIX} + dlclose(Pointer(PCRELib)); + {$ENDIF UNIX} + PCRELib := INVALID_MODULEHANDLE_VALUE; + InitPCREFuncPtrs(@LibNotLoadedHandler); +end; + +(* +function pcre_compile; external libpcremodulename name PCRECompileExportName; +function pcre_compile2; external libpcremodulename name PCRECompile2ExportName; +function pcre_config; external libpcremodulename name PCREConfigExportName; +function pcre_copy_named_substring; external libpcremodulename name PCRECopyNamedSubStringExportName; +function pcre_copy_substring; external libpcremodulename name PCRECopySubStringExportName; +function pcre_dfa_exec; external libpcremodulename name PCREDfaExecExportName; +function pcre_exec; external libpcremodulename name PCREExecExportName; +procedure pcre_free_substring; external libpcremodulename name PCREFreeSubStringExportName; +procedure pcre_free_substring_list; external libpcremodulename name PCREFreeSubStringListExportName; +function pcre_fullinfo; external libpcremodulename name PCREFullInfoExportName; +function pcre_get_named_substring; external libpcremodulename name PCREGetNamedSubStringExportName; +function pcre_get_stringnumber; external libpcremodulename name PCREGetStringNumberExportName; +function pcre_get_stringtable_entries; external libpcremodulename name PCREGetStringTableEntriesExportName; +function pcre_get_substring; external libpcremodulename name PCREGetSubStringExportName; +function pcre_get_substring_list; external libpcremodulename name PCREGetSubStringListExportName; +function pcre_info; external libpcremodulename name PCREInfoExportName; +function pcre_maketables; external libpcremodulename name PCREMakeTablesExportName; +function pcre_refcount; external libpcremodulename name PCRERefCountExportName; +function pcre_study; external libpcremodulename name PCREStudyExportName; +function pcre_version; external libpcremodulename name PCREVersionExportName; +*) + +end. diff --git a/cmake/src/lib/portaudio/portaudio.pas b/cmake/src/lib/portaudio/portaudio.pas index a0286b48..ea7d06b7 100644 --- a/cmake/src/lib/portaudio/portaudio.pas +++ b/cmake/src/lib/portaudio/portaudio.pas @@ -109,8 +109,8 @@ type TPaErrorCode = {enum}cint; const paStreamIsNotStopped = (paNotInitialized+18); paInputOverflowed = (paNotInitialized+19); paOutputUnderflowed = (paNotInitialized+20); - paHostApiNotFound = (paNotInitialized+21); - paInvalidHostApi = (paNotInitialized+22); + paHostApiNotFound = (paNotInitialized+21); // The notes below are from the + paInvalidHostApi = (paNotInitialized+22); // original file portaudio.h paCanNotReadFromACallbackStream = (paNotInitialized+23); {**< @todo review error code name *} paCanNotWriteToACallbackStream = (paNotInitialized+24); {**< @todo review error code name *} paCanNotReadFromAnOutputOnlyStream = (paNotInitialized+25); {**< @todo review error code name *} diff --git a/cmake/src/lib/projectM/cwrapper/projectM-cwrapper.h b/cmake/src/lib/projectM/cwrapper/projectM-cwrapper.h index 43f36ef4..125b1253 100644 --- a/cmake/src/lib/projectM/cwrapper/projectM-cwrapper.h +++ b/cmake/src/lib/projectM/cwrapper/projectM-cwrapper.h @@ -7,10 +7,11 @@ #define PROJECTM_VERSION_1_00_00 1000000 // 1.00.00 = 1.0 or 1.01 (same version number for 1.0 and 1.01) #define PROJECTM_VERSION_1_10_00 1010000 // 1.10.00 = 1.1 (bigger than 1.2 due to strange versioning) #define PROJECTM_VERSION_1_02_00 1002000 // 1.02.00 = 1.2 +#define PROJECTM_VERSION_2_00_00 2000000 // 2.00.00 = 2.0 // version of projectM to wrap (see PROJECTM_VERSION) #ifndef PROJECTM_VERSION_INT -#define PROJECTM_VERSION_INT PROJECTM_VERSION_1_02_00 +#define PROJECTM_VERSION_INT PROJECTM_VERSION_2_00_00 #endif extern "C" { diff --git a/cmake/src/lib/projectM/projectM.pas b/cmake/src/lib/projectM/projectM.pas index 4adba17d..533cb19b 100644 --- a/cmake/src/lib/projectM/projectM.pas +++ b/cmake/src/lib/projectM/projectM.pas @@ -2,7 +2,7 @@ unit projectM; {$IFDEF FPC} {$MODE DELPHI} - {$H+} (* use AnsiString *) + {$H+} (* use long strings *) {$PACKENUM 4} (* use 4-byte enums *) {$PACKRECORDS C} (* C/C++-compatible record packing *) {$ELSE} diff --git a/cmake/src/lib/zlib/zlib.pas b/cmake/src/lib/zlib/zlib.pas index 31d6a68b..8d09313f 100644 --- a/cmake/src/lib/zlib/zlib.pas +++ b/cmake/src/lib/zlib/zlib.pas @@ -14,7 +14,7 @@ interface {$ifdef FPC} {$mode objfpc} // Needed for array of const - {$H+} // use AnsiString + {$H+} // use long strings {$PACKRECORDS C} {$endif} diff --git a/cmake/src/lua/UHookableEvent.pas b/cmake/src/lua/UHookableEvent.pas new file mode 100644 index 00000000..8ad7ea9c --- /dev/null +++ b/cmake/src/lua/UHookableEvent.pas @@ -0,0 +1,380 @@ +{* UltraStar Deluxe - Karaoke Game
+ *
+ * UltraStar Deluxe is the legal property of its developers, whose names
+ * are too numerous to list here. Please refer to the COPYRIGHT
+ * file distributed with this source distribution.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301, USA.
+ *
+ * $URL$
+ * $Id$
+ *}
+
+unit UHookableEvent;
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+{$ENDIF}
+
+{$I switches.inc}
+
+uses ULua;
+
+type
+ { Record holding information about a hook of an event }
+ PHook = ^THook;
+ THook = record
+ Handle: Integer; //< Handle to identify the hook, e.g. for unhooking by plugin
+ Parent: Integer; //< Lua Core Handle this hook belongs to
+
+ Func: String; //< Name of the global that holds the function
+
+ Next: PHook; //< Next Hook in list (nil for the first)
+ end;
+
+ { procedure is called before each call to the hooking lua functions, to push values on stack
+ returns the number of pushed arguments}
+ PrepareStackProc = Function(L: PLua_State): Integer;
+
+ { class representing a hookable event }
+ THookableEvent = class
+ private
+ iHandle: Integer; //< used to unregister at lua core
+ LastHook: PHook; //< last hook in hook list, first to be called
+ NextHookHandle: Integer; //< handle to identify next hook
+
+ sName: String; //< the events name
+
+ PrepareStack: PrepareStackProc; //< prepare stack procedure passed to constructor
+ CallinProcess: boolean; //< true if a chain call is in process, to prepare unhooking during calls
+ HooksToRemove: array of PHook; // hooks to delete after chaincall
+
+ procedure RemoveWaitingHooks;
+ public
+ constructor Create(Name: String; const Proc: PrepareStackProc = nil);
+
+ property Name: String read sName; //< returns the events name
+ property Handle: Integer read iHandle; //< returns the events name
+
+ procedure Hook(L: Plua_State; Parent: Integer; Func: String); //< pushes hook object/table to the lua stack
+ procedure UnHook(L: Plua_State; hHook: Integer); //< unhook by plugin. push true or error string to lua stack
+
+ procedure UnHookByParent(Parent: Integer); //< deletes all hooks by a specified parent (unhook by core)
+
+ function CallHookChain(Breakable: Boolean): PLua_State; //< calls the events hookchain. if breakable, plugin can breake the chain by returning a value != 0 or false or nil
+
+ destructor Destroy; override;
+ end;
+
+{ the default function for THookableEvent.PrepareStack it don't pass any arguments }
+function PrepareStack_Dummy(L: PLua_State): Integer;
+
+{ function in resulting hook table. it calls the unhook command of the event on plugins demand }
+function LuaHook_UnHook(L: Plua_State): Integer; cdecl;
+
+implementation
+uses ULuaCore;
+
+constructor THookableEvent.Create(Name: String; const Proc: PrepareStackProc);
+begin
+ inherited Create;
+
+ Self.sName := Name;
+
+ if (@Proc = nil) then
+ Self.PrepareStack := @PrepareStack_Dummy
+ else
+ Self.PrepareStack := Proc;
+
+ //init LastHook pointer w/ nil
+ LastHook := nil;
+ NextHookHandle := 1;
+
+ iHandle := LuaCore.RegisterEvent(Self);
+end;
+
+destructor THookableEvent.Destroy;
+var
+ Prev: PHook;
+ Cur: PHook;
+begin
+ //delete all hooks
+ Cur := LastHook;
+ While (Cur <> nil) do
+ begin
+ Prev := Cur;
+ Cur := Prev.Next;
+
+ Dispose(Prev);
+ end;
+
+ //remove from luacores list
+ LuaCore.UnRegisterEvent(iHandle);
+
+ inherited;
+end;
+
+{ adds hook to events list and pushes hook object/table to the lua stack }
+procedure THookableEvent.Hook(L: PLua_State; Parent: Integer; Func: String);
+ var
+ Item: PHook;
+ P: TLuaPlugin;
+begin
+ P := LuaCore.GetPluginById(Parent);
+ if (P <> nil) then
+ begin
+ // get mem and fill it w/ data
+ New(Item);
+ Item.Handle := NextHookHandle;
+ Inc(NextHookHandle);
+
+ Item.Parent := Parent;
+ Item.Func := Func;
+
+ // add at front of the hook chain
+ Item.Next := LastHook;
+ LastHook := Item;
+
+ //we need 2 free stack slots
+ lua_checkstack(L, 2);
+
+ //create the hook table, we need 2 elements (event name and unhook function)
+ lua_createtable(L, 0, 2);
+
+ //push events name
+ lua_pushstring(L, PAnsiChar(Name));
+
+ //add the name to the table
+ lua_setfield(L, -2, 'Event');
+
+ //push hook id to the stack
+ lua_pushinteger(L, Item.Handle);
+
+ //create a c closure, append one value from stack(the id)
+ //this will pop both, the function and the id
+ lua_pushcclosure(L, LuaHook_UnHook, 1);
+
+ //add the function to our table
+ lua_setfield(L, -2, 'Unhook');
+
+ //the table is left on the stack, it is our result
+ end;
+end;
+
+{ removes hooks in HookstoRemove array from chain }
+procedure THookableEvent.RemoveWaitingHooks;
+ function IsInArray(Cur: PHook): boolean;
+ var I: Integer;
+ begin
+ Result := false;
+ for I := 0 to high(HooksToRemove) do
+ if (HooksToRemove[I] = Cur) then
+ begin
+ Result := true;
+ Break;
+ end;
+ end;
+
+ var
+ Cur, Prev: PHook;
+begin
+ Prev := nil;
+ Cur := LastHook;
+
+ while (Cur <> nil) do
+ begin
+ if (IsInArray(Cur)) then
+ begin //we found the hook
+ if (prev <> nil) then
+ Prev.Next := Cur.Next
+ else //last hook found
+ LastHook := Cur.Next;
+
+ //free hooks memory
+ Dispose(Cur);
+
+ if (prev <> nil) then
+ Cur := Prev.Next
+ else
+ Cur := LastHook;
+ end
+ else
+ begin
+ Prev := Cur;
+ Cur := Prev.Next;
+ end;
+ end;
+
+ SetLength(HooksToRemove, 0);
+end;
+
+{ unhook by plugin. push true or error string to lua stack }
+procedure THookableEvent.UnHook(L: Plua_State; hHook: Integer);
+ var
+ Cur, Prev: PHook;
+ Len: integer;
+begin
+ if (hHook < NextHookHandle) and (hHook > 0) then
+ begin
+ //Search for the Hook
+ Prev := nil;
+ Cur := LastHook;
+
+ while (Cur <> nil) do
+ begin
+ if (Cur.Handle = hHook) then
+ begin //we found the hook
+ if not CallinProcess then
+ begin // => remove it
+ if (prev <> nil) then
+ Prev.Next := Cur.Next
+ else //last hook found
+ LastHook := Cur.Next;
+
+ //free hooks memory
+ Dispose(Cur);
+ end
+ else
+ begin // add to list of hooks to remove
+ Len := Length(HooksToRemove);
+ SetLength(HooksToRemove, Len + 1);
+ HooksToRemove[Len] := Cur;
+ end;
+
+ //indicate success
+ lua_pushboolean(L, True);
+ exit; //break the chain and exit the function
+ end;
+ Prev := Cur;
+ Cur := Prev.Next;
+ end;
+
+ lua_pushstring(L, PAnsiChar('handle already unhooked')); //the error description
+ end
+ else
+ lua_pushstring(L, PAnsiChar('undefined hook handle')); //the error description
+end;
+
+{ deletes all hooks by a specified parent (unhook by core) }
+procedure THookableEvent.UnHookByParent(Parent: Integer);
+ var
+ Cur, Prev: PHook;
+begin
+ Prev := nil;
+ Cur := LastHook;
+
+ While (Cur <> nil) do
+ begin
+ if (Cur.Parent = Parent) then
+ begin //found a hook from parent => remove it
+ if (Prev <> nil) then
+ Prev.Next := Cur.Next
+ Else
+ LastHook := Cur.Next;
+
+ Dispose(Cur);
+
+ if (Prev <> nil) then
+ Cur := Prev.Next
+ else
+ Cur := LastHook;
+ end
+ else //move through the chain
+ begin
+ Prev := Cur;
+ Cur := Prev.Next;
+ end;
+ end;
+end;
+
+{ calls the events hookchain. if breakable, plugin can breake the chain
+ by returning a value
+ breakable is pushed as the first parameter to the hooking functions
+ if chain is broken the LuaStack is returned, with all results left
+ you may call lua_clearstack }
+function THookableEvent.CallHookChain(Breakable: Boolean): Plua_State;
+ var
+ Cur: PHook;
+ P: TLuaPlugin;
+begin
+ Result := nil;
+
+ CallinProcess := true;
+
+ Cur := LastHook;
+ While (Cur <> nil) do
+ begin
+ P := LuaCore.GetPluginById(Cur.Parent);
+ lua_pushboolean(P.LuaState, Breakable);
+
+ if (P.CallFunctionByName(Cur.Func, 1 + PrepareStack(P.LuaState), LUA_MULTRET))
+ and Breakable
+ and (lua_gettop(P.LuaState) > 0) then
+ begin //Chain Broken
+ Result := P.LuaState;
+ Break;
+ end;
+
+ Cur := Cur.Next;
+ end;
+
+ RemoveWaitingHooks;
+ CallinProcess := false;
+end;
+
+{ the default function for THookableEvent.PrepareStack it don't pass any arguments }
+function PrepareStack_Dummy(L: PLua_State): Integer;
+begin
+ Result := 0;
+end;
+
+{ function in resulting hook table. it calls the unhook command of the event on plugins demand }
+function LuaHook_UnHook(L: Plua_State): Integer; cdecl;
+ var
+ Name: string;
+ Event: THookableEvent;
+ hHook: integer;
+begin
+ Result := 0;
+
+ if not lua_isTable(L, 1) then
+ LuaL_Error(L, 'Can''t find hook table in LuaHook_Unhook. Please call Unhook with method seperator (colon) instead of a point.');
+
+ // get event name
+ Lua_GetField(L, 1, 'Event');
+ if not lua_isString(L, -1) then
+ LuaL_Error(L, 'Can''t get event name in LuaHook_Unhook');
+
+ Name := Lua_ToString(L, -1);
+
+ // get event by name
+ Event := LuaCore.GetEventbyName(Name);
+
+ // free stack slots
+ Lua_pop(L, Lua_GetTop(L));
+
+ if (Event = nil) then
+ LuaL_Error(L, PAnsiChar('event ' + Name + ' does not exist (anymore?) in LuaHook_Unhook'));
+
+ // get the hookid
+ hHook := lua_ToInteger(L, lua_upvalueindex(1));
+
+ Event.UnHook(L, hHook);
+end;
+
+end.
\ No newline at end of file diff --git a/cmake/src/lua/ULuaCore.pas b/cmake/src/lua/ULuaCore.pas new file mode 100644 index 00000000..ea9fd991 --- /dev/null +++ b/cmake/src/lua/ULuaCore.pas @@ -0,0 +1,1021 @@ +{* UltraStar Deluxe - Karaoke Game
+ *
+ * UltraStar Deluxe is the legal property of its developers, whose names
+ * are too numerous to list here. Please refer to the COPYRIGHT
+ * file distributed with this source distribution.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301, USA.
+ *
+ * $URL$
+ * $Id$
+ *}
+
+unit ULuaCore;
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+{$ENDIF}
+
+{$I switches.inc}
+
+uses SysUtils, ULua, UHookableEvent, UPath;
+
+type
+ { this exception is raised when the lua panic function
+ is called. Only in case we use call instead of pcall.
+ it has the lua error string in its message attribute }
+ ELuaException = class(Exception);
+
+ { record represents item of Eventlist of TLuaCore }
+ PEventListItem = ^TEventListItem;
+ TEventListItem = record
+ Event: THookableEvent;
+ Next: PEventListItem;
+ end;
+
+ { record represents a module }
+ TLuaModule = record
+ Name: string;
+ Functions: array of luaL_reg; //modules functions, w/ trailing nils this time
+ end;
+
+ TLuaPlugin_Status = (psNone, psRunning, psClosed, psErrorOnLoad, psErrorOnCall, psErrorInInit, psErrorOnRun);
+ { class represents a loaded plugin }
+ TLuaPlugin = class
+ private
+ iId: integer;
+ Filename: IPath;
+ State: Plua_State; //< all functions of this plugin are called with this Lua state
+ bPaused: boolean; //< If true no lua functions from this state are called
+ ErrorCount: integer; //< counts the errors that occured during function calls of this plugin
+ ShutDown: boolean; //< for self shutdown by plugin. true if plugin wants to be unloaded after execution of current function
+
+ sName: string;
+ sVersion: string;
+ sAuthor: string;
+ sURL: string;
+
+ sStatus: TLuaPlugin_Status;
+ public
+ constructor Create(Filename: IPath; Id: integer);
+
+ property Id: integer read iId;
+ property Name: string read sName;
+ property Version: string read sVersion;
+ property Author: string read sAuthor;
+ property Url: string read sUrl;
+
+ property Status: TLuaPlugin_Status read sStatus;
+ property CountErrors: integer read ErrorCount;
+
+ property LuaState: Plua_State read State;
+
+ procedure Load;
+
+ procedure Register(Name, Version, Author, Url: string);
+ function HasRegistred: boolean;
+
+ procedure PausePlugin(doPause: boolean);
+ property Paused: boolean read bPaused write PausePlugin;
+
+ procedure ShutMeDown;
+
+ { calls the lua function in the global w/ the given name.
+ the arguments to the function have to be pushed to the stack
+ before calling this function.
+ the arguments and the function will be removed from stack
+ results will not be removed.
+ if result is false there was an error calling the function
+ if ReportErrors is true the errorstring is popped from stack
+ and written to error.log otherwise it is left on stack}
+ function CallFunctionByName(Name: string;
+ const nArgs: integer = 0;
+ const nResults: integer = 0;
+ const ReportErrors: boolean = true): boolean;
+ procedure ClearStack;
+
+ procedure Unload; //< Destroys the Luastate, and frees as much mem as possible, w/o destroying the class and important information
+
+ destructor Destroy; override;
+ end;
+
+ { class managing the plugins w/ their LuaStates, the events and modules
+ it also offers the usdx table to the plugins w/ some basic functionality
+ like self unload or hook getting}
+ TLuaCore = class
+ private
+ EventList: PEventListItem; //< pointer to first registred Event, ordered by name
+ EventHandles: array of string; //< Index is Events handle, value is events name. if length(value) is 0 handle is considered unregistred
+
+ Plugins: array of TLuaPlugin;
+
+ eLoadingFinished: THookableEvent;
+ protected
+ Modules: array of TLuaModule; //< modules that has been registred, has to be proctected because fucntions of this unit need to get access
+
+ function GetModuleIdByName(Name: string): integer; //returns id of given module, or -1 if module is not found
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ procedure LoadPlugins; //< calls LoadPlugin w/ Plugindir and LoadingFinished Eventchain
+
+ procedure BrowseDir(Dir: IPath); //< searches for files w/ extension .usdx in the specified dir and tries to load them w/ lua
+ procedure LoadPlugin(Filename: IPath); //< tries to load filename w/ lua and creates the default usdx lua environment for the plugins state
+
+ function GetPluginByName(Name: string): TLuaPlugin;
+ function GetPluginById(Id: integer): TLuaPlugin;
+
+ { this function adds a module loader for your functions
+ name is the name the script needs to write in its require()
+ Functions is an array of lua calling compatible functions
+ w/o trailing nils! }
+ procedure RegisterModule(Name: string; const Functions: array of luaL_reg);
+
+ function RegisterEvent(Event: THookableEvent): integer; //< adds the event to eventlist and returns its handle
+ procedure UnRegisterEvent(hEvent: integer); //< removes the event from eventlist by handle
+
+ function GetEventbyName(Name: string): THookableEvent; //< tries to find the event w/ the given name in the list
+ function GetEventbyHandle(hEvent: integer): THookableEvent; //< tries to find the event w/ the given handle
+
+ procedure UnHookByParent(Parent: integer); //< remove all hooks by given parent id from all events
+
+ procedure PrepareState(L: Plua_State);
+
+ procedure DumpPlugins; //< prints plugin runtime information w/ Log.LogStatus
+ end;
+
+//some luastyle functions to call from lua scripts
+{ register global, used by plugins to identify
+ register(plugin name, plugin version, [plugin author], [plugin homepage])
+ can only be called once since the global "register" is niled by the function
+ returns true on success. (name does not exist)}
+function TLuaPlugin_Register (L: Plua_State): integer; cdecl;
+
+{ moduleloader for usdx.* modules
+ stored in package.loaders[3]
+ package.loaders[3] (module name)
+ returns a function to load the requested module or a error
+ description(string) when the module is not found }
+function TLuaCore_ModuleLoader (L: Plua_State): integer; cdecl;
+
+{ loads module specified by a cfunction upvalue to
+ usdx.modulename and returns it.
+ loadmodule(module name) }
+function TLuaCore_LoadModule (L: Plua_State): integer; cdecl;
+
+{ custom lua panic function
+ it writes error string to error.log and raises an ELuaException
+ that may be caught }
+function TLua_CustomPanic (L: Plua_State): integer; cdecl;
+
+{ replacement for luas require function
+ can be called with more than one parameter to require
+ some modules at once. e.g.: require('math', 'Usdx.Log')
+ modules are loaded from right to left
+ unlike standard require the module tables are not returned
+ the standard require function in _require is called by
+ this function }
+function TLua_CustomRequire(L: PLua_State): integer; cdecl;
+
+
+var
+ LuaCore: TLuaCore;
+
+implementation
+uses
+ StrUtils,
+ ULog,
+ UFilesystem,
+ ULuaUsdx,
+ UPathUtils,
+ ULuaUtils;
+
+constructor TLuaCore.Create;
+begin
+ inherited;
+
+ //init EventList w/ nil
+ EventList := nil;
+
+ eLoadingFinished := nil;
+end;
+
+destructor TLuaCore.Destroy;
+var
+ Cur: PEventListItem;
+ Prev: PEventListItem;
+begin
+ SetLength(EventHandles, 0);
+
+ //delete event list
+ Cur := EventList;
+
+ while(Cur <> nil) do
+ begin
+ Prev := Cur;
+ Cur := Prev.Next;
+
+ Dispose(Prev);
+ end;
+
+ inherited;
+end;
+
+{ calls BrowseDir w/ plugin dir and LoadingFinished eventchain }
+procedure TLuaCore.LoadPlugins;
+begin
+ // we have to create event here, because in create it can
+ // not be registred, because LuaCore is no assigned
+ if (not Assigned(eLoadingFinished)) then
+ eLoadingFinished := THookableEvent.Create('Usdx.LoadingFinished');
+
+ BrowseDir(PluginPath);
+ eLoadingFinished.CallHookChain(false);
+end;
+
+{ searches for files w/ extension .usdx in the specified
+ dir and tries to load them w/ lua }
+procedure TLuaCore.BrowseDir(Dir: IPath);
+ var
+ Iter: IFileIterator;
+ FileInfo: TFileInfo;
+ FileName: IPath;
+ Ext: IPath;
+begin
+ Ext := Path('.usdx');
+
+ // search for all files and directories
+ Iter := FileSystem.FileFind(Dir.Append('*'), faAnyFile);
+ while (Iter.HasNext) do
+ begin
+ FileInfo := Iter.Next;
+ FileName := FileInfo.Name;
+ if ((FileInfo.Attr and faDirectory) <> 0) then
+ begin
+ if (not FileName.Equals('.')) and (not FileName.Equals('..')) then
+ BrowseDir(Dir.Append(FileName));
+ end
+ else
+ begin
+ if (Ext.Equals(FileName.GetExtension(), true)) then
+ begin
+ LoadPlugin(Dir.Append(FileName));
+ end;
+ end;
+ end;
+end;
+
+{ tries to load filename w/ lua and creates the default
+ usdx lua environment for the plugins state }
+procedure TLuaCore.LoadPlugin(Filename: IPath);
+ var
+ Len: integer;
+begin
+ Len := Length(Plugins);
+ SetLength(Plugins, Len + 1);
+ Plugins[Len] := TLuaPlugin.Create(Filename, Len);
+ Plugins[Len].Load;
+end;
+
+{ returns Plugin on success nil on failure }
+function TLuaCore.GetPluginByName(Name: string): TLuaPlugin;
+ var
+ I: integer;
+begin
+ Result := nil;
+ Name := lowercase(Name);
+
+ for I := 0 to High(Plugins) do
+ if (lowercase(Plugins[I].Name) = Name) then
+ begin
+ Result := GetPluginById(I);
+ Exit;
+ end;
+end;
+
+{ returns Plugin on success nil on failure }
+function TLuaCore.GetPluginById(Id: integer): TLuaPlugin;
+begin
+ if (Id >= 0) and (Id <= High(Plugins)) then
+ Result := Plugins[Id]
+ else
+ Result := nil;
+end;
+
+{ this function adds a module loader for your functions
+ name is the name the script needs to write in its require()
+ Functions is an array of lua calling compatible functions
+ w/o trailing nils! }
+procedure TLuaCore.RegisterModule(Name: string; const Functions: array of luaL_reg);
+ var
+ Len: integer;
+ FuncLen: integer;
+ I: integer;
+begin
+ Len := Length(Modules);
+ SetLength(Modules, Len + 1);
+ Modules[Len].Name := Name;
+
+ FuncLen := Length(Functions);
+ SetLength(Modules[Len].Functions, FuncLen + 1);
+
+ for I := 0 to FuncLen-1 do
+ Modules[Len].Functions[I] := Functions[I];
+
+ Modules[Len].Functions[FuncLen].name := nil;
+ Modules[Len].Functions[FuncLen].func := nil;
+end;
+
+{ adds the event to eventlist and returns its handle
+ called by THookableEvent on creation }
+function TLuaCore.RegisterEvent(Event: THookableEvent): integer;
+var
+ Cur, Prev, Item: PEventListItem;
+begin
+ if (Event <> nil) and (Length(Event.Name) > 0) then
+ begin
+ Result := Length(EventHandles);
+ SetLength(EventHandles, Result + 1); //get Handle and copy it to result
+
+ EventHandles[Result] := Event.Name;
+
+ //create eventlist item
+ New(Item);
+ Item.Event := Event;
+
+ //search for a place for this event in alphabetical order
+ Prev := nil;
+ Cur := EventList;
+
+ while (Cur <> nil) and (CompareStr(Cur.Event.Name, EventHandles[Result]) < 0) do
+ begin
+ Prev := Cur;
+ Cur := Prev.Next;
+ end;
+
+ //found the place => add new item
+ if (Prev <> nil) then
+ Prev.Next := Item
+ else //first item
+ EventList := Item;
+
+ Item.Next := Cur;
+ end
+ else
+ Result := -1;
+end;
+
+{ removes the event from eventlist by handle }
+procedure TLuaCore.UnRegisterEvent(hEvent: integer);
+ var
+ Cur, Prev: PEventListItem;
+begin
+ if (hEvent >= 0) and (hEvent <= High(EventHandles)) and (Length(EventHandles[hEvent]) > 0) then
+ begin //hEvent in bounds and not already deleted
+ //delete from eventlist
+ Prev := nil;
+ Cur := EventList;
+
+ while (Cur <> nil) and (CompareStr(Cur.Event.Name, EventHandles[hEvent]) < 0) do
+ begin
+ Prev := Cur;
+ Cur := Prev.Next;
+ end;
+
+ if (Cur <> nil) and (Cur.Event.Name = EventHandles[hEvent]) then
+ begin //delete if found
+ Prev.Next := Cur.Next; // remove from list
+ Dispose(Cur); // free memory
+ end;
+
+ //delete from handle array
+ EventHandles[hEvent] := '';
+ end;
+end;
+
+{ tries to find the event w/ the given name in the list
+ to-do : use binary search algorithm instead of linear search here
+ check whether this is possible (events are saved in a pointer list) }
+function TLuaCore.GetEventbyName(Name: string): THookableEvent;
+ var
+ Cur: PEventListItem;
+begin
+ Result := nil;
+
+ if (Length(Name) > 0) then
+ begin
+ //search in eventlist
+ Cur := EventList;
+
+ while (Cur <> nil) and (CompareStr(Cur.Event.Name, Name) < 0) do
+ begin
+ Cur := Cur.Next;
+ end;
+
+ if (Cur <> nil) and (Cur.Event.Name = Name) then
+ begin //we found what we want to find
+ Result := Cur.Event;
+ end;
+ end;
+end;
+
+{ tries to find the event w/ the given handle }
+function TLuaCore.GetEventbyHandle(hEvent: integer): THookableEvent;
+begin
+ if (hEvent >= 0) and (hEvent <= High(EventHandles)) and (Length(EventHandles[hEvent]) > 0) then
+ begin //hEvent in bounds and not already deleted
+ Result := GetEventByName(EventHandles[hEvent]);
+ end
+ else
+ Result := nil;
+end;
+
+{ remove all hooks by given parent id from all events }
+procedure TLuaCore.UnHookByParent(Parent: integer);
+ var
+ Cur: PEventListItem;
+begin
+ if (Parent >= 0) and (Parent <= High(Plugins)) then
+ begin
+ // go through event list
+ Cur := EventList;
+
+ while (Cur <> nil) do
+ begin
+ Cur.Event.UnHookByParent(Parent);
+ Cur := Cur.Next;
+ end;
+ end;
+end;
+
+{ prepares the given already opened Lua state with the
+ basic usdx environment, e.g.: base and package Modules,
+ usdx moduleloader and usdx table }
+procedure TLuaCore.PrepareState(L: Plua_State);
+begin
+ //load basic lib functionality
+ lua_pushcfunction(L, luaopen_base);
+ lua_call(L, 0, 0);
+ lua_pop(L, lua_gettop(L)); //pop the results
+
+ //load module functionality
+ lua_pushcfunction(L, luaopen_package);
+ lua_call(L, 0, 0);
+ lua_pop(L, lua_gettop(L)); //pop the results
+
+ { adds the loader for the other standard lib to package.preload table
+ plugins can call e.g. require('math') if they need math functionality }
+
+ // we need 3 free stack slots
+ lua_checkstack(L, 3);
+
+ // get package table
+ lua_getglobal (L, PChar('package'));
+
+ // get package.preload table
+ lua_getfield (L, -1, PChar('preload'));
+
+ {**** add string lib }
+
+ // push loader function
+ lua_pushcfunction(L, luaopen_string);
+
+ // set package.preload.x loader
+ lua_setfield (L, -2, PChar('string'));
+
+ {**** add table lib }
+
+ // push loader function
+ lua_pushcfunction(L, luaopen_table);
+
+ // set package.preload.x loader
+ lua_setfield (L, -2, PChar('table'));
+
+ {**** add math lib }
+
+ // push loader function
+ lua_pushcfunction(L, luaopen_math);
+
+ // set package.preload.x loader
+ lua_setfield (L, -2, PChar('math'));
+
+ {**** add os lib }
+
+ // push loader function
+ lua_pushcfunction(L, luaopen_os);
+
+ // set package.preload.x loader
+ lua_setfield (L, -2, PChar('os'));
+
+ //pop package.preload table from stack
+ lua_pop(L, 1);
+
+ // get package.loaders table
+ lua_getfield (L, -1, PChar('loaders'));
+
+ {**** Move C-Library and all-in-one module loader backwards,
+ slot 3 is free now }
+ // get package.loaders[4] function
+ lua_pushinteger(L, 5); //push new index
+ lua_pushinteger(L, 4); //push old index
+ lua_gettable (L, -3);
+
+ // and move it to package.loaders[5]
+ lua_settable (L, -3);
+
+ // get package.loaders[3] function
+ lua_pushinteger(L, 4); //push new index
+ lua_pushinteger(L, 3); //push old index
+ lua_gettable (L, -3);
+
+ // and move it to package.loaders[4]
+ lua_settable (L, -3);
+
+ {**** now we add the core module to package.loaders[3] }
+ lua_pushinteger(L, 3); //push new loaders index
+ lua_pushcfunction(L, TLuaCore_ModuleLoader);
+
+ // and move it to package.loaders[3]
+ lua_settable (L, -3);
+
+ //pop both package and package.loaders tables from stack
+ lua_pop(L, 2);
+
+ {**** replace the standard require w/ our custom require function }
+ // first move standard require function to _require
+ lua_getfield(L, LUA_GLOBALSINDEX, PChar('require'));
+ lua_setfield(L, LUA_GLOBALSINDEX, PChar('_require'));
+
+ // then save custom require function to require
+ lua_pushcfunction(L, TLua_CustomRequire);
+ lua_setfield(L, LUA_GLOBALSINDEX, PChar('require'));
+
+ {**** now we create the usdx table }
+ //at first functions from ULuaUsdx
+ luaL_register(L, 'Usdx', @ULuaUsdx_Lib_f[0]);
+end;
+
+{ returns id of given module, or -1 if module is not found }
+function TLuaCore.GetModuleIdByName(Name: string): integer;
+ var
+ I: integer;
+begin
+ Result := -1;
+
+ for I := 0 to High(Modules) do
+ if (Modules[I].Name = Name) then
+ begin
+ Result := I;
+ Exit;
+ end;
+end;
+
+{ moduleloader for usdx.* modules
+ stored in package.loaders[3]
+ package.loaders[3] (module name)
+ returns a function to load the requested module or an error
+ description(string) when the module is not found }
+function TLuaCore_ModuleLoader (L: Plua_State): integer; cdecl;
+ var
+ Name: string;
+ ID: integer;
+begin
+ Result := 1; //we will return one value in any case (or never return in case of an error)
+
+ if (lua_gettop(L) >= 1) then
+ begin
+ // pop all arguments but the first
+ if (lua_gettop(L) > 1) then
+ lua_pop(L, lua_gettop(L)-1);
+
+
+ if (lua_IsString(L, 1)) then
+ begin //we got the name => go get it
+ Name := lua_toString(L, 1);
+
+ //we need at least 6 letters
+ //and first 5 letters have to be usdx.
+ if (Length(Name) > 5) and (lowercase(copy(Name, 1, 5))='usdx.') then
+ begin
+ ID := LuaCore.GetModuleIdByName(copy(Name, 6, Length(Name) - 5));
+ if (ID >= 0) then
+ begin //found the module -> return loader function
+ lua_pushinteger(L, Id);
+ lua_pushcclosure(L, TLuaCore_LoadModule, 1);
+ //the function is the result, so we leave it on stack
+ end
+ else
+ lua_pushString(L, PChar('usdx module "' + Name + '" couldn''t be found'));
+ end
+ else
+ lua_pushString(L, PChar('module doesn''t have "Usdx." prefix'));
+
+ end
+ else
+ luaL_argerror(L, 1, PChar('string expected'));
+ end
+ else
+ luaL_error(L, PChar('no modulename specified in usdx moduleloader'));
+end;
+
+{ loads module specified by a cfunction upvalue to
+ usdx.modulename and returns it.
+ loadmodule(module name) }
+function TLuaCore_LoadModule (L: Plua_State): integer; cdecl;
+ var
+ Id: integer;
+begin
+ if (not lua_isnoneornil(L, lua_upvalueindex(1))) then
+ begin
+ Id := lua_ToInteger(L, lua_upvalueindex(1));
+
+ luaL_register(L, PChar('Usdx.' + LuaCore.Modules[Id].Name), @LuaCore.Modules[Id].Functions[0]);
+
+ // set the modules table as global "modulename"
+ // so it can be accessed either by Usdx.modulename.x() or
+ // by modulename.x()
+ lua_setglobal(L, PChar(LuaCore.Modules[Id].Name));
+
+ // no we net to push the table again to return it
+ lua_getglobal(L, PChar(LuaCore.Modules[Id].Name));
+
+ Result := 1; //return table
+ end
+ else
+ luaL_error(L, PChar('no upvalue found in LuaCore_LoadModule'));
+end;
+
+{ prints plugin runtime information w/ Log.LogStatus }
+procedure TLuaCore.DumpPlugins;
+ function PluginStatusToString(Status: TLuaPlugin_Status): string;
+ begin
+ case Status of
+ psNone: Result := 'not loaded';
+ psRunning: Result := 'running';
+ psClosed: Result := 'closed';
+ psErrorOnLoad: Result := 'error during load';
+ psErrorOnCall: Result := 'error during call';
+ psErrorInInit: Result := 'error in plugin_init()';
+ psErrorOnRun: Result := 'error on function call';
+ else Result := 'unknown';
+ end;
+ end;
+
+var
+ I: integer;
+begin
+ // print table header
+ Log.LogStatus(Format('%3s %-30s %-8s %-10s %-7s %-6s', [
+ '#', 'Name', 'Version', 'Status', 'Paused', '#Errors'
+ ]), 'LuaCore Plugins');
+
+ for I := 0 to High(Plugins) do
+ Log.LogStatus(Format('%3d %-30s %-8s %-10s %-7s %-6d', [
+ Plugins[I].Id, Plugins[I].Name, Plugins[I].Version,
+ PluginStatusToString(Plugins[I].Status),
+ BoolToStr(Plugins[I].Paused, true),
+ Plugins[I].CountErrors
+ ]), 'LuaCore Plugins');
+ if (High(Plugins) < 0) then
+ Log.LogError(' no plugins loaded ', 'LuaCore Plugins');
+end;
+
+// Implementation of TLuaPlugin
+//--------
+constructor TLuaPlugin.Create(Filename: IPath; Id: integer);
+begin
+ inherited Create;
+ Self.iId := Id;
+ Self.Filename := Filename;
+
+ // set some default attributes
+ Self.bPaused := false;
+ Self.ErrorCount := 0;
+ Self.sName := 'not registred';
+ Self.sStatus := psNone;
+ Self.ShutDown := false;
+
+ State := nil; //< to prevent calls to unopened state
+end;
+
+destructor TLuaPlugin.Destroy;
+begin
+ Unload;
+ inherited;
+end;
+
+{ does the main loading part
+ can not be called by create, because Plugins[Id] isn't defined there }
+procedure TLuaPlugin.Load;
+begin
+ // create Lua state for this plugin
+ State := luaL_newstate;
+
+ //set our custom panic function if s/t went wrong along the init
+ //we don't expect
+ lua_atPanic(State, TLua_CustomPanic);
+
+ if (LuaL_LoadFile(State, PChar(Filename.ToNative)) = 0) then
+ begin // file loaded successful
+ { note: we run the file here, but the environment isn't
+ set up now. it just causes the functions to
+ register in globals and runs the code in the file
+ body. At least there should be no code, it could
+ neither use functions from baselibs nor load libs
+ with require, this code would be useless. }
+ if (lua_pcall(State, 0, 0, 0) = 0) then
+ begin // file called successful
+
+ //let the core prepare our state
+ LuaCore.PrepareState(State);
+
+ // set register function
+ lua_checkstack(State, 2);
+ lua_pushinteger(State, Id);
+ lua_pushcclosure(State, TLuaPlugin_Register, 1);
+ lua_setglobal(State, PChar('register'));
+
+ // write plugin id to registry
+ lua_pushinteger(State, iId);
+ lua_setfield (State, LUA_REGISTRYINDEX, '_USDX_STATE_ID');
+ lua_pop(State, Lua_GetTop(State));
+
+ // now run the plugin_init function
+ // plugin_init() if false or nothing is returned plugin init is aborted
+ if (CallFunctionByName('plugin_init', 0, 1)) then
+ begin
+ if (HasRegistred) and (sStatus = psNone) and (lua_toBoolean(State, 1)) then
+ begin
+ sStatus := psRunning;
+ ClearStack;
+ end
+ else
+ Unload;
+ end
+ else
+ begin
+ sStatus := psErrorInInit;
+ Log.LogError('error in plugin_init: ' + Self.Filename.ToNative, 'lua');
+ Unload;
+ end;
+ end
+ else
+ begin
+ sStatus := psErrorOnLoad;
+ Log.LogError(String(lua_toString(State, 1)), 'lua');
+ Log.LogError('unable to call file: ' + Self.Filename.ToNative, 'lua');
+ Unload;
+ end;
+
+ end
+ else
+ begin
+ sStatus := psErrorOnLoad;
+ Log.LogError(String(lua_toString(State, 1)), 'lua');
+ Log.LogError('unable to load file: ' + Self.Filename.ToNative, 'lua');
+ Unload;
+ end;
+end;
+
+procedure TLuaPlugin.Register(Name, Version, Author, Url: string);
+begin
+ sName := Name;
+ sVersion := Version;
+ sAuthor := Author;
+ sURL := Url;
+end;
+
+{ returns true if plugin has called register }
+function TLuaPlugin.HasRegistred: boolean;
+begin
+ Result := (Self.sName <> 'not registred');
+end;
+
+procedure TLuaPlugin.PausePlugin(doPause: boolean);
+begin
+ bPaused := doPause;
+end;
+
+{ unload plugin after execution of the current function }
+procedure TLuaPlugin.ShutMeDown;
+begin
+ ShutDown := true;
+end;
+
+{ calls the lua function in the global w/ the given name.
+ the arguments to the function have to be pushed to the stack
+ before calling this function.
+ the arguments and the function will be removed from stack
+ results will not be removed.
+ if result is false there was an error calling the function,
+ if ReportErrors is true the errorstring is popped from stack
+ and written to error.log otherwise it is left on stack}
+function TLuaPlugin.CallFunctionByName(Name: string;
+ const nArgs: integer;
+ const nResults: integer;
+ const ReportErrors: boolean): boolean;
+begin
+ Result := false;
+ if (State <> nil) then
+ begin
+ if (not bPaused) then
+ begin
+ // we need at least one stack slot free
+ lua_checkstack(State, 1);
+
+ // lua_getglobal(State, PChar(Name)); //this is just a macro:
+ lua_getfield(State, LUA_GLOBALSINDEX, PChar(Name));
+
+ if (lua_isfunction(State, -1)) then
+ begin //we got a function
+ // move function in front of the arguments (if any)
+ if (nArgs > 0) then
+ lua_insert(State, -(nArgs + 1));
+
+ // call it!
+ if (lua_pcall(State, nArgs, nResults, 0) = 0) then
+ Result := true //called w/o errors
+ else //increase error counter
+ Inc (ErrorCount);
+ end
+ else
+ begin //we have to pop the args and the field we pushed from stack
+ lua_pop(State, nArgs + 1);
+ //leave an errormessage on stack
+ lua_pushstring(State, Pchar('could not find function named ' + Name));
+ end;
+ end
+ else
+ begin //we have to pop the args from stack
+ lua_pop(State, nArgs);
+ //leave an errormessage on stack
+ lua_pushstring(State, PChar('plugin paused'));
+ end;
+
+ if (not Result) and (ReportErrors) then
+ Log.LogError(lua_toString(State, -1), 'lua/' + sName);
+
+ if ShutDown then
+ begin // plugin indicates self shutdown
+ ShutDown := false;
+ Unload;
+ Result := false;
+ end
+ end
+ else
+ begin
+ Log.LogError('trying to call function of closed or not opened lua state', IfThen(HasRegistred, Name, Filename.ToUTF8));
+ end;
+end;
+
+{ removes all values from stack }
+procedure TLuaPlugin.ClearStack;
+begin
+ if (State <> nil) and (lua_gettop(State) > 0) then
+ lua_pop(State, lua_gettop(State));
+end;
+
+{ destroys the lua state, and frees as much mem as possible,
+ w/o destroying the class and important information }
+procedure TLuaPlugin.Unload;
+begin
+ if (State <> nil) then
+ begin
+ if (Status in [psRunning, psErrorOnRun]) then
+ CallFunctionByName('plugin_unload');
+
+ ClearStack;
+ lua_close(State);
+ State := nil; //don't forget to nil it ;)
+
+ LuaCore.UnHookByParent(iId);
+
+ if (sStatus = psRunning) then
+ sStatus := psClosed;
+ end;
+end;
+
+function TLuaPlugin_Register (L: Plua_State): integer; cdecl;
+ var
+ Id: integer;
+ P: TLuaPlugin;
+ Name, Version, Author, Url: string;
+begin
+ if (lua_gettop(L) >= 2) then
+ begin // we got at least name and version
+ if (not lua_isNumber(L, lua_upvalueindex(1))) then
+ luaL_Error(L, PChar('upvalue missing'));
+
+ if (not lua_isString(L, 1)) then
+ luaL_ArgError(L, 1, 'string expected');
+
+ if (not lua_isString(L, 2)) then
+ luaL_ArgError(L, 1, 'string expected');
+
+ Id := lua_ToInteger(L, lua_upvalueindex(1));
+
+ //get version and name
+ Name := lua_tostring(L, 1);
+ Version := lua_tostring(L, 2);
+
+ //get optional parameters
+ if (lua_isString(L, 3)) then //author
+ Author := lua_toString(L, 3)
+ else
+ begin
+ Author := 'unknown';
+ end;
+
+ // homepage
+ if (lua_isString(L, 4)) then
+ Url := lua_toString(L, 4)
+ else
+ begin
+ Url := '';
+ end;
+
+ //clear stack
+ if (lua_gettop(L) > 0) then
+ lua_pop(L, lua_gettop(L));
+
+ //call register
+ P := LuaCore.GetPluginById(Id);
+ if (P <> nil) then
+ P.Register(Name, Version, Author, Url)
+ else
+ luaL_error(L, PChar('wrong id in upstream'));
+
+ // remove function from global register
+ lua_pushnil(L);
+ lua_setglobal(L, PChar('register'));
+
+ // return true
+ Result := 1;
+ lua_pushboolean(L, true);
+ end
+ else
+ luaL_error(L, PChar('not enough arguments, at least 2 expected. in TLuaPlugin_Register'));
+end;
+
+{ custom lua panic function
+ it writes error string to error.log and raises an ELuaException
+ that may be caught }
+function TLua_CustomPanic (L: Plua_State): integer; cdecl;
+ var
+ Msg: string;
+begin
+ if (lua_isString(L, -1)) then
+ Msg := lua_toString(L, -1)
+ else
+ Msg := 'undefined lua panic';
+
+ Log.LogError(Msg, 'lua');
+
+ raise ELuaException.Create(Msg);;
+
+ Result := 0;
+end;
+
+{ replacement for luas require function
+ can be called with more than one parameter to require
+ some modules at once. e.g.: require('math', 'Usdx.Log')
+ modules are loaded from right to left
+ unlike standard require the module tables are not returned
+ the standard require function in _require is called by
+ this function }
+function TLua_CustomRequire(L: PLua_State): integer; cdecl;
+begin
+ // no results
+ Result := 0;
+
+ // move through parameters
+ while (lua_getTop(L) >= 1) do
+ begin
+ // get luas require function
+ lua_getfield(L, LUA_GLOBALSINDEX, PChar('_require'));
+
+ // move it under the top param
+ lua_insert(L, -2);
+
+ // call it w/ next param (function + param are poped from stack)
+ lua_call(L, 1, 0);
+ end;
+end;
+
+end.
\ No newline at end of file diff --git a/cmake/src/lua/ULuaGl.pas b/cmake/src/lua/ULuaGl.pas new file mode 100644 index 00000000..178853b6 --- /dev/null +++ b/cmake/src/lua/ULuaGl.pas @@ -0,0 +1,1513 @@ +{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +unit ULuaGl; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + SysUtils, + gl, + ULua; + +function luaopen_gl (L: Plua_State): Integer; cdecl; +function ULuaGl_StringToEnum(Str: String): GLenum; + +{ lua lib functions } +function ULuaGl_Begin(L: Plua_State): Integer; cdecl; +function ULuaGl_BindTexture(L: Plua_State): Integer; cdecl; +function ULuaGl_BlendFunc(L: Plua_State): Integer; cdecl; +function ULuaGl_Clear(L: Plua_State): Integer; cdecl; +function ULuaGl_ClearAccum(L: Plua_State): Integer; cdecl; +function ULuaGl_ClearColor(L: Plua_State): Integer; cdecl; +function ULuaGl_Color(L: Plua_State): Integer; cdecl; +function ULuaGl_CullFace(L: Plua_State): Integer; cdecl; +function ULuaGl_DepthFunc(L: Plua_State): Integer; cdecl; +function ULuaGl_DepthRange(L: Plua_State): Integer; cdecl; +function ULuaGl_Disable(L: Plua_State): Integer; cdecl; +function ULuaGl_DisableClientState(L: Plua_State): Integer; cdecl; +function ULuaGl_DrawBuffer(L: Plua_State): Integer; cdecl; +function ULuaGl_Enable(L: Plua_State): Integer; cdecl; +function ULuaGl_EnableClientState(L: Plua_State): Integer; cdecl; +function ULuaGl_End(L: Plua_State): Integer; cdecl; +function ULuaGl_EndList(L: Plua_State): Integer; cdecl; +function ULuaGl_Finish(L: Plua_State): Integer; cdecl; +function ULuaGl_Flush(L: Plua_State): Integer; cdecl; +function ULuaGl_FrontFace(L: Plua_State): Integer; cdecl; +function ULuaGl_InitNames(L: Plua_State): Integer; cdecl; +function ULuaGl_LoadIdentity(L: Plua_State): Integer; cdecl; +function ULuaGl_LogicOp(L: Plua_State): Integer; cdecl; +function ULuaGl_MatrixMode(L: Plua_State): Integer; cdecl; +function ULuaGl_Ortho(L: Plua_State): Integer; cdecl; +function ULuaGl_PopAttrib(L: Plua_State): Integer; cdecl; +function ULuaGl_PopClientAttrib(L: Plua_State): Integer; cdecl; +function ULuaGl_PopMatrix(L: Plua_State): Integer; cdecl; +function ULuaGl_PopName(L: Plua_State): Integer; cdecl; +function ULuaGl_PushMatrix(L: Plua_State): Integer; cdecl; +function ULuaGl_RasterPos(L: Plua_State): Integer; cdecl; +function ULuaGl_ReadBuffer(L: Plua_State): Integer; cdecl; +function ULuaGl_Rect(L: Plua_State): Integer; cdecl; +function ULuaGl_Rotate(L: Plua_State): Integer; cdecl; +function ULuaGl_Scale(L: Plua_State): Integer; cdecl; +function ULuaGl_ShadeModel(L: Plua_State): Integer; cdecl; +function ULuaGl_TexCoord(L: Plua_State): Integer; cdecl; +function ULuaGl_Translate(L: Plua_State): Integer; cdecl; +function ULuaGl_Vertex(L: Plua_State): Integer; cdecl; +function ULuaGl_Viewport(L: Plua_State): Integer; cdecl; +function ULuaGl_Dummy(L: Plua_State): Integer; cdecl; + +const + ULuaGl_Lib_f: array [0..40] of lual_reg = ( + (name:'Begin';func:ULuaGl_Begin), + (name:'BindTexture';func:ULuaGl_BindTexture), + (name:'BlendFunc';func:ULuaGl_BlendFunc), + (name:'Clear';func:ULuaGl_Clear), + (name:'ClearAccum';func:ULuaGl_ClearAccum), + (name:'ClearColor';func:ULuaGl_ClearColor), + (name:'Color';func:ULuaGl_Color), + (name:'CullFace';func:ULuaGl_CullFace), + (name:'DepthFunc';func:ULuaGl_DepthFunc), + (name:'DepthRange';func:ULuaGl_DepthRange), + (name:'Disable';func:ULuaGl_Disable), + (name:'DisableClientState';func:ULuaGl_DisableClientState), + (name:'DrawBuffer';func:ULuaGl_DrawBuffer), + (name:'Enable';func:ULuaGl_Enable), + (name:'EnableClientState';func:ULuaGl_EnableClientState), + (name:'End';func:ULuaGl_End), + (name:'EndList';func:ULuaGl_EndList), + (name:'Finish';func:ULuaGl_Finish), + (name:'Flush';func:ULuaGl_Flush), + (name:'FrontFace';func:ULuaGl_FrontFace), + (name:'InitNames';func:ULuaGl_InitNames), + (name:'LoadIdentity';func:ULuaGl_LoadIdentity), + (name:'LogicOp';func:ULuaGl_LogicOp), + (name:'MatrixMode';func:ULuaGl_MatrixMode), + (name:'Ortho';func:ULuaGl_Ortho), + (name:'PopAttrib';func:ULuaGl_PopAttrib), + (name:'PopClientAttrib';func:ULuaGl_PopClientAttrib), + (name:'PopMatrix';func:ULuaGl_PopMatrix), + (name:'PopName';func:ULuaGl_PopName), + (name:'PushMatrix';func:ULuaGl_PushMatrix), + (name:'RasterPos';func:ULuaGl_RasterPos), + (name:'ReadBuffer';func:ULuaGl_ReadBuffer), + (name:'Rotate';func:ULuaGl_Rotate), + (name:'Rect';func:ULuaGl_Rect), + (name:'Scale';func:ULuaGl_Scale), + (name:'ShadeModel';func:ULuaGl_ShadeModel), + (name:'TexCoord';func:ULuaGl_TexCoord), + (name:'Translate';func:ULuaGl_Translate), + (name:'Vertex';func:ULuaGl_Vertex), + (name:'Viewport';func:ULuaGl_Viewport), + (name:nil;func:nil) + ); + +implementation + +uses + ULog; + +type + TULuaGl_Enums = record + Text: string; + Value: GLenum; + end; +const + ULuaGl_EnumERROR = $fffffffe; + +function ULuaGl_Begin(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.Begin'''); + + glBegin(e); + + result:=0; // number of results +end; + +function ULuaGl_BindTexture(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.BindTexture'''); + + glBindTexture(e,lual_checkinteger(L,2)); + + result:=0; // number of results +end; + +function ULuaGl_BlendFunc(L: Plua_State): Integer; cdecl; +var + e : GLenum; + f : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + f := ULuaGl_StringToEnum(lual_checkstring(L,2)); + + if (e = ULuaGl_EnumERROR) or (f = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.BlendFunc'''); + + glBlendFunc(e,f); + + result:=0; // number of results +end; + +function ULuaGl_Clear(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.Clear'''); + + glClear(e); + + result:=0; // number of results +end; + +function ULuaGl_ClearAccum(L: Plua_State): Integer; cdecl; +var + i: Integer; +begin + if lua_istable(L, 1) then + for i := 1 to lua_objlen(L,1) do + lua_rawgeti(L,1,i); + + if (lua_istable(L, 1) and (lua_objlen(L,1) = 4)) or (lua_gettop(L) = 4) then + glClearAccum(lual_checknumber(L,-4), + lual_checknumber(L,-3), + lual_checknumber(L,-2), + lual_checknumber(L,-1)) + else + luaL_error(L, 'incorrect argument to function ''gl.ClearAccum'''); + result:=0; // number of results +end; + +function ULuaGl_ClearColor(L: Plua_State): Integer; cdecl; +var + i: Integer; +begin + if lua_istable(L, 1) then + for i := 1 to lua_objlen(L,1) do + lua_rawgeti(L,1,i); + + if (lua_istable(L, 1) and (lua_objlen(L,1) = 4)) or (lua_gettop(L) = 4) then + glClearColor(lual_checknumber(L,-4), + lual_checknumber(L,-3), + lual_checknumber(L,-2), + lual_checknumber(L,-1)) + else + luaL_error(L, 'incorrect argument to function ''gl.ClearColor'''); + result:=0; // number of results +end; + +function ULuaGl_Color(L: Plua_State): Integer; cdecl; +var + i: Integer; +begin + if lua_istable(L, 1) then + for i := 1 to lua_objlen(L,1) do + lua_rawgeti(L,1,i); + + if (lua_istable(L, 1) and (lua_objlen(L,1) = 3)) or (lua_gettop(L) = 3) then + glColor3d(GLdouble(lual_checknumber(L,-3)), + GLdouble(lual_checknumber(L,-2)), + GLdouble(lual_checknumber(L,-1))) + else if (lua_istable(L, 1) and (lua_objlen(L,1) = 4)) or (lua_gettop(L) = 4) then + glColor4d(GLdouble(lual_checknumber(L,-4)), + GLdouble(lual_checknumber(L,-3)), + GLdouble(lual_checknumber(L,-2)), + GLdouble(lual_checknumber(L,-1))) + else + luaL_error(L, 'incorrect argument to function ''gl.Color'''); + result:=0; // number of results +end; + +function ULuaGl_CullFace(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.CullFace'''); + + glCullFace(e); + + result:=0; // number of results +end; + +function ULuaGl_DepthFunc(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.DepthFunc'''); + + glDepthFunc(e); + + result:=0; // number of results +end; + +function ULuaGl_DepthRange(L: Plua_State): Integer; cdecl; +var + i: Integer; +begin + if lua_istable(L, 1) then + for i := 1 to lua_objlen(L,1) do + lua_rawgeti(L,1,i); + + if (lua_istable(L, 1) and (lua_objlen(L,1) = 2)) + or (lua_gettop(L) = 2) then + glDepthRange(lual_checkinteger(L,-2), + lual_checkinteger(L,-1)) + else + luaL_error(L, 'incorrect argument to function ''gl.DepthRange'''); + result:=0; // number of results +end; + +function ULuaGl_Disable(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.Disable'''); + + glDisable(e); + + result:=0; // number of results +end; + +function ULuaGl_DisableClientState(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.DisableClientState'''); + + glDisableClientState(e); + + result:=0; // number of results +end; + +function ULuaGl_DrawBuffer(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.DrawBuffer'''); + + glDrawBuffer(e); + + result:=0; // number of results +end; + +function ULuaGl_Enable(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.Enable'''); + + glEnable(e); + result:=0; // number of results +end; + +function ULuaGl_EnableClientState(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.EnableClientState'''); + + glEnableClientState(e); + + result:=0; // number of results +end; + +function ULuaGl_End(L: Plua_State): Integer; cdecl; +begin + glEnd(); + result:=0; // number of results +end; + +function ULuaGl_EndList(L: Plua_State): Integer; cdecl; +begin + glEndList(); + result:=0; // number of results +end; + +function ULuaGl_Finish(L: Plua_State): Integer; cdecl; +begin + glFinish(); + result:=0; // number of results +end; + +function ULuaGl_Flush(L: Plua_State): Integer; cdecl; +begin + glFlush(); + result:=0; // number of results +end; + +function ULuaGl_FrontFace(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.FrontFace'''); + + glFrontFace(e); + + result:=0; // number of results +end; + +function ULuaGl_InitNames(L: Plua_State): Integer; cdecl; +begin + glInitNames(); + result:=0; // number of results +end; + +function ULuaGl_LoadIdentity(L: Plua_State): Integer; cdecl; +begin + glLoadIdentity(); + result:=0; // number of results +end; + +function ULuaGl_LogicOp(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.LogicOp'''); + + glLogicOp(e); + + result:=0; // number of results +end; + +function ULuaGl_MatrixMode(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.MatrixMode'''); + + glMatrixMode(e); + + result:=0; // number of results +end; + +function ULuaGl_Ortho(L: Plua_State): Integer; cdecl; +begin + if (lua_gettop(L) = 6) then + glOrtho(lual_checkinteger(L,-6), + lual_checkinteger(L,-5), + lual_checkinteger(L,-4), + lual_checkinteger(L,-3), + lual_checkinteger(L,-2), + lual_checkinteger(L,-1)) + else + luaL_error(L, 'incorrect argument to function ''gl.Ortho'''); + result:=0; // number of results +end; + +function ULuaGl_PopAttrib(L: Plua_State): Integer; cdecl; +begin + glPopAttrib(); + result:=0; // number of results +end; + +function ULuaGl_PopClientAttrib(L: Plua_State): Integer; cdecl; +begin + glPopClientAttrib(); + result:=0; // number of results +end; + +function ULuaGl_PopMatrix(L: Plua_State): Integer; cdecl; +begin + glPopMatrix(); + result:=0; // number of results +end; + +function ULuaGl_PopName(L: Plua_State): Integer; cdecl; +begin + glPopName(); + result:=0; // number of results +end; + +function ULuaGl_PushMatrix(L: Plua_State): Integer; cdecl; +begin + glPopName(); + result:=0; // number of results +end; + +function ULuaGl_RasterPos(L: Plua_State): Integer; cdecl; +var + i: Integer; +begin + if lua_istable(L, 1) then + for i := 1 to lua_objlen(L,1) do + lua_rawgeti(L,1,i); + + if (lua_istable(L, 1) and (lua_objlen(L,1) = 2)) or (lua_gettop(L) = 2) then + glRasterPos2d(GLdouble(lual_checknumber(L,-2)), + GLdouble(lual_checknumber(L,-1))) + else if (lua_istable(L, 1) and (lua_objlen(L,1) = 3)) or (lua_gettop(L) = 3) then + glRasterPos3d(GLdouble(lual_checknumber(L,-3)), + GLdouble(lual_checknumber(L,-2)), + GLdouble(lual_checknumber(L,-1))) + else if (lua_istable(L, 1) and (lua_objlen(L,1) = 4)) or (lua_gettop(L) = 4) then + glRasterPos4d(GLdouble(lual_checknumber(L,-4)), + GLdouble(lual_checknumber(L,-3)), + GLdouble(lual_checknumber(L,-2)), + GLdouble(lual_checknumber(L,-1))) + else + luaL_error(L, 'incorrect argument to function ''gl.RasterPos'''); + result:=0; // number of results +end; + +function ULuaGl_ReadBuffer(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.ReadBuffer'''); + + glReadBuffer(e); + + result:=0; // number of results +end; + +function ULuaGl_Rect(L: Plua_State): Integer; cdecl; +var + i: Integer; +begin + if lua_istable(L, 1) and lua_istable(L, 2) then + begin + for i := 1 to lua_objlen(L,1) do + lua_rawgeti(L,1,i); + for i := 1 to lua_objlen(L,2) do + lua_rawgeti(L,2,i); + end; + + if (lua_istable(L, 1) and (lua_objlen(L,1) = 2)) + and (lua_istable(L, 2) and (lua_objlen(L,2) = 2)) + or (lua_gettop(L) = 4) then + glRectD(lual_checknumber(L,-4), + lual_checknumber(L,-3), + lual_checknumber(L,-2), + lual_checknumber(L,-1)) + else + luaL_error(L, 'incorrect argument to function ''gl.Rect'''); + result:=0; // number of results +end; + +function ULuaGl_Rotate(L: Plua_State): Integer; cdecl; +begin + if (lua_gettop(L) = 3) then + glRotated(lual_checkinteger(L,-4), + lual_checkinteger(L,-3), + lual_checkinteger(L,-2), + lual_checkinteger(L,-1)) + else + luaL_error(L, 'incorrect argument to function ''gl.Rotate'''); + result:=0; // number of results +end; + +function ULuaGl_Scale(L: Plua_State): Integer; cdecl; +begin + if (lua_gettop(L) = 3) then + glScaled(lual_checkinteger(L,-3), + lual_checkinteger(L,-2), + lual_checkinteger(L,-1)) + else + luaL_error(L, 'incorrect argument to function ''gl.Scale'''); + result:=0; // number of results +end; + +function ULuaGl_ShadeModel(L: Plua_State): Integer; cdecl; +var + e : GLenum; +begin + e := ULuaGl_StringToEnum(lual_checkstring(L,1)); + + if (e = ULuaGl_EnumERROR) then + luaL_error(L, 'incorrect string argument to function ''gl.ShadeModel'''); + + glShadeModel(e); + + result:=0; // number of results +end; + +function ULuaGl_TexCoord(L: Plua_State): Integer; cdecl; +var + i: Integer; +begin + if lua_istable(L, 1) then + for i := 1 to lua_objlen(L,1) do + lua_rawgeti(L,1,i); + + if (lua_istable(L, 1) and (lua_objlen(L,1) = 1)) or (lua_gettop(L) = 1) then + glTexCoord1d(GLdouble(lual_checknumber(L,-1))) + else if (lua_istable(L, 1) and (lua_objlen(L,1) = 2)) or (lua_gettop(L) = 2) then + glTexCoord2d(GLdouble(lual_checknumber(L,-2)), + GLdouble(lual_checknumber(L,-1))) + else if (lua_istable(L, 1) and (lua_objlen(L,1) = 3)) or (lua_gettop(L) = 3) then + glTexCoord3d(GLdouble(lual_checknumber(L,-3)), + GLdouble(lual_checknumber(L,-2)), + GLdouble(lual_checknumber(L,-1))) + else if (lua_istable(L, 1) and (lua_objlen(L,1) = 4)) or (lua_gettop(L) = 4) then + glTexCoord4d(GLdouble(lual_checknumber(L,-4)), + GLdouble(lual_checknumber(L,-3)), + GLdouble(lual_checknumber(L,-2)), + GLdouble(lual_checknumber(L,-1))) + else + luaL_error(L, 'incorrect argument to function ''gl.TexCoord'''); + result:=0; // number of results +end; + +function ULuaGl_Translate(L: Plua_State): Integer; cdecl; +begin + if (lua_gettop(L) = 3) then + glTranslated(lual_checkinteger(L,-3), + lual_checkinteger(L,-2), + lual_checkinteger(L,-1)) + else + luaL_error(L, 'incorrect argument to function ''gl.Translate'''); + result:=0; // number of results +end; + +function ULuaGl_Vertex(L: Plua_State): Integer; cdecl; +var + i: Integer; +begin + if lua_istable(L, 1) then + for i := 1 to lua_objlen(L,1) do + lua_rawgeti(L,1,i); + + if (lua_istable(L, 1) and (lua_objlen(L,1) = 2)) or (lua_gettop(L) = 2) then + glVertex2d(GLdouble(lual_checknumber(L,-2)), + GLdouble(lual_checknumber(L,-1))) + else if (lua_istable(L, 1) and (lua_objlen(L,1) = 3)) or (lua_gettop(L) = 3) then + glVertex3d(GLdouble(lual_checknumber(L,-3)), + GLdouble(lual_checknumber(L,-2)), + GLdouble(lual_checknumber(L,-1))) + else if (lua_istable(L, 1) and (lua_objlen(L,1) = 4)) or (lua_gettop(L) = 4) then + glVertex4d(GLdouble(lual_checknumber(L,-4)), + GLdouble(lual_checknumber(L,-3)), + GLdouble(lual_checknumber(L,-2)), + GLdouble(lual_checknumber(L,-1))) + else + luaL_error(L, 'incorrect argument to function ''gl.Vertex'''); + result:=0; // number of results +end; + +function ULuaGl_Viewport(L: Plua_State): Integer; cdecl; +var + i: Integer; +begin + if lua_istable(L, 1) and lua_istable(L, 2) then + begin + for i := 1 to lua_objlen(L,1) do + lua_rawgeti(L,1,i); + for i := 1 to lua_objlen(L,2) do + lua_rawgeti(L,2,i); + end; + + if (lua_istable(L, 1) and (lua_objlen(L,1) = 2)) + and (lua_istable(L, 2) and (lua_objlen(L,2) = 2)) + or (lua_gettop(L) = 4) then + glViewport(lual_checkinteger(L,-4), + lual_checkinteger(L,-3), + lual_checkinteger(L,-2), + lual_checkinteger(L,-1)) + else + luaL_error(L, 'incorrect argument to function ''gl.Viewport'''); + result:=0; // number of results +end; + +function ULuaGl_Dummy(L: Plua_State): Integer; cdecl; +begin + result:=0; // number of results +end; + +function luaopen_gl (L: Plua_State): Integer; cdecl; +begin + luaL_register(L,'gl',@ULuaGl_Lib_f[0]); + result:=1; +end; + +(* + glAccum: procedure(op: GLenum; value: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glAlphaFunc: procedure(func: GLenum; ref: GLclampf); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glAreTexturesResident: function (n: GLsizei; const textures: PGLuint; residences: PGLboolean): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glArrayElement: procedure(i: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glBitmap: procedure (width, height: GLsizei; xorig, yorig: GLfloat; xmove, ymove: GLfloat; const bitmap: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glCallList: procedure(list: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glCallLists: procedure(n: GLsizei; atype: GLenum; const lists: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glClearDepth: procedure(depth: GLclampd); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glClearIndex: procedure(c: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glClearStencil: procedure(s: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glClipPlane: procedure(plane: GLenum; const equation: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + + glColorMask: procedure(red, green, blue, alpha: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glColorMaterial: procedure(face, mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glColorPointer: procedure(size: GLint; atype: GLenum; stride: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glCopyPixels: procedure(x, y: GLint; width, height: GLsizei; atype: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glCopyTexImage1D: procedure (target: GLenum; level: GLint; internalFormat: GLenum; x, y: GLint; width: GLsizei; border: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glCopyTexImage2D: procedure(target: GLenum; level: GLint; internalFormat: GLenum; x, y: GLint; width, height: GLsizei; border: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glCopyTexSubImage1D: procedure(target: GLenum; level, xoffset, x, y: GLint; width: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glCopyTexSubImage2D: procedure(target: GLenum; level, xoffset, yoffset, x, y: GLint; width, height: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glDeleteLists: procedure(list: GLuint; range: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glDeleteTextures: procedure(n: GLsizei; const textures: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glDepthMask: procedure(flag: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glDrawArrays: procedure(mode: GLenum; first: GLint; count: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glDrawElements: procedure(mode: GLenum; count: GLsizei; atype: GLenum; const indices: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glDrawPixels: procedure(width, height: GLsizei; format, atype: GLenum; const pixels: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glEdgeFlag: procedure(flag: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glEdgeFlagPointer: procedure(stride: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glEdgeFlagv: procedure(const flag: PGLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + + glEvalCoord1d: procedure(u: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glEvalCoord1dv: procedure(const u: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glEvalCoord1f: procedure(u: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glEvalCoord1fv: procedure(const u: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glEvalCoord2d: procedure(u, v: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glEvalCoord2dv: procedure(const u: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glEvalCoord2f: procedure(u, v: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glEvalCoord2fv: procedure(const u: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + + glEvalMesh1: procedure(mode: GLenum; i1, i2: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glEvalMesh2: procedure(mode: GLenum; i1, i2, j1, j2: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glEvalPoint1: procedure(i: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glEvalPoint2: procedure(i, j: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glFeedbackBuffer: procedure(size: GLsizei; atype: GLenum; buffer: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glFogf: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glFogfv: procedure(pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glFogi: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glFogiv: procedure(pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glFrustum: procedure(left, right, bottom, top, zNear, zFar: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGenLists: function(range: GLsizei): GLuint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGenTextures: procedure(n: GLsizei; textures: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetBooleanv: procedure(pname: GLenum; params: PGLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetClipPlane: procedure(plane: GLenum; equation: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetDoublev: procedure(pname: GLenum; params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} +// glGetError: function: GLenum; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetFloatv: procedure(pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetIntegerv: procedure(pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetLightfv: procedure(light, pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetLightiv: procedure(light, pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetMapdv: procedure(target, query: GLenum; v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetMapfv: procedure(target, query: GLenum; v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetMapiv: procedure(target, query: GLenum; v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetMaterialfv: procedure(face, pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetMaterialiv: procedure(face, pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetPixelMapfv: procedure(map: GLenum; values: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetPixelMapuiv: procedure(map: GLenum; values: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetPixelMapusv: procedure(map: GLenum; values: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetPointerv: procedure(pname: GLenum; params: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetPolygonStipple: procedure(mask: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} +/ glGetString: function(name: GLenum): PChar; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetTexEnvfv: procedure(target, pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetTexEnviv: procedure(target, pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetTexGendv: procedure(coord, pname: GLenum; params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetTexGenfv: procedure(coord, pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetTexGeniv: procedure(coord, pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetTexImage: procedure(target: GLenum; level: GLint; format: GLenum; atype: GLenum; pixels: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetTexLevelParameterfv: procedure(target: GLenum; level: GLint; pname: GLenum; params: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetTexLevelParameteriv: procedure(target: GLenum; level: GLint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetTexParameterfv: procedure(target, pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glGetTexParameteriv: procedure(target, pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glHint: procedure(target, mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glIndexMask: procedure(mask: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + + glIndexPointer: procedure(atype: GLenum; stride: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glIndexd: procedure(c: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glIndexdv: procedure(const c: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glIndexf: procedure(c: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glIndexfv: procedure(const c: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glIndexi: procedure(c: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glIndexiv: procedure(const c: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glIndexs: procedure(c: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glIndexsv: procedure(const c: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glIndexub: procedure(c: GLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glIndexubv: procedure(const c: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + + glInterleavedArrays: procedure(format: GLenum; stride: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} +/ glIsEnabled: function(cap: GLenum): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glIsList: function(list: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glIsTexture: function(texture: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glLightModelf: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glLightModelfv: procedure(pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glLightModeli: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glLightModeliv: procedure(pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glLightf: procedure(light, pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glLightfv: procedure(light, pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glLighti: procedure(light, pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glLightiv: procedure(light, pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glLineStipple: procedure(factor: GLint; pattern: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glLineWidth: procedure(width: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glListBase: procedure(base: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glLoadMatrixd: procedure(const m: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glLoadMatrixf: procedure(const m: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glLoadName: procedure(name: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glMap1d: procedure(target: GLenum; u1, u2: GLdouble; stride, order: GLint; const points: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glMap1f: procedure(target: GLenum; u1, u2: GLfloat; stride, order: GLint; const points: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glMap2d: procedure(target: GLenum; u1, u2: GLdouble; ustride, uorder: GLint; v1, v2: GLdouble; vstride, vorder: GLint; const points: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glMap2f: procedure(target: GLenum; u1, u2: GLfloat; ustride, uorder: GLint; v1, v2: GLfloat; vstride, vorder: GLint; const points: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glMapGrid1d: procedure(un: GLint; u1, u2: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glMapGrid1f: procedure(un: GLint; u1, u2: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glMapGrid2d: procedure(un: GLint; u1, u2: GLdouble; vn: GLint; v1, v2: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glMapGrid2f: procedure(un: GLint; u1, u2: GLfloat; vn: GLint; v1, v2: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glMaterialf: procedure(face, pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glMaterialfv: procedure(face, pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glMateriali: procedure(face, pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glMaterialiv: procedure(face, pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glMultMatrixd: procedure(const m: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glMultMatrixf: procedure(const m: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glNewList: procedure(list: GLuint; mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glNormal3b: procedure(nx, ny, nz: GLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glNormal3bv: procedure(const v: PGLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glNormal3d: procedure(nx, ny, nz: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glNormal3dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glNormal3f: procedure(nx, ny, nz: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glNormal3fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glNormal3i: procedure(nx, ny, nz: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glNormal3iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glNormal3s: procedure(nx, ny, nz: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glNormal3sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glNormalPointer: procedure(atype: GLenum; stride: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPassThrough: procedure(token: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPixelMapfv: procedure(map: GLenum; mapsize: GLsizei; const values: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPixelMapuiv: procedure(map: GLenum; mapsize: GLsizei; const values: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPixelMapusv: procedure(map: GLenum; mapsize: GLsizei; const values: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPixelStoref: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPixelStorei: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPixelTransferf: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPixelTransferi: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPixelZoom: procedure(xfactor, yfactor: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPointSize: procedure(size: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPolygonMode: procedure(face, mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPolygonOffset: procedure(factor, units: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPolygonStipple: procedure(const mask: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPrioritizeTextures: procedure(n: GLsizei; const textures: PGLuint; const priorities: PGLclampf); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPushAttrib: procedure(mask: GLbitfield); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPushClientAttrib: procedure(mask: GLbitfield); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glPushName: procedure(name: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glReadPixels: procedure(x, y: GLint; width, height: GLsizei; format, atype: GLenum; pixels: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + + glRenderMode: function(mode: GLint): GLint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glScissor: procedure(x, y: GLint; width, height: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glSelectBuffer: procedure(size: GLsizei; buffer: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glStencilFunc: procedure(func: GLenum; ref: GLint; mask: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glStencilMask: procedure(mask: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glStencilOp: procedure(fail, zfail, zpass: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + + glTexCoordPointer: procedure(size: GLint; atype: GLenum; stride: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexEnvf: procedure(target: GLenum; pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexEnvfv: procedure(target: GLenum; pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexEnvi: procedure(target: GLenum; pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexEnviv: procedure(target: GLenum; pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexGend: procedure(coord: GLenum; pname: GLenum; param: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexGendv: procedure(coord: GLenum; pname: GLenum; const params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexGenf: procedure(coord: GLenum; pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexGenfv: procedure(coord: GLenum; pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexGeni: procedure(coord: GLenum; pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexGeniv: procedure(coord: GLenum; pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexImage1D: procedure(target: GLenum; level, internalformat: GLint; width: GLsizei; border: GLint; format, atype: GLenum; const pixels: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexImage2D: procedure(target: GLenum; level, internalformat: GLint; width, height: GLsizei; border: GLint; format, atype: GLenum; const pixels: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexParameterf: procedure(target: GLenum; pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexParameterfv: procedure(target: GLenum; pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexParameteri: procedure(target: GLenum; pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexParameteriv: procedure(target: GLenum; pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexSubImage1D: procedure(target: GLenum; level, xoffset: GLint; width: GLsizei; format, atype: GLenum; const pixels: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glTexSubImage2D: procedure(target: GLenum; level, xoffset, yoffset: GLint; width, height: GLsizei; format, atype: GLenum; const pixels: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + glVertexPointer: procedure(size: GLint; atype: GLenum; stride: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + {$IFDEF WINDOWS} + ChoosePixelFormat: function(DC: HDC; p2: PPixelFormatDescriptor): Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} + {$ENDIF} + *) + + const + ULuaGl_Enum: array [0..579] of TULuaGl_Enums = ( + (Text:'GL_VERSION_1_1';Value:GL_VERSION_1_1), + (Text:'GL_ACCUM';Value:GL_ACCUM), + (Text:'GL_LOAD';Value:GL_LOAD), + (Text:'GL_RETURN';Value:GL_RETURN), + (Text:'GL_MULT';Value:GL_MULT), + (Text:'GL_ADD';Value:GL_ADD), + (Text:'GL_NEVER';Value:GL_NEVER), + (Text:'GL_LESS';Value:GL_LESS), + (Text:'GL_EQUAL';Value:GL_EQUAL), + (Text:'GL_LEQUAL';Value:GL_LEQUAL), + (Text:'GL_GREATER';Value:GL_GREATER), + (Text:'GL_NOTEQUAL';Value:GL_NOTEQUAL), + (Text:'GL_GEQUAL';Value:GL_GEQUAL), + (Text:'GL_ALWAYS';Value:GL_ALWAYS), + (Text:'GL_CURRENT_BIT';Value:GL_CURRENT_BIT), + (Text:'GL_POINT_BIT';Value:GL_POINT_BIT), + (Text:'GL_LINE_BIT';Value:GL_LINE_BIT), + (Text:'GL_POLYGON_BIT';Value:GL_POLYGON_BIT), + (Text:'GL_POLYGON_STIPPLE_BIT';Value:GL_POLYGON_STIPPLE_BIT), + (Text:'GL_PIXEL_MODE_BIT';Value:GL_PIXEL_MODE_BIT), + (Text:'GL_LIGHTING_BIT';Value:GL_LIGHTING_BIT), + (Text:'GL_FOG_BIT';Value:GL_FOG_BIT), + (Text:'GL_DEPTH_BUFFER_BIT';Value:GL_DEPTH_BUFFER_BIT), + (Text:'GL_ACCUM_BUFFER_BIT';Value:GL_ACCUM_BUFFER_BIT), + (Text:'GL_STENCIL_BUFFER_BIT';Value:GL_STENCIL_BUFFER_BIT), + (Text:'GL_VIEWPORT_BIT';Value:GL_VIEWPORT_BIT), + (Text:'GL_TRANSFORM_BIT';Value:GL_TRANSFORM_BIT), + (Text:'GL_ENABLE_BIT';Value:GL_ENABLE_BIT), + (Text:'GL_COLOR_BUFFER_BIT';Value:GL_COLOR_BUFFER_BIT), + (Text:'GL_HINT_BIT';Value:GL_HINT_BIT), + (Text:'GL_EVAL_BIT';Value:GL_EVAL_BIT), + (Text:'GL_LIST_BIT';Value:GL_LIST_BIT), + (Text:'GL_TEXTURE_BIT';Value:GL_TEXTURE_BIT), + (Text:'GL_SCISSOR_BIT';Value:GL_SCISSOR_BIT), + (Text:'GL_ALL_ATTRIB_BITS';Value:GL_ALL_ATTRIB_BITS), + (Text:'GL_POINTS';Value:GL_POINTS), + (Text:'GL_LINES';Value:GL_LINES), + (Text:'GL_LINE_LOOP';Value:GL_LINE_LOOP), + (Text:'GL_LINE_STRIP';Value:GL_LINE_STRIP), + (Text:'GL_TRIANGLES';Value:GL_TRIANGLES), + (Text:'GL_TRIANGLE_STRIP';Value:GL_TRIANGLE_STRIP), + (Text:'GL_TRIANGLE_FAN';Value:GL_TRIANGLE_FAN), + (Text:'GL_QUADS';Value:GL_QUADS), + (Text:'GL_QUAD_STRIP';Value:GL_QUAD_STRIP), + (Text:'GL_POLYGON';Value:GL_POLYGON), + (Text:'GL_ZERO';Value:GL_ZERO), + (Text:'GL_ONE';Value:GL_ONE), + (Text:'GL_SRC_COLOR';Value:GL_SRC_COLOR), + (Text:'GL_ONE_MINUS_SRC_COLOR';Value:GL_ONE_MINUS_SRC_COLOR), + (Text:'GL_SRC_ALPHA';Value:GL_SRC_ALPHA), + (Text:'GL_ONE_MINUS_SRC_ALPHA';Value:GL_ONE_MINUS_SRC_ALPHA), + (Text:'GL_DST_ALPHA';Value:GL_DST_ALPHA), + (Text:'GL_ONE_MINUS_DST_ALPHA';Value:GL_ONE_MINUS_DST_ALPHA), + (Text:'GL_DST_COLOR';Value:GL_DST_COLOR), + (Text:'GL_ONE_MINUS_DST_COLOR';Value:GL_ONE_MINUS_DST_COLOR), + (Text:'GL_SRC_ALPHA_SATURATE';Value:GL_SRC_ALPHA_SATURATE), + (Text:'GL_TRUE';Value:GL_TRUE), + (Text:'GL_FALSE';Value:GL_FALSE), + (Text:'GL_CLIP_PLANE0';Value:GL_CLIP_PLANE0), + (Text:'GL_CLIP_PLANE1';Value:GL_CLIP_PLANE1), + (Text:'GL_CLIP_PLANE2';Value:GL_CLIP_PLANE2), + (Text:'GL_CLIP_PLANE3';Value:GL_CLIP_PLANE3), + (Text:'GL_CLIP_PLANE4';Value:GL_CLIP_PLANE4), + (Text:'GL_CLIP_PLANE5';Value:GL_CLIP_PLANE5), + (Text:'GL_BYTE';Value:GL_BYTE), + (Text:'GL_UNSIGNED_BYTE';Value:GL_UNSIGNED_BYTE), + (Text:'GL_SHORT';Value:GL_SHORT), + (Text:'GL_UNSIGNED_SHORT';Value:GL_UNSIGNED_SHORT), + (Text:'GL_INT';Value:GL_INT), + (Text:'GL_UNSIGNED_INT';Value:GL_UNSIGNED_INT), + (Text:'GL_FLOAT';Value:GL_FLOAT), + (Text:'GL_2_BYTES';Value:GL_2_BYTES), + (Text:'GL_3_BYTES';Value:GL_3_BYTES), + (Text:'GL_4_BYTES';Value:GL_4_BYTES), + (Text:'GL_DOUBLE';Value:GL_DOUBLE), + (Text:'GL_NONE';Value:GL_NONE), + (Text:'GL_FRONT_LEFT';Value:GL_FRONT_LEFT), + (Text:'GL_FRONT_RIGHT';Value:GL_FRONT_RIGHT), + (Text:'GL_BACK_LEFT';Value:GL_BACK_LEFT), + (Text:'GL_BACK_RIGHT';Value:GL_BACK_RIGHT), + (Text:'GL_FRONT';Value:GL_FRONT), + (Text:'GL_BACK';Value:GL_BACK), + (Text:'GL_LEFT';Value:GL_LEFT), + (Text:'GL_RIGHT';Value:GL_RIGHT), + (Text:'GL_FRONT_AND_BACK';Value:GL_FRONT_AND_BACK), + (Text:'GL_AUX0';Value:GL_AUX0), + (Text:'GL_AUX1';Value:GL_AUX1), + (Text:'GL_AUX2';Value:GL_AUX2), + (Text:'GL_AUX3';Value:GL_AUX3), + (Text:'GL_NO_ERROR';Value:GL_NO_ERROR), + (Text:'GL_INVALID_ENUM';Value:GL_INVALID_ENUM), + (Text:'GL_INVALID_VALUE';Value:GL_INVALID_VALUE), + (Text:'GL_INVALID_OPERATION';Value:GL_INVALID_OPERATION), + (Text:'GL_STACK_OVERFLOW';Value:GL_STACK_OVERFLOW), + (Text:'GL_STACK_UNDERFLOW';Value:GL_STACK_UNDERFLOW), + (Text:'GL_OUT_OF_MEMORY';Value:GL_OUT_OF_MEMORY), + (Text:'GL_2D';Value:GL_2D), + (Text:'GL_3D';Value:GL_3D), + (Text:'GL_3D_COLOR';Value:GL_3D_COLOR), + (Text:'GL_3D_COLOR_TEXTURE';Value:GL_3D_COLOR_TEXTURE), + (Text:'GL_4D_COLOR_TEXTURE';Value:GL_4D_COLOR_TEXTURE), + (Text:'GL_PASS_THROUGH_TOKEN';Value:GL_PASS_THROUGH_TOKEN), + (Text:'GL_POINT_TOKEN';Value:GL_POINT_TOKEN), + (Text:'GL_LINE_TOKEN';Value:GL_LINE_TOKEN), + (Text:'GL_POLYGON_TOKEN';Value:GL_POLYGON_TOKEN), + (Text:'GL_BITMAP_TOKEN';Value:GL_BITMAP_TOKEN), + (Text:'GL_DRAW_PIXEL_TOKEN';Value:GL_DRAW_PIXEL_TOKEN), + (Text:'GL_COPY_PIXEL_TOKEN';Value:GL_COPY_PIXEL_TOKEN), + (Text:'GL_LINE_RESET_TOKEN';Value:GL_LINE_RESET_TOKEN), + (Text:'GL_EXP';Value:GL_EXP), + (Text:'GL_EXP2';Value:GL_EXP2), + (Text:'GL_CW';Value:GL_CW), + (Text:'GL_CCW';Value:GL_CCW), + (Text:'GL_COEFF';Value:GL_COEFF), + (Text:'GL_ORDER';Value:GL_ORDER), + (Text:'GL_DOMAIN';Value:GL_DOMAIN), + (Text:'GL_CURRENT_COLOR';Value:GL_CURRENT_COLOR), + (Text:'GL_CURRENT_INDEX';Value:GL_CURRENT_INDEX), + (Text:'GL_CURRENT_NORMAL';Value:GL_CURRENT_NORMAL), + (Text:'GL_CURRENT_TEXTURE_COORDS';Value:GL_CURRENT_TEXTURE_COORDS), + (Text:'GL_CURRENT_RASTER_COLOR';Value:GL_CURRENT_RASTER_COLOR), + (Text:'GL_CURRENT_RASTER_INDEX';Value:GL_CURRENT_RASTER_INDEX), + (Text:'GL_CURRENT_RASTER_TEXTURE_COORDS';Value:GL_CURRENT_RASTER_TEXTURE_COORDS), + (Text:'GL_CURRENT_RASTER_POSITION';Value:GL_CURRENT_RASTER_POSITION), + (Text:'GL_CURRENT_RASTER_POSITION_VALID';Value:GL_CURRENT_RASTER_POSITION_VALID), + (Text:'GL_CURRENT_RASTER_DISTANCE';Value:GL_CURRENT_RASTER_DISTANCE), + (Text:'GL_POINT_SMOOTH';Value:GL_POINT_SMOOTH), + (Text:'GL_POINT_SIZE';Value:GL_POINT_SIZE), + (Text:'GL_POINT_SIZE_RANGE';Value:GL_POINT_SIZE_RANGE), + (Text:'GL_POINT_SIZE_GRANULARITY';Value:GL_POINT_SIZE_GRANULARITY), + (Text:'GL_LINE_SMOOTH';Value:GL_LINE_SMOOTH), + (Text:'GL_LINE_WIDTH';Value:GL_LINE_WIDTH), + (Text:'GL_LINE_WIDTH_RANGE';Value:GL_LINE_WIDTH_RANGE), + (Text:'GL_LINE_WIDTH_GRANULARITY';Value:GL_LINE_WIDTH_GRANULARITY), + (Text:'GL_LINE_STIPPLE';Value:GL_LINE_STIPPLE), + (Text:'GL_LINE_STIPPLE_PATTERN';Value:GL_LINE_STIPPLE_PATTERN), + (Text:'GL_LINE_STIPPLE_REPEAT';Value:GL_LINE_STIPPLE_REPEAT), + (Text:'GL_LIST_MODE';Value:GL_LIST_MODE), + (Text:'GL_MAX_LIST_NESTING';Value:GL_MAX_LIST_NESTING), + (Text:'GL_LIST_BASE';Value:GL_LIST_BASE), + (Text:'GL_LIST_INDEX';Value:GL_LIST_INDEX), + (Text:'GL_POLYGON_MODE';Value:GL_POLYGON_MODE), + (Text:'GL_POLYGON_SMOOTH';Value:GL_POLYGON_SMOOTH), + (Text:'GL_POLYGON_STIPPLE';Value:GL_POLYGON_STIPPLE), + (Text:'GL_EDGE_FLAG';Value:GL_EDGE_FLAG), + (Text:'GL_CULL_FACE';Value:GL_CULL_FACE), + (Text:'GL_CULL_FACE_MODE';Value:GL_CULL_FACE_MODE), + (Text:'GL_FRONT_FACE';Value:GL_FRONT_FACE), + (Text:'GL_LIGHTING';Value:GL_LIGHTING), + (Text:'GL_LIGHT_MODEL_LOCAL_VIEWER';Value:GL_LIGHT_MODEL_LOCAL_VIEWER), + (Text:'GL_LIGHT_MODEL_TWO_SIDE';Value:GL_LIGHT_MODEL_TWO_SIDE), + (Text:'GL_LIGHT_MODEL_AMBIENT';Value:GL_LIGHT_MODEL_AMBIENT), + (Text:'GL_SHADE_MODEL';Value:GL_SHADE_MODEL), + (Text:'GL_COLOR_MATERIAL_FACE';Value:GL_COLOR_MATERIAL_FACE), + (Text:'GL_COLOR_MATERIAL_PARAMETER';Value:GL_COLOR_MATERIAL_PARAMETER), + (Text:'GL_COLOR_MATERIAL';Value:GL_COLOR_MATERIAL), + (Text:'GL_FOG';Value:GL_FOG), + (Text:'GL_FOG_INDEX';Value:GL_FOG_INDEX), + (Text:'GL_FOG_DENSITY';Value:GL_FOG_DENSITY), + (Text:'GL_FOG_START';Value:GL_FOG_START), + (Text:'GL_FOG_END';Value:GL_FOG_END), + (Text:'GL_FOG_MODE';Value:GL_FOG_MODE), + (Text:'GL_FOG_COLOR';Value:GL_FOG_COLOR), + (Text:'GL_DEPTH_RANGE';Value:GL_DEPTH_RANGE), + (Text:'GL_DEPTH_TEST';Value:GL_DEPTH_TEST), + (Text:'GL_DEPTH_WRITEMASK';Value:GL_DEPTH_WRITEMASK), + (Text:'GL_DEPTH_CLEAR_VALUE';Value:GL_DEPTH_CLEAR_VALUE), + (Text:'GL_DEPTH_FUNC';Value:GL_DEPTH_FUNC), + (Text:'GL_ACCUM_CLEAR_VALUE';Value:GL_ACCUM_CLEAR_VALUE), + (Text:'GL_STENCIL_TEST';Value:GL_STENCIL_TEST), + (Text:'GL_STENCIL_CLEAR_VALUE';Value:GL_STENCIL_CLEAR_VALUE), + (Text:'GL_STENCIL_FUNC';Value:GL_STENCIL_FUNC), + (Text:'GL_STENCIL_VALUE_MASK';Value:GL_STENCIL_VALUE_MASK), + (Text:'GL_STENCIL_FAIL';Value:GL_STENCIL_FAIL), + (Text:'GL_STENCIL_PASS_DEPTH_FAIL';Value:GL_STENCIL_PASS_DEPTH_FAIL), + (Text:'GL_STENCIL_PASS_DEPTH_PASS';Value:GL_STENCIL_PASS_DEPTH_PASS), + (Text:'GL_STENCIL_REF';Value:GL_STENCIL_REF), + (Text:'GL_STENCIL_WRITEMASK';Value:GL_STENCIL_WRITEMASK), + (Text:'GL_MATRIX_MODE';Value:GL_MATRIX_MODE), + (Text:'GL_NORMALIZE';Value:GL_NORMALIZE), + (Text:'GL_VIEWPORT';Value:GL_VIEWPORT), + (Text:'GL_MODELVIEW_STACK_DEPTH';Value:GL_MODELVIEW_STACK_DEPTH), + (Text:'GL_PROJECTION_STACK_DEPTH';Value:GL_PROJECTION_STACK_DEPTH), + (Text:'GL_TEXTURE_STACK_DEPTH';Value:GL_TEXTURE_STACK_DEPTH), + (Text:'GL_MODELVIEW_MATRIX';Value:GL_MODELVIEW_MATRIX), + (Text:'GL_PROJECTION_MATRIX';Value:GL_PROJECTION_MATRIX), + (Text:'GL_TEXTURE_MATRIX';Value:GL_TEXTURE_MATRIX), + (Text:'GL_ATTRIB_STACK_DEPTH';Value:GL_ATTRIB_STACK_DEPTH), + (Text:'GL_CLIENT_ATTRIB_STACK_DEPTH';Value:GL_CLIENT_ATTRIB_STACK_DEPTH), + (Text:'GL_ALPHA_TEST';Value:GL_ALPHA_TEST), + (Text:'GL_ALPHA_TEST_FUNC';Value:GL_ALPHA_TEST_FUNC), + (Text:'GL_ALPHA_TEST_REF';Value:GL_ALPHA_TEST_REF), + (Text:'GL_DITHER';Value:GL_DITHER), + (Text:'GL_BLEND_DST';Value:GL_BLEND_DST), + (Text:'GL_BLEND_SRC';Value:GL_BLEND_SRC), + (Text:'GL_BLEND';Value:GL_BLEND), + (Text:'GL_LOGIC_OP_MODE';Value:GL_LOGIC_OP_MODE), + (Text:'GL_INDEX_LOGIC_OP';Value:GL_INDEX_LOGIC_OP), + (Text:'GL_COLOR_LOGIC_OP';Value:GL_COLOR_LOGIC_OP), + (Text:'GL_AUX_BUFFERS';Value:GL_AUX_BUFFERS), + (Text:'GL_DRAW_BUFFER';Value:GL_DRAW_BUFFER), + (Text:'GL_READ_BUFFER';Value:GL_READ_BUFFER), + (Text:'GL_SCISSOR_BOX';Value:GL_SCISSOR_BOX), + (Text:'GL_SCISSOR_TEST';Value:GL_SCISSOR_TEST), + (Text:'GL_INDEX_CLEAR_VALUE';Value:GL_INDEX_CLEAR_VALUE), + (Text:'GL_INDEX_WRITEMASK';Value:GL_INDEX_WRITEMASK), + (Text:'GL_COLOR_CLEAR_VALUE';Value:GL_COLOR_CLEAR_VALUE), + (Text:'GL_COLOR_WRITEMASK';Value:GL_COLOR_WRITEMASK), + (Text:'GL_INDEX_MODE';Value:GL_INDEX_MODE), + (Text:'GL_RGBA_MODE';Value:GL_RGBA_MODE), + (Text:'GL_DOUBLEBUFFER';Value:GL_DOUBLEBUFFER), + (Text:'GL_STEREO';Value:GL_STEREO), + (Text:'GL_RENDER_MODE';Value:GL_RENDER_MODE), + (Text:'GL_PERSPECTIVE_CORRECTION_HINT';Value:GL_PERSPECTIVE_CORRECTION_HINT), + (Text:'GL_POINT_SMOOTH_HINT';Value:GL_POINT_SMOOTH_HINT), + (Text:'GL_LINE_SMOOTH_HINT';Value:GL_LINE_SMOOTH_HINT), + (Text:'GL_POLYGON_SMOOTH_HINT';Value:GL_POLYGON_SMOOTH_HINT), + (Text:'GL_FOG_HINT';Value:GL_FOG_HINT), + (Text:'GL_TEXTURE_GEN_S';Value:GL_TEXTURE_GEN_S), + (Text:'GL_TEXTURE_GEN_T';Value:GL_TEXTURE_GEN_T), + (Text:'GL_TEXTURE_GEN_R';Value:GL_TEXTURE_GEN_R), + (Text:'GL_TEXTURE_GEN_Q';Value:GL_TEXTURE_GEN_Q), + (Text:'GL_PIXEL_MAP_I_TO_I';Value:GL_PIXEL_MAP_I_TO_I), + (Text:'GL_PIXEL_MAP_S_TO_S';Value:GL_PIXEL_MAP_S_TO_S), + (Text:'GL_PIXEL_MAP_I_TO_R';Value:GL_PIXEL_MAP_I_TO_R), + (Text:'GL_PIXEL_MAP_I_TO_G';Value:GL_PIXEL_MAP_I_TO_G), + (Text:'GL_PIXEL_MAP_I_TO_B';Value:GL_PIXEL_MAP_I_TO_B), + (Text:'GL_PIXEL_MAP_I_TO_A';Value:GL_PIXEL_MAP_I_TO_A), + (Text:'GL_PIXEL_MAP_R_TO_R';Value:GL_PIXEL_MAP_R_TO_R), + (Text:'GL_PIXEL_MAP_G_TO_G';Value:GL_PIXEL_MAP_G_TO_G), + (Text:'GL_PIXEL_MAP_B_TO_B';Value:GL_PIXEL_MAP_B_TO_B), + (Text:'GL_PIXEL_MAP_A_TO_A';Value:GL_PIXEL_MAP_A_TO_A), + (Text:'GL_PIXEL_MAP_I_TO_I_SIZE';Value:GL_PIXEL_MAP_I_TO_I_SIZE), + (Text:'GL_PIXEL_MAP_S_TO_S_SIZE';Value:GL_PIXEL_MAP_S_TO_S_SIZE), + (Text:'GL_PIXEL_MAP_I_TO_R_SIZE';Value:GL_PIXEL_MAP_I_TO_R_SIZE), + (Text:'GL_PIXEL_MAP_I_TO_G_SIZE';Value:GL_PIXEL_MAP_I_TO_G_SIZE), + (Text:'GL_PIXEL_MAP_I_TO_B_SIZE';Value:GL_PIXEL_MAP_I_TO_B_SIZE), + (Text:'GL_PIXEL_MAP_I_TO_A_SIZE';Value:GL_PIXEL_MAP_I_TO_A_SIZE), + (Text:'GL_PIXEL_MAP_R_TO_R_SIZE';Value:GL_PIXEL_MAP_R_TO_R_SIZE), + (Text:'GL_PIXEL_MAP_G_TO_G_SIZE';Value:GL_PIXEL_MAP_G_TO_G_SIZE), + (Text:'GL_PIXEL_MAP_B_TO_B_SIZE';Value:GL_PIXEL_MAP_B_TO_B_SIZE), + (Text:'GL_PIXEL_MAP_A_TO_A_SIZE';Value:GL_PIXEL_MAP_A_TO_A_SIZE), + (Text:'GL_UNPACK_SWAP_BYTES';Value:GL_UNPACK_SWAP_BYTES), + (Text:'GL_UNPACK_LSB_FIRST';Value:GL_UNPACK_LSB_FIRST), + (Text:'GL_UNPACK_ROW_LENGTH';Value:GL_UNPACK_ROW_LENGTH), + (Text:'GL_UNPACK_SKIP_ROWS';Value:GL_UNPACK_SKIP_ROWS), + (Text:'GL_UNPACK_SKIP_PIXELS';Value:GL_UNPACK_SKIP_PIXELS), + (Text:'GL_UNPACK_ALIGNMENT';Value:GL_UNPACK_ALIGNMENT), + (Text:'GL_PACK_SWAP_BYTES';Value:GL_PACK_SWAP_BYTES), + (Text:'GL_PACK_LSB_FIRST';Value:GL_PACK_LSB_FIRST), + (Text:'GL_PACK_ROW_LENGTH';Value:GL_PACK_ROW_LENGTH), + (Text:'GL_PACK_SKIP_ROWS';Value:GL_PACK_SKIP_ROWS), + (Text:'GL_PACK_SKIP_PIXELS';Value:GL_PACK_SKIP_PIXELS), + (Text:'GL_PACK_ALIGNMENT';Value:GL_PACK_ALIGNMENT), + (Text:'GL_MAP_COLOR';Value:GL_MAP_COLOR), + (Text:'GL_MAP_STENCIL';Value:GL_MAP_STENCIL), + (Text:'GL_INDEX_SHIFT';Value:GL_INDEX_SHIFT), + (Text:'GL_INDEX_OFFSET';Value:GL_INDEX_OFFSET), + (Text:'GL_RED_SCALE';Value:GL_RED_SCALE), + (Text:'GL_RED_BIAS';Value:GL_RED_BIAS), + (Text:'GL_ZOOM_X';Value:GL_ZOOM_X), + (Text:'GL_ZOOM_Y';Value:GL_ZOOM_Y), + (Text:'GL_GREEN_SCALE';Value:GL_GREEN_SCALE), + (Text:'GL_GREEN_BIAS';Value:GL_GREEN_BIAS), + (Text:'GL_BLUE_SCALE';Value:GL_BLUE_SCALE), + (Text:'GL_BLUE_BIAS';Value:GL_BLUE_BIAS), + (Text:'GL_ALPHA_SCALE';Value:GL_ALPHA_SCALE), + (Text:'GL_ALPHA_BIAS';Value:GL_ALPHA_BIAS), + (Text:'GL_DEPTH_SCALE';Value:GL_DEPTH_SCALE), + (Text:'GL_DEPTH_BIAS';Value:GL_DEPTH_BIAS), + (Text:'GL_MAX_EVAL_ORDER';Value:GL_MAX_EVAL_ORDER), + (Text:'GL_MAX_LIGHTS';Value:GL_MAX_LIGHTS), + (Text:'GL_MAX_CLIP_PLANES';Value:GL_MAX_CLIP_PLANES), + (Text:'GL_MAX_TEXTURE_SIZE';Value:GL_MAX_TEXTURE_SIZE), + (Text:'GL_MAX_PIXEL_MAP_TABLE';Value:GL_MAX_PIXEL_MAP_TABLE), + (Text:'GL_MAX_ATTRIB_STACK_DEPTH';Value:GL_MAX_ATTRIB_STACK_DEPTH), + (Text:'GL_MAX_MODELVIEW_STACK_DEPTH';Value:GL_MAX_MODELVIEW_STACK_DEPTH), + (Text:'GL_MAX_NAME_STACK_DEPTH';Value:GL_MAX_NAME_STACK_DEPTH), + (Text:'GL_MAX_PROJECTION_STACK_DEPTH';Value:GL_MAX_PROJECTION_STACK_DEPTH), + (Text:'GL_MAX_TEXTURE_STACK_DEPTH';Value:GL_MAX_TEXTURE_STACK_DEPTH), + (Text:'GL_MAX_VIEWPORT_DIMS';Value:GL_MAX_VIEWPORT_DIMS), + (Text:'GL_MAX_CLIENT_ATTRIB_STACK_DEPTH';Value:GL_MAX_CLIENT_ATTRIB_STACK_DEPTH), + (Text:'GL_SUBPIXEL_BITS';Value:GL_SUBPIXEL_BITS), + (Text:'GL_INDEX_BITS';Value:GL_INDEX_BITS), + (Text:'GL_RED_BITS';Value:GL_RED_BITS), + (Text:'GL_GREEN_BITS';Value:GL_GREEN_BITS), + (Text:'GL_BLUE_BITS';Value:GL_BLUE_BITS), + (Text:'GL_ALPHA_BITS';Value:GL_ALPHA_BITS), + (Text:'GL_DEPTH_BITS';Value:GL_DEPTH_BITS), + (Text:'GL_STENCIL_BITS';Value:GL_STENCIL_BITS), + (Text:'GL_ACCUM_RED_BITS';Value:GL_ACCUM_RED_BITS), + (Text:'GL_ACCUM_GREEN_BITS';Value:GL_ACCUM_GREEN_BITS), + (Text:'GL_ACCUM_BLUE_BITS';Value:GL_ACCUM_BLUE_BITS), + (Text:'GL_ACCUM_ALPHA_BITS';Value:GL_ACCUM_ALPHA_BITS), + (Text:'GL_NAME_STACK_DEPTH';Value:GL_NAME_STACK_DEPTH), + (Text:'GL_AUTO_NORMAL';Value:GL_AUTO_NORMAL), + (Text:'GL_MAP1_COLOR_4';Value:GL_MAP1_COLOR_4), + (Text:'GL_MAP1_INDEX';Value:GL_MAP1_INDEX), + (Text:'GL_MAP1_NORMAL';Value:GL_MAP1_NORMAL), + (Text:'GL_MAP1_TEXTURE_COORD_1';Value:GL_MAP1_TEXTURE_COORD_1), + (Text:'GL_MAP1_TEXTURE_COORD_2';Value:GL_MAP1_TEXTURE_COORD_2), + (Text:'GL_MAP1_TEXTURE_COORD_3';Value:GL_MAP1_TEXTURE_COORD_3), + (Text:'GL_MAP1_TEXTURE_COORD_4';Value:GL_MAP1_TEXTURE_COORD_4), + (Text:'GL_MAP1_VERTEX_3';Value:GL_MAP1_VERTEX_3), + (Text:'GL_MAP1_VERTEX_4';Value:GL_MAP1_VERTEX_4), + (Text:'GL_MAP2_COLOR_4';Value:GL_MAP2_COLOR_4), + (Text:'GL_MAP2_INDEX';Value:GL_MAP2_INDEX), + (Text:'GL_MAP2_NORMAL';Value:GL_MAP2_NORMAL), + (Text:'GL_MAP2_TEXTURE_COORD_1';Value:GL_MAP2_TEXTURE_COORD_1), + (Text:'GL_MAP2_TEXTURE_COORD_2';Value:GL_MAP2_TEXTURE_COORD_2), + (Text:'GL_MAP2_TEXTURE_COORD_3';Value:GL_MAP2_TEXTURE_COORD_3), + (Text:'GL_MAP2_TEXTURE_COORD_4';Value:GL_MAP2_TEXTURE_COORD_4), + (Text:'GL_MAP2_VERTEX_3';Value:GL_MAP2_VERTEX_3), + (Text:'GL_MAP2_VERTEX_4';Value:GL_MAP2_VERTEX_4), + (Text:'GL_MAP1_GRID_DOMAIN';Value:GL_MAP1_GRID_DOMAIN), + (Text:'GL_MAP1_GRID_SEGMENTS';Value:GL_MAP1_GRID_SEGMENTS), + (Text:'GL_MAP2_GRID_DOMAIN';Value:GL_MAP2_GRID_DOMAIN), + (Text:'GL_MAP2_GRID_SEGMENTS';Value:GL_MAP2_GRID_SEGMENTS), + (Text:'GL_TEXTURE_1D';Value:GL_TEXTURE_1D), + (Text:'GL_TEXTURE_2D';Value:GL_TEXTURE_2D), + (Text:'GL_FEEDBACK_BUFFER_POINTER';Value:GL_FEEDBACK_BUFFER_POINTER), + (Text:'GL_FEEDBACK_BUFFER_SIZE';Value:GL_FEEDBACK_BUFFER_SIZE), + (Text:'GL_FEEDBACK_BUFFER_TYPE';Value:GL_FEEDBACK_BUFFER_TYPE), + (Text:'GL_SELECTION_BUFFER_POINTER';Value:GL_SELECTION_BUFFER_POINTER), + (Text:'GL_SELECTION_BUFFER_SIZE';Value:GL_SELECTION_BUFFER_SIZE), + (Text:'GL_TEXTURE_WIDTH';Value:GL_TEXTURE_WIDTH), + (Text:'GL_TEXTURE_HEIGHT';Value:GL_TEXTURE_HEIGHT), + (Text:'GL_TEXTURE_INTERNAL_FORMAT';Value:GL_TEXTURE_INTERNAL_FORMAT), + (Text:'GL_TEXTURE_BORDER_COLOR';Value:GL_TEXTURE_BORDER_COLOR), + (Text:'GL_TEXTURE_BORDER';Value:GL_TEXTURE_BORDER), + (Text:'GL_DONT_CARE';Value:GL_DONT_CARE), + (Text:'GL_FASTEST';Value:GL_FASTEST), + (Text:'GL_NICEST';Value:GL_NICEST), + (Text:'GL_LIGHT0';Value:GL_LIGHT0), + (Text:'GL_LIGHT1';Value:GL_LIGHT1), + (Text:'GL_LIGHT2';Value:GL_LIGHT2), + (Text:'GL_LIGHT3';Value:GL_LIGHT3), + (Text:'GL_LIGHT4';Value:GL_LIGHT4), + (Text:'GL_LIGHT5';Value:GL_LIGHT5), + (Text:'GL_LIGHT6';Value:GL_LIGHT6), + (Text:'GL_LIGHT7';Value:GL_LIGHT7), + (Text:'GL_AMBIENT';Value:GL_AMBIENT), + (Text:'GL_DIFFUSE';Value:GL_DIFFUSE), + (Text:'GL_SPECULAR';Value:GL_SPECULAR), + (Text:'GL_POSITION';Value:GL_POSITION), + (Text:'GL_SPOT_DIRECTION';Value:GL_SPOT_DIRECTION), + (Text:'GL_SPOT_EXPONENT';Value:GL_SPOT_EXPONENT), + (Text:'GL_SPOT_CUTOFF';Value:GL_SPOT_CUTOFF), + (Text:'GL_CONSTANT_ATTENUATION';Value:GL_CONSTANT_ATTENUATION), + (Text:'GL_LINEAR_ATTENUATION';Value:GL_LINEAR_ATTENUATION), + (Text:'GL_QUADRATIC_ATTENUATION';Value:GL_QUADRATIC_ATTENUATION), + (Text:'GL_COMPILE';Value:GL_COMPILE), + (Text:'GL_COMPILE_AND_EXECUTE';Value:GL_COMPILE_AND_EXECUTE), + (Text:'GL_CLEAR';Value:GL_CLEAR), + (Text:'GL_AND';Value:GL_AND), + (Text:'GL_AND_REVERSE';Value:GL_AND_REVERSE), + (Text:'GL_COPY';Value:GL_COPY), + (Text:'GL_AND_INVERTED';Value:GL_AND_INVERTED), + (Text:'GL_NOOP';Value:GL_NOOP), + (Text:'GL_XOR';Value:GL_XOR), + (Text:'GL_OR';Value:GL_OR), + (Text:'GL_NOR';Value:GL_NOR), + (Text:'GL_EQUIV';Value:GL_EQUIV), + (Text:'GL_INVERT';Value:GL_INVERT), + (Text:'GL_OR_REVERSE';Value:GL_OR_REVERSE), + (Text:'GL_COPY_INVERTED';Value:GL_COPY_INVERTED), + (Text:'GL_OR_INVERTED';Value:GL_OR_INVERTED), + (Text:'GL_NAND';Value:GL_NAND), + (Text:'GL_SET';Value:GL_SET), + (Text:'GL_EMISSION';Value:GL_EMISSION), + (Text:'GL_SHININESS';Value:GL_SHININESS), + (Text:'GL_AMBIENT_AND_DIFFUSE';Value:GL_AMBIENT_AND_DIFFUSE), + (Text:'GL_COLOR_INDEXES';Value:GL_COLOR_INDEXES), + (Text:'GL_MODELVIEW';Value:GL_MODELVIEW), + (Text:'GL_PROJECTION';Value:GL_PROJECTION), + (Text:'GL_TEXTURE';Value:GL_TEXTURE), + (Text:'GL_COLOR';Value:GL_COLOR), + (Text:'GL_DEPTH';Value:GL_DEPTH), + (Text:'GL_STENCIL';Value:GL_STENCIL), + (Text:'GL_COLOR_INDEX';Value:GL_COLOR_INDEX), + (Text:'GL_STENCIL_INDEX';Value:GL_STENCIL_INDEX), + (Text:'GL_DEPTH_COMPONENT';Value:GL_DEPTH_COMPONENT), + (Text:'GL_RED';Value:GL_RED), + (Text:'GL_GREEN';Value:GL_GREEN), + (Text:'GL_BLUE';Value:GL_BLUE), + (Text:'GL_ALPHA';Value:GL_ALPHA), + (Text:'GL_RGB';Value:GL_RGB), + (Text:'GL_RGBA';Value:GL_RGBA), + (Text:'GL_LUMINANCE';Value:GL_LUMINANCE), + (Text:'GL_LUMINANCE_ALPHA';Value:GL_LUMINANCE_ALPHA), + (Text:'GL_BITMAP';Value:GL_BITMAP), + (Text:'GL_POINT';Value:GL_POINT), + (Text:'GL_LINE';Value:GL_LINE), + (Text:'GL_FILL';Value:GL_FILL), + (Text:'GL_RENDER';Value:GL_RENDER), + (Text:'GL_FEEDBACK';Value:GL_FEEDBACK), + (Text:'GL_SELECT';Value:GL_SELECT), + (Text:'GL_FLAT';Value:GL_FLAT), + (Text:'GL_SMOOTH';Value:GL_SMOOTH), + (Text:'GL_KEEP';Value:GL_KEEP), + (Text:'GL_REPLACE';Value:GL_REPLACE), + (Text:'GL_INCR';Value:GL_INCR), + (Text:'GL_DECR';Value:GL_DECR), + (Text:'GL_VENDOR';Value:GL_VENDOR), + (Text:'GL_RENDERER';Value:GL_RENDERER), + (Text:'GL_VERSION';Value:GL_VERSION), + (Text:'GL_EXTENSIONS';Value:GL_EXTENSIONS), + (Text:'GL_S';Value:GL_S), + (Text:'GL_T';Value:GL_T), + (Text:'GL_R';Value:GL_R), + (Text:'GL_Q';Value:GL_Q), + (Text:'GL_MODULATE';Value:GL_MODULATE), + (Text:'GL_DECAL';Value:GL_DECAL), + (Text:'GL_TEXTURE_ENV_MODE';Value:GL_TEXTURE_ENV_MODE), + (Text:'GL_TEXTURE_ENV_COLOR';Value:GL_TEXTURE_ENV_COLOR), + (Text:'GL_TEXTURE_ENV';Value:GL_TEXTURE_ENV), + (Text:'GL_EYE_LINEAR';Value:GL_EYE_LINEAR), + (Text:'GL_OBJECT_LINEAR';Value:GL_OBJECT_LINEAR), + (Text:'GL_SPHERE_MAP';Value:GL_SPHERE_MAP), + (Text:'GL_TEXTURE_GEN_MODE';Value:GL_TEXTURE_GEN_MODE), + (Text:'GL_OBJECT_PLANE';Value:GL_OBJECT_PLANE), + (Text:'GL_EYE_PLANE';Value:GL_EYE_PLANE), + (Text:'GL_NEAREST';Value:GL_NEAREST), + (Text:'GL_LINEAR';Value:GL_LINEAR), + (Text:'GL_NEAREST_MIPMAP_NEAREST';Value:GL_NEAREST_MIPMAP_NEAREST), + (Text:'GL_LINEAR_MIPMAP_NEAREST';Value:GL_LINEAR_MIPMAP_NEAREST), + (Text:'GL_NEAREST_MIPMAP_LINEAR';Value:GL_NEAREST_MIPMAP_LINEAR), + (Text:'GL_LINEAR_MIPMAP_LINEAR';Value:GL_LINEAR_MIPMAP_LINEAR), + (Text:'GL_TEXTURE_MAG_FILTER';Value:GL_TEXTURE_MAG_FILTER), + (Text:'GL_TEXTURE_MIN_FILTER';Value:GL_TEXTURE_MIN_FILTER), + (Text:'GL_TEXTURE_WRAP_S';Value:GL_TEXTURE_WRAP_S), + (Text:'GL_TEXTURE_WRAP_T';Value:GL_TEXTURE_WRAP_T), + (Text:'GL_CLAMP';Value:GL_CLAMP), + (Text:'GL_REPEAT';Value:GL_REPEAT), + (Text:'GL_CLIENT_PIXEL_STORE_BIT';Value:GL_CLIENT_PIXEL_STORE_BIT), + (Text:'GL_CLIENT_VERTEX_ARRAY_BIT';Value:GL_CLIENT_VERTEX_ARRAY_BIT), + (Text:'GL_CLIENT_ALL_ATTRIB_BITS';Value:GL_CLIENT_ALL_ATTRIB_BITS), + (Text:'GL_POLYGON_OFFSET_FACTOR';Value:GL_POLYGON_OFFSET_FACTOR), + (Text:'GL_POLYGON_OFFSET_UNITS';Value:GL_POLYGON_OFFSET_UNITS), + (Text:'GL_POLYGON_OFFSET_POINT';Value:GL_POLYGON_OFFSET_POINT), + (Text:'GL_POLYGON_OFFSET_LINE';Value:GL_POLYGON_OFFSET_LINE), + (Text:'GL_POLYGON_OFFSET_FILL';Value:GL_POLYGON_OFFSET_FILL), + (Text:'GL_ALPHA4';Value:GL_ALPHA4), + (Text:'GL_ALPHA8';Value:GL_ALPHA8), + (Text:'GL_ALPHA12';Value:GL_ALPHA12), + (Text:'GL_ALPHA16';Value:GL_ALPHA16), + (Text:'GL_LUMINANCE4';Value:GL_LUMINANCE4), + (Text:'GL_LUMINANCE8';Value:GL_LUMINANCE8), + (Text:'GL_LUMINANCE12';Value:GL_LUMINANCE12), + (Text:'GL_LUMINANCE16';Value:GL_LUMINANCE16), + (Text:'GL_LUMINANCE4_ALPHA4';Value:GL_LUMINANCE4_ALPHA4), + (Text:'GL_LUMINANCE6_ALPHA2';Value:GL_LUMINANCE6_ALPHA2), + (Text:'GL_LUMINANCE8_ALPHA8';Value:GL_LUMINANCE8_ALPHA8), + (Text:'GL_LUMINANCE12_ALPHA4';Value:GL_LUMINANCE12_ALPHA4), + (Text:'GL_LUMINANCE12_ALPHA12';Value:GL_LUMINANCE12_ALPHA12), + (Text:'GL_LUMINANCE16_ALPHA16';Value:GL_LUMINANCE16_ALPHA16), + (Text:'GL_INTENSITY';Value:GL_INTENSITY), + (Text:'GL_INTENSITY4';Value:GL_INTENSITY4), + (Text:'GL_INTENSITY8';Value:GL_INTENSITY8), + (Text:'GL_INTENSITY12';Value:GL_INTENSITY12), + (Text:'GL_INTENSITY16';Value:GL_INTENSITY16), + (Text:'GL_R3_G3_B2';Value:GL_R3_G3_B2), + (Text:'GL_RGB4';Value:GL_RGB4), + (Text:'GL_RGB5';Value:GL_RGB5), + (Text:'GL_RGB8';Value:GL_RGB8), + (Text:'GL_RGB10';Value:GL_RGB10), + (Text:'GL_RGB12';Value:GL_RGB12), + (Text:'GL_RGB16';Value:GL_RGB16), + (Text:'GL_RGBA2';Value:GL_RGBA2), + (Text:'GL_RGBA4';Value:GL_RGBA4), + (Text:'GL_RGB5_A1';Value:GL_RGB5_A1), + (Text:'GL_RGBA8';Value:GL_RGBA8), + (Text:'GL_RGB10_A2';Value:GL_RGB10_A2), + (Text:'GL_RGBA12';Value:GL_RGBA12), + (Text:'GL_RGBA16';Value:GL_RGBA16), + (Text:'GL_TEXTURE_RED_SIZE';Value:GL_TEXTURE_RED_SIZE), + (Text:'GL_TEXTURE_GREEN_SIZE';Value:GL_TEXTURE_GREEN_SIZE), + (Text:'GL_TEXTURE_BLUE_SIZE';Value:GL_TEXTURE_BLUE_SIZE), + (Text:'GL_TEXTURE_ALPHA_SIZE';Value:GL_TEXTURE_ALPHA_SIZE), + (Text:'GL_TEXTURE_LUMINANCE_SIZE';Value:GL_TEXTURE_LUMINANCE_SIZE), + (Text:'GL_TEXTURE_INTENSITY_SIZE';Value:GL_TEXTURE_INTENSITY_SIZE), + (Text:'GL_PROXY_TEXTURE_1D';Value:GL_PROXY_TEXTURE_1D), + (Text:'GL_PROXY_TEXTURE_2D';Value:GL_PROXY_TEXTURE_2D), + (Text:'GL_TEXTURE_PRIORITY';Value:GL_TEXTURE_PRIORITY), + (Text:'GL_TEXTURE_RESIDENT';Value:GL_TEXTURE_RESIDENT), + (Text:'GL_TEXTURE_BINDING_1D';Value:GL_TEXTURE_BINDING_1D), + (Text:'GL_TEXTURE_BINDING_2D';Value:GL_TEXTURE_BINDING_2D), + (Text:'GL_VERTEX_ARRAY';Value:GL_VERTEX_ARRAY), + (Text:'GL_NORMAL_ARRAY';Value:GL_NORMAL_ARRAY), + (Text:'GL_COLOR_ARRAY';Value:GL_COLOR_ARRAY), + (Text:'GL_INDEX_ARRAY';Value:GL_INDEX_ARRAY), + (Text:'GL_TEXTURE_COORD_ARRAY';Value:GL_TEXTURE_COORD_ARRAY), + (Text:'GL_EDGE_FLAG_ARRAY';Value:GL_EDGE_FLAG_ARRAY), + (Text:'GL_VERTEX_ARRAY_SIZE';Value:GL_VERTEX_ARRAY_SIZE), + (Text:'GL_VERTEX_ARRAY_TYPE';Value:GL_VERTEX_ARRAY_TYPE), + (Text:'GL_VERTEX_ARRAY_STRIDE';Value:GL_VERTEX_ARRAY_STRIDE), + (Text:'GL_NORMAL_ARRAY_TYPE';Value:GL_NORMAL_ARRAY_TYPE), + (Text:'GL_NORMAL_ARRAY_STRIDE';Value:GL_NORMAL_ARRAY_STRIDE), + (Text:'GL_COLOR_ARRAY_SIZE';Value:GL_COLOR_ARRAY_SIZE), + (Text:'GL_COLOR_ARRAY_TYPE';Value:GL_COLOR_ARRAY_TYPE), + (Text:'GL_COLOR_ARRAY_STRIDE';Value:GL_COLOR_ARRAY_STRIDE), + (Text:'GL_INDEX_ARRAY_TYPE';Value:GL_INDEX_ARRAY_TYPE), + (Text:'GL_INDEX_ARRAY_STRIDE';Value:GL_INDEX_ARRAY_STRIDE), + (Text:'GL_TEXTURE_COORD_ARRAY_SIZE';Value:GL_TEXTURE_COORD_ARRAY_SIZE), + (Text:'GL_TEXTURE_COORD_ARRAY_TYPE';Value:GL_TEXTURE_COORD_ARRAY_TYPE), + (Text:'GL_TEXTURE_COORD_ARRAY_STRIDE';Value:GL_TEXTURE_COORD_ARRAY_STRIDE), + (Text:'GL_EDGE_FLAG_ARRAY_STRIDE';Value:GL_EDGE_FLAG_ARRAY_STRIDE), + (Text:'GL_VERTEX_ARRAY_POINTER';Value:GL_VERTEX_ARRAY_POINTER), + (Text:'GL_NORMAL_ARRAY_POINTER';Value:GL_NORMAL_ARRAY_POINTER), + (Text:'GL_COLOR_ARRAY_POINTER';Value:GL_COLOR_ARRAY_POINTER), + (Text:'GL_INDEX_ARRAY_POINTER';Value:GL_INDEX_ARRAY_POINTER), + (Text:'GL_TEXTURE_COORD_ARRAY_POINTER';Value:GL_TEXTURE_COORD_ARRAY_POINTER), + (Text:'GL_EDGE_FLAG_ARRAY_POINTER';Value:GL_EDGE_FLAG_ARRAY_POINTER), + (Text:'GL_V2F';Value:GL_V2F), + (Text:'GL_V3F';Value:GL_V3F), + (Text:'GL_C4UB_V2F';Value:GL_C4UB_V2F), + (Text:'GL_C4UB_V3F';Value:GL_C4UB_V3F), + (Text:'GL_C3F_V3F';Value:GL_C3F_V3F), + (Text:'GL_N3F_V3F';Value:GL_N3F_V3F), + (Text:'GL_C4F_N3F_V3F';Value:GL_C4F_N3F_V3F), + (Text:'GL_T2F_V3F';Value:GL_T2F_V3F), + (Text:'GL_T4F_V4F';Value:GL_T4F_V4F), + (Text:'GL_T2F_C4UB_V3F';Value:GL_T2F_C4UB_V3F), + (Text:'GL_T2F_C3F_V3F';Value:GL_T2F_C3F_V3F), + (Text:'GL_T2F_N3F_V3F';Value:GL_T2F_N3F_V3F), + (Text:'GL_T2F_C4F_N3F_V3F';Value:GL_T2F_C4F_N3F_V3F), + (Text:'GL_T4F_C4F_N3F_V4F';Value:GL_T4F_C4F_N3F_V4F), + (Text:'GL_EXT_vertex_array';Value:GL_EXT_vertex_array), + (Text:'GL_WIN_swap_hint';Value:GL_WIN_swap_hint), + (Text:'GL_EXT_bgra';Value:GL_EXT_bgra), + (Text:'GL_EXT_paletted_texture';Value:GL_EXT_paletted_texture), + (Text:'GL_VERTEX_ARRAY_EXT';Value:GL_VERTEX_ARRAY_EXT), + (Text:'GL_NORMAL_ARRAY_EXT';Value:GL_NORMAL_ARRAY_EXT), + (Text:'GL_COLOR_ARRAY_EXT';Value:GL_COLOR_ARRAY_EXT), + (Text:'GL_INDEX_ARRAY_EXT';Value:GL_INDEX_ARRAY_EXT), + (Text:'GL_TEXTURE_COORD_ARRAY_EXT';Value:GL_TEXTURE_COORD_ARRAY_EXT), + (Text:'GL_EDGE_FLAG_ARRAY_EXT';Value:GL_EDGE_FLAG_ARRAY_EXT), + (Text:'GL_VERTEX_ARRAY_SIZE_EXT';Value:GL_VERTEX_ARRAY_SIZE_EXT), + (Text:'GL_VERTEX_ARRAY_TYPE_EXT';Value:GL_VERTEX_ARRAY_TYPE_EXT), + (Text:'GL_VERTEX_ARRAY_STRIDE_EXT';Value:GL_VERTEX_ARRAY_STRIDE_EXT), + (Text:'GL_VERTEX_ARRAY_COUNT_EXT';Value:GL_VERTEX_ARRAY_COUNT_EXT), + (Text:'GL_NORMAL_ARRAY_TYPE_EXT';Value:GL_NORMAL_ARRAY_TYPE_EXT), + (Text:'GL_NORMAL_ARRAY_STRIDE_EXT';Value:GL_NORMAL_ARRAY_STRIDE_EXT), + (Text:'GL_NORMAL_ARRAY_COUNT_EXT';Value:GL_NORMAL_ARRAY_COUNT_EXT), + (Text:'GL_COLOR_ARRAY_SIZE_EXT';Value:GL_COLOR_ARRAY_SIZE_EXT), + (Text:'GL_COLOR_ARRAY_TYPE_EXT';Value:GL_COLOR_ARRAY_TYPE_EXT), + (Text:'GL_COLOR_ARRAY_STRIDE_EXT';Value:GL_COLOR_ARRAY_STRIDE_EXT), + (Text:'GL_COLOR_ARRAY_COUNT_EXT';Value:GL_COLOR_ARRAY_COUNT_EXT), + (Text:'GL_INDEX_ARRAY_TYPE_EXT';Value:GL_INDEX_ARRAY_TYPE_EXT), + (Text:'GL_INDEX_ARRAY_STRIDE_EXT';Value:GL_INDEX_ARRAY_STRIDE_EXT), + (Text:'GL_INDEX_ARRAY_COUNT_EXT';Value:GL_INDEX_ARRAY_COUNT_EXT), + (Text:'GL_TEXTURE_COORD_ARRAY_SIZE_EXT';Value:GL_TEXTURE_COORD_ARRAY_SIZE_EXT), + (Text:'GL_TEXTURE_COORD_ARRAY_TYPE_EXT';Value:GL_TEXTURE_COORD_ARRAY_TYPE_EXT), + (Text:'GL_TEXTURE_COORD_ARRAY_STRIDE_EXT';Value:GL_TEXTURE_COORD_ARRAY_STRIDE_EXT), + (Text:'GL_TEXTURE_COORD_ARRAY_COUNT_EXT';Value:GL_TEXTURE_COORD_ARRAY_COUNT_EXT), + (Text:'GL_EDGE_FLAG_ARRAY_STRIDE_EXT';Value:GL_EDGE_FLAG_ARRAY_STRIDE_EXT), + (Text:'GL_EDGE_FLAG_ARRAY_COUNT_EXT';Value:GL_EDGE_FLAG_ARRAY_COUNT_EXT), + (Text:'GL_VERTEX_ARRAY_POINTER_EXT';Value:GL_VERTEX_ARRAY_POINTER_EXT), + (Text:'GL_NORMAL_ARRAY_POINTER_EXT';Value:GL_NORMAL_ARRAY_POINTER_EXT), + (Text:'GL_COLOR_ARRAY_POINTER_EXT';Value:GL_COLOR_ARRAY_POINTER_EXT), + (Text:'GL_INDEX_ARRAY_POINTER_EXT';Value:GL_INDEX_ARRAY_POINTER_EXT), + (Text:'GL_TEXTURE_COORD_ARRAY_POINTER_EXT';Value:GL_TEXTURE_COORD_ARRAY_POINTER_EXT), + (Text:'GL_EDGE_FLAG_ARRAY_POINTER_EXT';Value:GL_EDGE_FLAG_ARRAY_POINTER_EXT), + (Text:'GL_DOUBLE_EXT';Value:GL_DOUBLE_EXT), + (Text:'GL_BGR_EXT';Value:GL_BGR_EXT), + (Text:'GL_BGRA_EXT';Value:GL_BGRA_EXT), + (Text:'GL_COLOR_TABLE_FORMAT_EXT';Value:GL_COLOR_TABLE_FORMAT_EXT), + (Text:'GL_COLOR_TABLE_WIDTH_EXT';Value:GL_COLOR_TABLE_WIDTH_EXT), + (Text:'GL_COLOR_TABLE_RED_SIZE_EXT';Value:GL_COLOR_TABLE_RED_SIZE_EXT), + (Text:'GL_COLOR_TABLE_GREEN_SIZE_EXT';Value:GL_COLOR_TABLE_GREEN_SIZE_EXT), + (Text:'GL_COLOR_TABLE_BLUE_SIZE_EXT';Value:GL_COLOR_TABLE_BLUE_SIZE_EXT), + (Text:'GL_COLOR_TABLE_ALPHA_SIZE_EXT';Value:GL_COLOR_TABLE_ALPHA_SIZE_EXT), + (Text:'GL_COLOR_TABLE_LUMINANCE_SIZE_EXT';Value:GL_COLOR_TABLE_LUMINANCE_SIZE_EXT), + (Text:'GL_COLOR_TABLE_INTENSITY_SIZE_EXT';Value:GL_COLOR_TABLE_INTENSITY_SIZE_EXT), + (Text:'GL_COLOR_INDEX1_EXT';Value:GL_COLOR_INDEX1_EXT), + (Text:'GL_COLOR_INDEX2_EXT';Value:GL_COLOR_INDEX2_EXT), + (Text:'GL_COLOR_INDEX4_EXT';Value:GL_COLOR_INDEX4_EXT), + (Text:'GL_COLOR_INDEX8_EXT';Value:GL_COLOR_INDEX8_EXT), + (Text:'GL_COLOR_INDEX12_EXT';Value:GL_COLOR_INDEX12_EXT), + (Text:'GL_COLOR_INDEX16_EXT';Value:GL_COLOR_INDEX16_EXT) + ); + +function ULuaGl_StringToEnum(Str: String): GLenum; + function GetEnum(const Str: String): GLenum; + var + i : Integer; + begin + for i := 0 to high(ULuaGl_Enum) do + begin + if 0 = AnsiCompareText(Str, ULuaGl_Enum[i].Text) then + begin + Result := ULuaGl_Enum[i].Value; + Exit; + end; + end; + Result := ULuaGl_EnumERROR; + end; + var + i : Integer; + j : Integer; + temp : GLenum; +begin + Result := 0; + j := 1; + for i := 1 to Length(Str) do + begin + if Str[i] = ',' then + begin + temp := GetEnum(Copy(Str,j,i-j)); + if temp <> ULuaGl_EnumERROR then + Result := Result or temp; + j := i + 1; + end; + end; + + temp := GetEnum(Copy(Str,j,MaxInt)); + if (temp = ULuaGl_EnumERROR) then + begin + if Result = 0 then + Result := ULuaGl_EnumERROR; + exit; + end; + Result := Result or temp; +end; +end. + diff --git a/cmake/src/lua/ULuaLog.pas b/cmake/src/lua/ULuaLog.pas new file mode 100644 index 00000000..95efaa19 --- /dev/null +++ b/cmake/src/lua/ULuaLog.pas @@ -0,0 +1,167 @@ +{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +unit ULuaLog; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + SysUtils, + ULog, + ULua; + +function luaopen_Log (L: Plua_State): Integer; cdecl; + +function ULuaLog_LogError(L: Plua_State): Integer; cdecl; +function ULuaLog_LogMsg(L: Plua_State): Integer; cdecl; +function ULuaLog_BenchmarkStart(L: Plua_State): Integer; cdecl; +function ULuaLog_BenchmarkEnd(L: Plua_State): Integer; cdecl; +function ULuaLog_LogBenchmark(L: Plua_State): Integer; cdecl; +function ULuaLog_LogDebug(L: Plua_State): Integer; cdecl; +function ULuaLog_LogInfo(L: Plua_State): Integer; cdecl; +function ULuaLog_LogStatus(L: Plua_State): Integer; cdecl; +function ULuaLog_LogWarn(L: Plua_State): Integer; cdecl; +function ULuaLog_LogCritical(L: Plua_State): Integer; cdecl; +function ULuaLog_CriticalError(L: Plua_State): Integer; cdecl; +function ULuaLog_GetLogLevel(L: Plua_State): Integer; cdecl; +function ULuaLog_SetLogLevel(L: Plua_State): Integer; cdecl; + + +const + ULuaLog_Lib_f: array [0..13] of lual_reg = ( + (name:'LogError';func:ULuaLog_LogError), + (name:'LogMsg';func:ULuaLog_LogMsg), + (name:'BenchmarkStart';func:ULuaLog_BenchmarkStart), + (name:'BenchmarkEnd';func:ULuaLog_BenchmarkEnd), + (name:'LogBenchmark';func:ULuaLog_LogBenchmark), + (name:'LogDebug';func:ULuaLog_LogDebug), + (name:'LogInfo';func:ULuaLog_LogInfo), + (name:'LogStatus';func:ULuaLog_LogStatus), + (name:'LogWarn';func:ULuaLog_LogWarn), + (name:'LogCritical';func:ULuaLog_LogCritical), + (name:'CriticalError';func:ULuaLog_CriticalError), + (name:'SetLogLevel';func:ULuaLog_GetLogLevel), + (name:'GetLogLevel';func:ULuaLog_SetLogLevel), + (name:nil;func:nil) + ); + +implementation + +function ULuaLog_LogError(L: Plua_State): Integer; cdecl; +begin + if (lua_gettop(L) > 1) then + Log.LogError(luaL_checkstring(L,-2),luaL_checkstring(L,-1)) + else + Log.LogError(luaL_checkstring(L,-1)); + result:=0; // number of results +end; + +function ULuaLog_LogMsg(L: Plua_State): Integer; cdecl; +begin + if (lua_gettop(L) > 2) then + Log.LogMsg(luaL_checkstring(L,-3),luaL_checkstring(L,-1),luaL_checkinteger(L,-2)) + else + Log.LogMsg(luaL_checkstring(L,-2),luaL_checkinteger(L,-1)); + result:=0; // number of results +end; + +function ULuaLog_BenchmarkStart(L: Plua_State): Integer; cdecl; +begin + Log.BenchmarkStart(luaL_checkinteger(L,-1)); + result:=0; // number of results +end; + +function ULuaLog_BenchmarkEnd(L: Plua_State): Integer; cdecl; +begin + Log.BenchmarkEnd(luaL_checkinteger(L,-1)); + result:=0; // number of results +end; + +function ULuaLog_LogBenchmark(L: Plua_State): Integer; cdecl; +begin + Log.LogBenchmark(luaL_checkstring(L,-2),luaL_checkinteger(L,-1)); + result:=0; // number of results +end; + +function ULuaLog_LogDebug(L: Plua_State): Integer; cdecl; +begin + Log.LogDebug(luaL_checkstring(L,-2),luaL_checkstring(L,-1)); + result:=0; // number of results +end; + +function ULuaLog_LogInfo(L: Plua_State): Integer; cdecl; +begin + Log.LogInfo(luaL_checkstring(L,-2),luaL_checkstring(L,-1)); + result:=0; // number of results +end; + +function ULuaLog_LogStatus(L: Plua_State): Integer; cdecl; +begin + Log.LogStatus(luaL_checkstring(L,-2),luaL_checkstring(L,-1)); + result:=0; // number of results +end; + +function ULuaLog_LogWarn(L: Plua_State): Integer; cdecl; +begin + Log.LogWarn(luaL_checkstring(L,-2),luaL_checkstring(L,-1)); + result:=0; // number of results +end; + +function ULuaLog_LogCritical(L: Plua_State): Integer; cdecl; +begin + Log.LogCritical(luaL_checkstring(L,-2),luaL_checkstring(L,-1)); + result:=0; // number of results +end; + +function ULuaLog_CriticalError(L: Plua_State): Integer; cdecl; +begin + Log.CriticalError(luaL_checkstring(L,-1)); + result:=0; // number of results +end; + +function ULuaLog_GetLogLevel(L: Plua_State): Integer; cdecl; +begin + lua_pushinteger(L,Log.GetLogLevel()); + result:=1; // number of results +end; + +function ULuaLog_SetLogLevel(L: Plua_State): Integer; cdecl; +begin + Log.SetLogLevel(luaL_checkinteger(L,-1)); + result:=0; // number of results +end; + +function luaopen_Log (L: Plua_State): Integer; cdecl; +begin + luaL_register(L,'Log',@ULuaLog_Lib_f[0]); + result:=1; +end; +end. diff --git a/cmake/src/lua/ULuaParty.pas b/cmake/src/lua/ULuaParty.pas new file mode 100644 index 00000000..69096e97 --- /dev/null +++ b/cmake/src/lua/ULuaParty.pas @@ -0,0 +1,391 @@ +{* UltraStar Deluxe - Karaoke Game
+ *
+ * UltraStar Deluxe is the legal property of its developers, whose names
+ * are too numerous to list here. Please refer to the COPYRIGHT
+ * file distributed with this source distribution.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301, USA.
+ *
+ * $URL$
+ * $Id$
+ *}
+
+unit ULuaParty;
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+{$ENDIF}
+
+{$I switches.inc}
+
+uses ULua;
+
+{ lua c functions from Party table. Enables creating of party modes w/ lua scripts }
+
+{ Party.Register - register party mode at party manager
+ arguments: info: table
+ Name: String; //< Name used as identifier (language strings, etc.). Has to be set.
+ CanNonParty: Boolean //< mode is playable when not in party mode. defaulted to false if not set
+ CanParty: Boolean //< mode is playable in party mode. defaulted to false if not set
+ PlayerCount: Table //< playable with one, two, three etc. players per team. defaulted to no restrictions if not set. (use table constructor e.g. {1, 2, 3) means playable w/ 1, 2 or three players)
+ TeamCount: Table //< playable with one, two, three etc. different teams. defaulted to no restrictions if not set. (use table constructor e.g. {1, 2, 3) means playable w/ 1, 2 or three players)
+
+ BeforeSongSelect: String //< name of global that will be called before song select screen is shown (if nil, not callable or returns true, default action will be executed)
+ AfterSongSelect: String //< name of global that will be called after song is selected (if nil, not callable or returns true, default action will be executed)
+
+ BeforeSing: String //< name of global that will be called before song select screen is shown (if nil, not callable or returns true, default action will be executed)
+ OnSing: String //< name of global that will be called before song select screen is shown (if nil, not callable or returns true, default action will be executed)
+ AfterSing: String //< name of global that will be called before song select screen is shown (if nil, not callable or returns true, default action will be executed)}
+function ULuaParty_Register(L: Plua_State): Integer; cdecl;
+
+{ Party.GameFinished - returns true if no party game is running or all rounds
+ of current game were played }
+function ULuaParty_GameFinished(L: Plua_State): Integer; cdecl;
+
+(* Party.SetRoundRanking - sets ranking of current party round,
+ arguments: Ranking: table
+ ranking of team i is the value (integer from 1 to number of teams) of the
+ table with index [i: number].
+ you may call this function in the following way:
+ Party.SetRoundRanking({3, 1, 2});
+ this means: team 1 is ranked third, team 2 is ranked first and team 3 is
+ ranked second.
+ if no party game is started or party game is finished
+ it will raise an error *)
+function ULuaParty_SetRoundRanking(L: Plua_State): Integer; cdecl;
+
+{ Party.GetTeams - returns a table with all information and structure as
+ in the TPartyGame.Teams array }
+function ULuaParty_GetTeams(L: Plua_State): Integer; cdecl;
+
+{ Party.SetTeams - changes all fields from TPartyGame.Teams that have been
+ set in the table given as first argument}
+function ULuaParty_SetTeams(L: Plua_State): Integer; cdecl;
+
+const
+ ULuaParty_Lib_f: array [0..4] of lual_reg = (
+ (name:'Register'; func:ULuaParty_Register),
+ (name:'GameFinished'; func:ULuaParty_GameFinished),
+ (name:'SetRoundRanking'; func:ULuaParty_SetRoundRanking),
+ (name:'GetTeams'; func:ULuaParty_GetTeams),
+ (name:'SetTeams'; func:ULuaParty_SetTeams)
+ );
+
+implementation
+uses ULuaCore, ULuaUtils, UParty, SysUtils;
+
+
+{ Party.Register - register party mode at party manager
+ arguments: info: table
+ Name: String; //< Name used as identifier (language strings, etc.). Has to be set.
+ CanNonParty: Boolean //< mode is playable when not in party mode. defaulted to false if not set
+ CanParty: Boolean //< mode is playable in party mode. defaulted to false if not set
+ PlayerCount: Table //< playable with one, two, three etc. players per team. defaulted to no restrictions if not set. (use table constructor e.g. {1, 2, 3) means playable w/ 1, 2 or three players)
+ TeamCount: Table //< playable with one, two, three etc. different teams. defaulted to no restrictions if not set. (use table constructor e.g. {1, 2, 3) means playable w/ 1, 2 or three players)
+
+ BeforeSongSelect: String //< name of global that will be called before song select screen is shown (if nil, not callable or returns true, default action will be executed)
+ AfterSongSelect: String //< name of global that will be called after song is selected (if nil, not callable or returns true, default action will be executed)
+
+ BeforeSing: String //< name of global that will be called before song select screen is shown (if nil, not callable or returns true, default action will be executed)
+ OnSing: String //< name of global that will be called before song select screen is shown (if nil, not callable or returns true, default action will be executed)
+ AfterSing: String //< name of global that will be called before song select screen is shown (if nil, not callable or returns true, default action will be executed)}
+function ULuaParty_Register(L: Plua_State): Integer; cdecl;
+ var
+ Info: TParty_ModeInfo;
+ Key: String;
+ P: TLuaPlugin;
+begin
+ Result := 0;
+
+ // check for table on stack
+ luaL_checkType(L, 1, LUA_TTABLE);
+
+ // get parent id
+ P := Lua_GetOwner(L);
+
+
+ // set mode info to default
+ Party.DefaultModeInfo(Info);
+
+
+ // set parent in info rec and pop it from stack
+ Info.Parent := P.Id;
+
+ // go through table elements
+ lua_pushNil(L);
+ while (lua_Next(L, 1) <> 0) do
+ begin
+ Key := lowercase(lua_ToString(L, -2));
+
+ if (Key = 'name') and lua_isString(L, -1) then
+ Info.Name := lua_toString(L, -1)
+ else if (Key = 'cannonparty') and lua_isBoolean(L, -1) then
+ Info.CanNonParty := lua_toBoolean(L, -1)
+ else if (Key = 'canparty') and lua_isBoolean(L, -1) then
+ Info.CanParty := lua_toBoolean(L, -1)
+ else if (Key = 'playercount') and lua_isTable(L, -1) then
+ Info.PlayerCount := lua_toBinInt(L, -1)
+ else if (Key = 'teamcount') and lua_isTable(L, -1) then
+ Info.TeamCount := lua_toBinInt(L, -1)
+ else if (Key = 'beforesongselect') and lua_isString(L, -1) then
+ Info.Functions.BeforeSongSelect := lua_toString(L, -1)
+ else if (Key = 'aftersongselect') and lua_isString(L, -1) then
+ Info.Functions.AfterSongSelect := lua_toString(L, -1)
+ else if (Key = 'beforesing') and lua_isString(L, -1) then
+ Info.Functions.BeforeSing := lua_toString(L, -1)
+ else if (Key = 'onsing') and lua_isString(L, -1) then
+ Info.Functions.OnSing := lua_toString(L, -1)
+ else if (Key = 'aftersing') and lua_isString(L, -1) then
+ Info.Functions.AfterSing := lua_toString(L, -1);
+
+ // pop value from stack so key is on top
+ lua_pop(L, 1);
+ end;
+
+ // clear stack from table
+ lua_pop(L, lua_gettop(L));
+
+ if not Party.RegisterMode(Info) then
+ luaL_error(L, PChar('can''t register party mode at party manager in Party.Register. Is Info.Name defined or is there another mode with this name?'));
+end;
+
+{ Party.GameFinished - returns true if no party game is running or all rounds
+ of current game were played }
+function ULuaParty_GameFinished(L: Plua_State): Integer; cdecl;
+begin
+ // clear stack
+ lua_pop(L, lua_gettop(L));
+
+ // push result
+ lua_pushBoolean(L, Party.GameFinished);
+
+ //we return one value
+ Result := 1;
+end;
+
+{ Party.SetRoundRanking - sets ranking of current party round,
+ if no party game is started or party game is finished
+ it will raise an error }
+function ULuaParty_SetRoundRanking(L: Plua_State): Integer; cdecl;
+var
+ R: AParty_TeamRanking;
+ I: Integer;
+ Rank: Integer;
+begin
+ Result := 0;
+
+ luaL_checktype(L, 1, LUA_TTABLE);
+
+ lua_checkstack(L, 1);
+
+ SetLength(R, Length(Party.Teams));
+
+ for I := 0 to High(R) do
+ begin
+ lua_pushInteger(L, (I+1));
+ lua_gettable(L, 1);
+
+ R[I].Rank := Length(R);
+ R[I].Team := I;
+ if (lua_isnumber(L, -1)) then
+ begin
+ Rank := lua_toInteger(L, -1);
+ if (Rank >= 1) and (Rank <= Length(R)) then
+ R[I].Rank := Rank
+ end;
+
+ lua_pop(L, 1);
+
+ end;
+
+ // pop table
+ lua_pop(L, 1);
+
+ if (not Party.SetRanking(R)) then
+ luaL_error(L, PChar('cann''t set party round ranking. Is party started and not finished yet?'));
+end;
+
+{ Party.GetTeams - returns a table with all information and structure as
+ in the TPartyGame.Teams array }
+function ULuaParty_GetTeams(L: Plua_State): Integer; cdecl;
+ var
+ Team: Integer;
+ Player: Integer;
+begin
+ // clear stack
+ lua_pop(L, lua_gettop(L));
+
+ // ensure we have enough stack slots left
+ lua_checkstack(L, 7);
+
+ // create the table we want to return
+ lua_createtable(L, Length(Party.Teams), 0);
+
+ // add the teams
+ for Team := 0 to High(Party.Teams) do
+ begin
+ // push key for current teams value. lua array beggins at 1
+ lua_pushInteger(L, Team + 1);
+
+ // push table containing team info and players table
+ lua_createtable(L, 0, 5);
+
+ // team name
+ lua_pushString(L, PChar(Party.Teams[Team].Name));
+ lua_setField(L, -2, 'Name');
+
+ // team score
+ lua_pushInteger(L, Party.Teams[Team].Score);
+ lua_setField(L, -2, 'Score');
+
+ // team jokers left
+ lua_pushInteger(L, Party.Teams[Team].JokersLeft);
+ lua_setField(L, -2, 'JokersLeft');
+
+ // team nextPlayer
+ lua_pushInteger(L, Party.Teams[Team].NextPlayer);
+ lua_setField(L, -2, 'NextPlayer');
+
+ // team players table
+ lua_createtable(L, Length(Party.Teams[Team].Players), 0);
+
+ //add players
+ for Player := 0 to High(Party.Teams[Team].Players) do
+ begin
+ // push key for current players value. lua array beggins at 1
+ lua_pushInteger(L, Player + 1);
+
+ // push table containing player info
+ lua_createTable(L, 0, 2);
+
+ // player name
+ lua_PushString(L, PChar(Party.Teams[Team].Players[Player].Name));
+ lua_SetField(L, -2, 'Name');
+
+ // players times played
+ lua_PushInteger(L, Party.Teams[Team].Players[Player].TimesPlayed);
+ lua_SetField(L, -2, 'TimesPlayed');
+
+ // add value - key - pair to teams player table
+ lua_setTable(L, -3);
+ end;
+
+ lua_setField(L, -2, 'Players');
+
+ // add value - key - pair to returned table
+ lua_setTable(L, -3);
+ end;
+
+ // we return 1 value (the first table)
+ Result := 1;
+end;
+
+{ Party.SetTeams - changes all fields from TPartyGame.Teams that have been
+ set in the table given as first argument}
+function ULuaParty_SetTeams(L: Plua_State): Integer; cdecl;
+
+ procedure Do_Player(Team, Player: Integer);
+ var
+ Key: String;
+ begin
+ if (Player >= 0) and (Player <= High(Party.Teams[Team].Players)) then
+ begin
+ // go through table elements
+ lua_pushNil(L);
+ while (lua_Next(L, -2) <> 0) do
+ begin
+ Key := lowercase(lua_ToString(L, -2));
+
+ if (Key = 'name') and lua_isString(L, -1) then
+ Party.Teams[Team].Players[Player].Name := lua_toString(L, -1)
+ else if (Key = 'timesplayed') and lua_isNumber(L, -1) then
+ Party.Teams[Team].Players[Player].TimesPlayed := lua_toInteger(L, -1);
+
+ // pop value from stack so key is on top
+ lua_pop(L, 1);
+ end;
+ end;
+ end;
+
+ procedure Do_Players(Team: Integer);
+ begin
+ // go through table elements
+ lua_pushNil(L);
+ while (lua_Next(L, -2) <> 0) do
+ begin
+ // check if key is a number and value is a table
+ if (lua_isNumber(L, -2)) and (lua_isTable(L, -1)) then
+ Do_Player(Team, lua_toInteger(L, -2));
+
+ // pop value from stack so key is on top
+ lua_pop(L, 1);
+ end;
+ end;
+
+ procedure Do_Team(Team: Integer);
+ var
+ Key: String;
+ begin
+ if (Team >= 0) and (Team <= High(Party.Teams)) then
+ begin
+ // go through table elements
+ lua_pushNil(L);
+ while (lua_Next(L, -2) <> 0) do
+ begin
+ Key := lowercase(lua_ToString(L, -2));
+
+ if (Key = 'name') and lua_isString(L, -1) then
+ Party.Teams[Team].Name := lua_toString(L, -1)
+ else if (Key = 'score') and lua_isNumber(L, -1) then
+ Party.Teams[Team].Score := lua_toInteger(L, -1)
+ else if (Key = 'jokersleft') and lua_isNumber(L, -1) then
+ Party.Teams[Team].JokersLeft := lua_toInteger(L, -1)
+ else if (Key = 'currentplayer') and lua_isNumber(L, -1) then
+ Party.Teams[Team].NextPlayer := lua_toInteger(L, -1)
+ else if (Key = 'players') and lua_isTable(L, -1) then
+ Do_Players(Team);
+
+ // pop value from stack so key is on top
+ lua_pop(L, 1);
+ end;
+ end;
+ end;
+begin
+ Result := 0;
+
+ // check for table on stack
+ luaL_checkType(L, 1, LUA_TTABLE);
+
+
+ // go through table elements
+ lua_pushNil(L);
+ while (lua_Next(L, 1) <> 0) do
+ begin
+ // check if key is a number and value is a table
+ if (lua_isNumber(L, -2)) and (lua_isTable(L, -1)) then
+ Do_Team(lua_toInteger(L, -2));
+
+ // pop value from stack so key is on top
+ lua_pop(L, 1);
+ end;
+
+ // clear stack from table
+ lua_pop(L, lua_gettop(L));
+end;
+
+end.
\ No newline at end of file diff --git a/cmake/src/lua/ULuaScreenSing.pas b/cmake/src/lua/ULuaScreenSing.pas new file mode 100644 index 00000000..7e17224c --- /dev/null +++ b/cmake/src/lua/ULuaScreenSing.pas @@ -0,0 +1,489 @@ +{* UltraStar Deluxe - Karaoke Game
+ *
+ * UltraStar Deluxe is the legal property of its developers, whose names
+ * are too numerous to list here. Please refer to the COPYRIGHT
+ * file distributed with this source distribution.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301, USA.
+ *
+ * $URL: https://ultrastardx.svn.sourceforge.net/svnroot/ultrastardx/branches/experimental/Lua/src/lua/ULuaTexture.pas $
+ * $Id: ULuaTexture.pas 1551 2009-01-04 14:08:33Z Hawkear $
+ *}
+
+unit ULuaScreenSing;
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+{$ENDIF}
+
+{$I switches.inc}
+
+uses
+ ULua;
+
+{ returns a table with following structure:
+ t[1..playercount] = score of player i }
+function ULuaScreenSing_GetScores(L: Plua_State): Integer; cdecl;
+
+{ returns a table with following structure:
+ t[1..playercount] = rating of player i range: [0..1] }
+function ULuaScreenSing_GetRating(L: Plua_State): Integer; cdecl;
+
+{ returns a table with following structure:
+ t[1..playercount] = rect of players score background: table(x, y, w, h) }
+function ULuaScreenSing_GetScoreBGRect(L: Plua_State): Integer; cdecl;
+
+{ returns a table with following structure:
+ t[1..playercount] = rect of players rating bar: table(x, y, w, h) }
+function ULuaScreenSing_GetRBRect(L: Plua_State): Integer; cdecl;
+
+{ ScreenSing.GetBPM - no arguments
+ returns the beats per minutes of the current song in quarts }
+function ULuaScreenSing_GetBPM(L: Plua_State): Integer; cdecl;
+
+{ ScreenSing.BeatsToSeconds(Beats: float)
+ returns the time in seconds that the given number of beats (in quarts) last }
+function ULuaScreenSing_BeatsToSeconds(L: Plua_State): Integer; cdecl;
+
+{ ScreenSing.SecondsToBeats(Seconds: float)
+ returns the Beats in quarts that the given seconds last }
+function ULuaScreenSing_SecondsToBeats(L: Plua_State): Integer; cdecl;
+
+{ ScreenSing.GetBeat() - returns current beat of lyricstate (in quarts) }
+function ULuaScreenSing_GetBeat(L: Plua_State): Integer; cdecl;
+
+{ finishes current song, if sing screen is not shown it will raise
+ an error }
+function ULuaScreenSing_Finish(L: Plua_State): Integer; cdecl;
+
+{ ScreenSing.GetSettings - no arguments
+ returns a table filled with the data of TScreenSing.Settings }
+function ULuaScreenSing_GetSettings(L: Plua_State): Integer; cdecl;
+
+{ ScreenSing.SetSettings - arguments: Table
+ sets all attributes of TScreenSing.Settings that are
+ unequal to nil in Table }
+function ULuaScreenSing_SetSettings(L: Plua_State): Integer; cdecl;
+
+{ ScreenSing.GetSongLines - no arguments
+ returns a table filled with lines of the loaded song or
+ nil if no song is loaded (singscreen is not displayed)
+ structure of returned table:
+ array [1.."count of lines"]
+ \
+ | Start: integer - beat the line is displayed at (on top of lyrics display)
+ | Lyric: string - full lyric of the line
+ | Notes: array [1.."count notes of this line"]
+ \
+ | Start: integer - beat the note starts at
+ | Length: integer - length in beats
+ | Tone: integer - pitch that has to be sung, full range
+ | NoteType: integer - 0 for freestyle, 1 for normal, 2 for golden
+ | Text: string - text of this fragment }
+function ULuaScreenSing_GetSongLines(L: Plua_State): Integer; cdecl;
+
+const
+ ULuaScreenSing_Lib_f: array [0..11] of lual_reg = (
+ (name:'GetScores';func:ULuaScreenSing_GetScores),
+ (name:'GetRating';func:ULuaScreenSing_GetRating),
+ (name:'GetBPM';func:ULuaScreenSing_GetBPM),
+ (name:'BeatsToSeconds';func:ULuaScreenSing_BeatsToSeconds),
+ (name:'SecondsToBeats';func:ULuaScreenSing_SecondsToBeats),
+ (name:'GetBeat';func:ULuaScreenSing_GetBeat),
+ (name:'GetScoreBGRect';func:ULuaScreenSing_GetScoreBGRect),
+ (name:'GetRBRect';func:ULuaScreenSing_GetRBRect),
+ (name:'Finish';func:ULuaScreenSing_Finish),
+ (name:'GetSettings';func:ULuaScreenSing_GetSettings),
+ (name:'SetSettings';func:ULuaScreenSing_SetSettings),
+ (name:'GetSongLines';func:ULuaScreenSing_GetSongLines)
+ );
+
+implementation
+uses UScreenSing, UNote, UDisplay, UGraphic, UMusic, ULuaUtils, SysUtils;
+
+{ returns a table with following structure:
+ t[1..playercount] = score of player i }
+function ULuaScreenSing_GetScores(L: Plua_State): Integer; cdecl;
+ var
+ Top: Integer;
+ I: Integer;
+begin
+ Result := 1;
+
+ // pop arguments
+ Top := lua_getTop(L);
+ if (Top > 0) then
+ lua_pop(L, Top);
+
+ // create table
+ lua_createtable(L, Length(Player), 0);
+
+ // fill w/ values
+ for I := 0 to High(Player) do
+ begin
+ lua_pushInteger(L, I + 1);
+ lua_pushInteger(L, Player[I].ScoreTotalInt);
+
+ lua_settable(L, -3);
+ end;
+
+ // leave table on stack, it is our result
+end;
+
+{ returns a table with following structure:
+ t[1..playercount] = rating of player i range: [0..1] }
+function ULuaScreenSing_GetRating(L: Plua_State): Integer; cdecl;
+ var
+ Top: Integer;
+ I: Integer;
+begin
+ Result := 1;
+
+ // pop arguments
+ Top := lua_getTop(L);
+ if (Top > 0) then
+ lua_pop(L, Top);
+
+ // create table
+ lua_createtable(L, Length(Player), 0);
+
+ // fill w/ values
+ for I := 0 to High(ScreenSing.Scores.Players) do
+ begin
+ lua_pushInteger(L, I + 1);
+ lua_pushNumber(L, ScreenSing.Scores.Players[I].RBPos);
+
+ lua_settable(L, -3);
+ end;
+
+ // leave table on stack, it is our result
+end;
+
+{ ScreenSing.GetBPM - no arguments
+ returns the beats per minutes of the current song in quarts }
+function ULuaScreenSing_GetBPM(L: Plua_State): Integer; cdecl;
+begin
+ lua_ClearStack(L);
+ Result := 1;
+
+ if (CurrentSong = nil) or (Length(CurrentSong.BPM) = 0) or (Display.CurrentScreen <> @ScreenSing) then
+ lua_PushNumber(L, 0) // in case of error
+ else if (Length(CurrentSong.BPM) = 1) then
+ lua_PushNumber(L, CurrentSong.BPM[0].BPM)
+ else
+ begin
+ // to-do: do this for songs w/ BPM changes
+ // or drop support for BPM changes?!
+ end;
+end;
+
+{ ScreenSing.BeatsToSeconds(Beats: float)
+ returns the time in seconds that the given number of beats (in quarts) last }
+function ULuaScreenSing_BeatsToSeconds(L: Plua_State): Integer; cdecl;
+begin
+ Result := 1;
+
+ if (CurrentSong = nil) or (Length(CurrentSong.BPM) = 0) or (Display.CurrentScreen <> @ScreenSing) then
+ lua_PushNumber(L, 0) // in case of error
+ else if (Length(CurrentSong.BPM) = 1) then
+ lua_PushNumber(L, luaL_CheckNumber(L, 1) * 60 / CurrentSong.BPM[0].BPM)
+ else
+ begin
+ // to-do: do this for songs w/ BPM changes
+ // or drop support for BPM changes?!
+ end;
+end;
+
+{ ScreenSing.BeatsToSeconds(Seconds: float)
+ returns the Beats in quarts that the given seconds last }
+function ULuaScreenSing_SecondsToBeats(L: Plua_State): Integer; cdecl;
+begin
+ Result := 1;
+
+ if (CurrentSong = nil) or (Length(CurrentSong.BPM) = 0) or (Display.CurrentScreen <> @ScreenSing) then
+ lua_PushNumber(L, 0)
+ else if (Length(CurrentSong.BPM) = 1) then
+ lua_PushNumber(L, luaL_CheckNumber(L, 1) * CurrentSong.BPM[0].BPM / 60)
+ else
+ begin
+ // to-do: do this for songs w/ BPM changes
+ // or drop support for BPM changes?!
+ end;
+end;
+
+{ ScreenSing.GetBeat() - returns current beat of lyricstate (in quarts) }
+function ULuaScreenSing_GetBeat(L: Plua_State): Integer; cdecl;
+var top: Integer;
+begin
+ //remove arguments (if any)
+ top := lua_gettop(L);
+
+ if (top > 0) then
+ lua_pop(L, top);
+
+ //push result
+ lua_pushnumber(L, LyricsState.MidBeat);
+ Result := 1; //one result
+end;
+
+{ returns a table with following structure:
+ t[1..playercount] = rect of players ScoreBG: table(x, y, w, h) }
+function ULuaScreenSing_GetScoreBGRect(L: Plua_State): Integer; cdecl;
+ var
+ Top: Integer;
+ I: Integer;
+begin
+ Result := 1;
+
+ // pop arguments
+ Top := lua_getTop(L);
+ if (Top > 0) then
+ lua_pop(L, Top);
+
+ // create table
+ lua_createtable(L, Length(ScreenSing.Scores.Players), 0);
+
+ // fill w/ values
+ for I := 0 to High(ScreenSing.Scores.Players) do
+ begin
+ lua_pushInteger(L, I + 1);
+
+ if (ScreenSing.Scores.Players[I].Position = High(Byte)) then
+ // player has no position, prevent crash by pushing nil
+ lua_pushNil(L)
+ else
+ with ScreenSing.Scores.Positions[ScreenSing.Scores.Players[I].Position] do
+ lua_PushRect(L, BGX, BGY, BGW, BGH);
+
+
+ lua_settable(L, -3);
+ end;
+
+ // leave table on stack, it is our result
+end;
+
+{ returns a table with following structure:
+ t[1..playercount] = rect of players rating bar: table(x, y, w, h) }
+function ULuaScreenSing_GetRBRect(L: Plua_State): Integer; cdecl;
+ var
+ Top: Integer;
+ I: Integer;
+begin
+ Result := 1;
+
+ // pop arguments
+ Top := lua_getTop(L);
+ if (Top > 0) then
+ lua_pop(L, Top);
+
+ // create table
+ lua_createtable(L, Length(ScreenSing.Scores.Players), 0);
+
+ // fill w/ values
+ for I := 0 to High(ScreenSing.Scores.Players) do
+ begin
+ lua_pushInteger(L, I + 1);
+
+ if (ScreenSing.Scores.Players[I].Position = High(Byte)) then
+ // player has no position, prevent crash by pushing nil
+ lua_pushNil(L)
+ else
+ with ScreenSing.Scores.Positions[ScreenSing.Scores.Players[I].Position] do
+ lua_PushRect(L, RBX, RBY, RBW, RBH);
+
+
+ lua_settable(L, -3);
+ end;
+
+ // leave table on stack, it is our result
+end;
+
+{ finishes current song, if sing screen is not shown it will raise
+ an error }
+function ULuaScreenSing_Finish(L: Plua_State): Integer; cdecl;
+ var Top: Integer;
+begin
+ Result := 0;
+
+ // pop arguments
+ Top := lua_getTop(L);
+ if (Top > 0) then
+ lua_pop(L, Top);
+
+ if (Display.CurrentScreen^ = ScreenSing) then
+ begin
+ ScreenSing.EndSong;
+ end
+ else
+ LuaL_error(L, 'Usdx.ScreenSing.Finish is called, but sing screen is not shown.');
+end;
+
+{ ScreenSing.GetSettings - no arguments
+ returns a table filled with the data of TScreenSing }
+function ULuaScreenSing_GetSettings(L: Plua_State): Integer; cdecl;
+ var Top: Integer;
+begin
+ // pop arguments
+ Top := lua_getTop(L);
+ if (Top > 0) then
+ lua_pop(L, Top);
+
+ lua_createtable(L, 0, 3);
+
+ //fill table w/ info
+ lua_pushBoolean(L, ScreenSing.Settings.LyricsVisible);
+ lua_setField(L, -2, 'LyricsVisible');
+
+ lua_pushBinInt(L, ScreenSing.Settings.NotesVisible);
+ lua_setField(L, -2, 'NotesVisible');
+
+ lua_pushBinInt(L, ScreenSing.Settings.PlayerEnabled);
+ lua_setField(L, -2, 'PlayerEnabled');
+
+
+ Result := 1;
+end;
+
+{ ScreenSing.SetSettings - arguments: Table
+ sets all attributes of TScreenSing.Settings that are
+ unequal to nil in Table }
+function ULuaScreenSing_SetSettings(L: Plua_State): Integer; cdecl;
+ var
+ Key: String;
+begin
+ Result := 0;
+
+ // check for table on stack
+ luaL_checkType(L, 1, LUA_TTABLE);
+
+ // go through table elements
+ lua_pushNil(L);
+ while (lua_Next(L, 1) <> 0) do
+ begin
+ Key := lowercase(lua_ToString(L, -2));
+
+ if (Key = 'lyricsvisible') and (lua_isBoolean(L, -1)) then
+ ScreenSing.settings.LyricsVisible := lua_toBoolean(L, -1)
+ else if (Key = 'notesvisible') and (lua_isTable(L, -1)) then
+ ScreenSing.settings.NotesVisible := lua_toBinInt(L, -1)
+ else if (Key = 'playerenabled') and (lua_isTable(L, -1)) then
+ ScreenSing.settings.PlayerEnabled := lua_toBinInt(L, -1);
+
+ // pop value from stack so key is on top
+ lua_pop(L, 1);
+ end;
+
+ // clear stack from table
+ lua_pop(L, lua_gettop(L));
+
+ ScreenSing.ApplySettings;
+end;
+
+{ ScreenSing.GetSongLines - no arguments
+ returns a table filled with lines of the loaded song or
+ nil if no song is loaded (singscreen is not displayed)
+ structure of returned table:
+ array [1.."count of lines"]
+ \
+ | Start: integer - beat the line is displayed at (on top of lyrics display)
+ | Lyric: string - full lyric of the line
+ | Notes: array [1.."count notes of this line"]
+ \
+ | Start: integer - beat the note starts at
+ | Length: integer - length in beats
+ | Tone: integer - pitch that has to be sung, full range
+ | NoteType: integer - 0 for freestyle, 1 for normal, 2 for golden
+ | Text: string - text of this fragment }
+function ULuaScreenSing_GetSongLines(L: Plua_State): Integer; cdecl;
+ var
+ I, J: Integer;
+begin
+ Result := 1;
+ if (Length(Lines) >= 1) then
+ begin
+ lua_ClearStack(L);
+
+ if not lua_CheckStack(L, 7) then
+ luaL_Error(L, PChar('can''t allocate enough stack space in ULuaScreenSing_GetSongLines'));
+
+ // lines array table
+ lua_CreateTable(L, Length(Lines[0].Line), 0);
+
+ for I := 0 to High(Lines[0].Line) do
+ with Lines[0].Line[I] do
+ begin
+ lua_pushInteger(L, I+1);
+
+ // line struct table
+ lua_CreateTable(L, 0, 3);
+
+ // line start
+ lua_PushInteger(L, Start);
+ lua_SetField(L, -2, PChar('Start'));
+
+ // line lyric
+ lua_PushString(L, PChar(Lyric));
+ lua_SetField(L, -2, PChar('Lyric'));
+
+ //line notes array table
+ lua_CreateTable(L, Length(Note), 0);
+
+ for J := 0 to High(Note) do
+ begin
+ lua_PushInteger(L, J + 1);
+
+ // note struct table
+ lua_CreateTable(L, 0, 5);
+
+ // Notes[J+1].Start
+ lua_PushInteger(L, Note[J].Start);
+ lua_SetField(L, -2, PChar('Start'));
+
+ // Notes[J+1].Length
+ lua_PushInteger(L, Note[J].Length);
+ lua_SetField(L, -2, PChar('Length'));
+
+ // Notes[J+1].Tone
+ lua_PushInteger(L, Note[J].Tone);
+ lua_SetField(L, -2, PChar('Tone'));
+
+ // Notes[J+1].NoteType
+ lua_PushInteger(L, Integer(Note[J].NoteType));
+ lua_SetField(L, -2, PChar('NoteType'));
+
+ // Notes[J+1].Text
+ lua_PushString(L, PChar(Note[J].Text));
+ lua_SetField(L, -2, PChar('Text'));
+
+ lua_SetTable(L, -3);
+ end;
+
+ lua_SetField(L, -2, PChar('Notes'));
+
+ // save line to array table
+ lua_setTable(L, -3);
+ end;
+ end
+ else
+ begin
+ lua_ClearStack(L);
+ lua_pushNil(L);
+ end;
+end;
+
+end.
\ No newline at end of file diff --git a/cmake/src/lua/ULuaTextGL.pas b/cmake/src/lua/ULuaTextGL.pas new file mode 100644 index 00000000..2e70a2c1 --- /dev/null +++ b/cmake/src/lua/ULuaTextGL.pas @@ -0,0 +1,148 @@ +{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +unit ULuaTextGL; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + TextGL, + SysUtils, + ULua; + +{ TextGl.Pos(X, Y: Float) : sets font position } +function ULuaTextGL_Pos(L: Plua_State): Integer; cdecl; + +{ TextGl.Size(Size: Float) : sets font size } +function ULuaTextGL_Size(L: Plua_State): Integer; cdecl; + +{ TextGl.Style(Style: int) : sets font style (from 0 to 3) } +function ULuaTextGL_Style(L: Plua_State): Integer; cdecl; + +{ TextGl.Italic(isItalic: boolean) : sets if font is italic } +function ULuaTextGL_Italic(L: Plua_State): Integer; cdecl; + +{ TextGl.Width(Text: String) : returns width of Text if printed + w/ current settings in pixels } +function ULuaTextGL_Width(L: Plua_State): Integer; cdecl; + +{ TextGl.Print(Text: String) : prints text to screen w/ current + settings} +function ULuaTextGL_Print(L: Plua_State): Integer; cdecl; + +const + ULuaTextGl_Lib_f: array [0..5] of lual_reg = ( + (name:'Pos'; func:ULuaTextGl_Pos), + (name:'Size'; func:ULuaTextGl_Size), + (name:'Style'; func:ULuaTextGl_Style), + (name:'Italic'; func:ULuaTextGl_Italic), + (name:'Width'; func:ULuaTextGl_Width), + (name:'Print'; func:ULuaTextGl_Print) + ); + + +implementation + +{ TextGl.Pos(X, Y: Float) : sets font position } +function ULuaTextGL_Pos(L: Plua_State): Integer; cdecl; + var X, Y: Double; +begin + X := luaL_checknumber(L, 1); + Y := luaL_checknumber(L, 2); + + SetFontPos(X, Y); + + Result := 0; +end; + +{ TextGl.Size(Size: Float) : sets font size } +function ULuaTextGL_Size(L: Plua_State): Integer; cdecl; + var Size: Double; +begin + Size := luaL_checknumber(L, 1); + + SetFontSize(Size); + + Result := 0; +end; + +{ TextGl.Style(Style: int) : sets font style (from 0 to 3) } +function ULuaTextGL_Style(L: Plua_State): Integer; cdecl; + var Style: Integer; +begin + Style := luaL_checkinteger(L, 1); + + if (Style >= 0) and (Style < Length(Fonts)) then + SetFontStyle(Style) + else + luaL_ArgError(L, 1, PChar('number from 0 to ' + IntToStr(High(Fonts)) + ' expected')); + + Result := 0; +end; + +{ TextGl.Italic(isItalic: boolean) : sets if font is italic } +function ULuaTextGL_Italic(L: Plua_State): Integer; cdecl; + var isItalic: Boolean; +begin + luaL_checkany(L, 1); + isItalic := lua_toBoolean(L, 1); + + SetFontItalic(isItalic); + + Result := 0; +end; + +{ TextGl.Width(Text: String) : returns width of Text if printed + w/ current settings in pixels } +function ULuaTextGL_Width(L: Plua_State): Integer; cdecl; + var Text: String; +begin + Text := luaL_checkstring(L, 1); + lua_pop(L, lua_gettop(L)); + + lua_PushNumber(L, glTextWidth(Text)); + + Result := 1; +end; + +{ TextGl.Print(Text: String) : prints text to screen w/ current + settings} +function ULuaTextGL_Print(L: Plua_State): Integer; cdecl; + var Text: String; +begin + Text := luaL_checkstring(L, 1); + + glPrint(Text); + + Result := 0; +end; + +end. diff --git a/cmake/src/lua/ULuaTexture.pas b/cmake/src/lua/ULuaTexture.pas new file mode 100644 index 00000000..931c0405 --- /dev/null +++ b/cmake/src/lua/ULuaTexture.pas @@ -0,0 +1,63 @@ +{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +unit ULuaTexture; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + SysUtils, + ULua, + UTexture; + +function luaopen_Texture (L: Plua_State): Integer; cdecl; + +function ULuaTexture_Dummy(L: Plua_State): Integer; cdecl; + +implementation + +function ULuaTexture_Dummy(L: Plua_State): Integer; cdecl; +begin + result:=0; // number of results +end; + +const + ULuaTexture_Lib_f: array [0..1] of lual_reg = ( + (name:'Add';func:ULuaTexture_Dummy), + (name:nil;func:nil) + ); + +function luaopen_Texture (L: Plua_State): Integer; cdecl; +begin + luaL_register(L,'Texture',@ULuaTexture_Lib_f[0]); + result:=1; +end; +end. diff --git a/cmake/src/lua/ULuaUsdx.pas b/cmake/src/lua/ULuaUsdx.pas new file mode 100644 index 00000000..d92289b1 --- /dev/null +++ b/cmake/src/lua/ULuaUsdx.pas @@ -0,0 +1,145 @@ +{* UltraStar Deluxe - Karaoke Game
+ *
+ * UltraStar Deluxe is the legal property of its developers, whose names
+ * are too numerous to list here. Please refer to the COPYRIGHT
+ * file distributed with this source distribution.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301, USA.
+ *
+ * $URL$
+ * $Id$
+ *}
+
+unit ULuaUsdx;
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+{$ENDIF}
+
+{$I switches.inc}
+
+uses ULua;
+
+{ some basic lua c functions from usdx table }
+
+{ Usdx.Time - returns sdl_time to have time numbers comparable with
+ ultrastar deluxe ones. no arguments }
+function ULuaUsdx_Time(L: Plua_State): Integer; cdecl;
+
+{ Usdx.Version - returns Usdx version string (the same that US_Version
+ language-constant does). no arguments }
+function ULuaUsdx_Version(L: Plua_State): Integer; cdecl;
+
+{ Usdx.Hook - returns an hook table with name and Unhook function
+ arguments: event_name: string }
+function ULuaUsdx_Hook(L: Plua_State): Integer; cdecl;
+
+{ Usdx.ShutMeDown - no results, no arguments
+ unloads the calling plugin }
+function ULuaUsdx_ShutMeDown(L: Plua_State): Integer; cdecl;
+
+const
+ ULuaUsdx_Lib_f: array [0..4] of lual_reg = (
+ (name:'Version'; func:ULuaUsdx_Version),
+ (name:'Time'; func:ULuaUsdx_Time),
+ (name:'Hook'; func:ULuaUsdx_Hook),
+ (name:'ShutMeDown'; func:ULuaUsdx_ShutMeDown),
+ (name:nil;func:nil)
+ );
+
+implementation
+uses SDL, ULuaCore, ULuaUtils, UHookableEvent, UConfig;
+
+{ Usdx.Time - returns sdl_time to have time numbers comparable with
+ ultrastar deluxe ones. no arguments }
+function ULuaUsdx_Time(L: Plua_State): Integer; cdecl;
+ var top: Integer;
+begin
+ //remove arguments (if any)
+ top := lua_gettop(L);
+
+ if (top > 0) then
+ lua_pop(L, top);
+
+ //push result
+ lua_pushinteger(L, SDL_GetTicks);
+ Result := 1; //one result
+end;
+
+{ Usdx.Version - returns Usdx version string (the same that US_Version
+ language-constant does). no arguments }
+function ULuaUsdx_Version(L: Plua_State): Integer; cdecl;
+ var top: Integer;
+begin
+ //remove arguments (if any)
+ top := lua_gettop(L);
+
+ if (top > 0) then
+ lua_pop(L, top);
+
+ //push result
+ lua_pushstring(L, PChar(USDXVersionStr()));
+ Result := 1; //one result
+end;
+
+{ Usdx.Hook - returns an hook table with name and Unhook function
+ arguments: event_name: string; function_name: string }
+function ULuaUsdx_Hook(L: Plua_State): Integer; cdecl;
+var
+ EventName: String;
+ FunctionName: String;
+ P: TLuaPlugin;
+ Event: THookableEvent;
+begin
+ EventName := luaL_checkstring(L, 1);
+ FunctionName := luaL_checkstring(L, 2);
+
+ P := Lua_GetOwner(L);
+
+ lua_pop(L, lua_gettop(L)); //clear stack
+
+ Result := 1;
+
+ Event := LuaCore.GetEventByName(EventName);
+ if (Event <> nil) then
+ begin
+ Event.Hook(L, P.Id, FunctionName);
+ end
+ else
+ luaL_error(L, PChar('event does not exist: ' + EventName));
+end;
+
+function ULuaUsdx_ShutMeDown(L: Plua_State): Integer; cdecl;
+ var
+ top: Integer;
+ P: TLuaPlugin;
+begin
+ Result := 0;
+
+ //remove arguments (if any)
+ top := lua_gettop(L);
+
+ if (top > 0) then
+ lua_pop(L, top);
+
+ P := Lua_GetOwner(L);
+
+ P.ShutMeDown;
+end;
+
+end.
\ No newline at end of file diff --git a/cmake/src/lua/ULuaUtils.pas b/cmake/src/lua/ULuaUtils.pas new file mode 100644 index 00000000..143b34d4 --- /dev/null +++ b/cmake/src/lua/ULuaUtils.pas @@ -0,0 +1,186 @@ +{* UltraStar Deluxe - Karaoke Game
+ *
+ * UltraStar Deluxe is the legal property of its developers, whose names
+ * are too numerous to list here. Please refer to the COPYRIGHT
+ * file distributed with this source distribution.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301, USA.
+ *
+ * $URL$
+ * $Id$
+ *}
+
+unit ULuaUtils;
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+{$ENDIF}
+
+{$I switches.inc}
+
+uses ULua, ULuaCore;
+
+{ converts a lua table with a structure like:
+ * = 1 , * = 4 , * = 5
+ to an integer with the value:
+ 0b11001
+ does not pop anything }
+function Lua_ToBinInt(L: PLua_State; idx: Integer): Integer;
+
+{ converts an integer with the value:
+ 0b11001
+ to a lua table with a structure like:
+ * = 1 , * = 4 , * = 5
+ and pushed the table onto the stack }
+procedure Lua_PushBinInt(L: PLua_State; BinInt: Integer);
+
+{ pushes a table with position and size of a rectangle
+ t.x => position of the rectangle in pixels at x-axis
+ t.y => position of the rectangle in pixels at y-axis
+ t.w => width of the rectangle
+ t.h => height of the rectangle }
+procedure Lua_PushRect(L: PLua_State; X, Y, W, H: Double);
+
+{ returns plugin that is the owner of the given state
+ may raise a lua error if the parent id is not found
+ in states registry, if state owner does not exists
+ or is not loaded. So a check for a nil value is not
+ necessary }
+function Lua_GetOwner(L: PLua_State): TLuaPlugin;
+
+{ this is a helper in case an evenet owner don't has no use for the results
+ returns number of popped elements }
+function Lua_ClearStack(L: Plua_State): Integer;
+
+
+implementation
+
+{ converts a lua table with a structure like:
+ * = 1 , * = 4 , * = 5
+ to an integer with the value:
+ 0b11001
+ does not pop anything }
+function Lua_ToBinInt(L: PLua_State; idx: Integer): Integer;
+ var
+ I: Integer;
+begin
+ // default: no bits set
+ Result := 0;
+
+ lua_checkstack(L, 2);
+
+ if (idx < 0) then
+ dec(idx); // we will push one value before using this
+
+ lua_PushNil(L);
+ while (lua_next(L, idx) <> 0) do
+ begin
+ if (lua_isNumber(L, -1)) then
+ begin //check if we got an integer value from 1 to 32
+ I := lua_toInteger(L, -1);
+ if (I >= 1) and (I <= 32) then
+ Result := Result or 1 shl (I - 1);
+ end;
+
+ // pop value, so key is on top
+ lua_pop(L, 1);
+ end;
+end;
+
+{ converts an integer with the value:
+ 0b11001
+ to a lua table with a structure like:
+ * = 1 , * = 4 , * = 5
+ and pushed the table onto the stack }
+procedure Lua_PushBinInt(L: PLua_State; BinInt: Integer);
+var
+ I, Index: Integer;
+begin
+ lua_newTable(L);
+
+
+ Index := 1; //< lua starts w/ index 1
+ for I := 0 to 31 do
+ if (BinInt and (1 shl I) <> 0) then
+ begin
+ lua_pushInteger(L, Index);
+ lua_pushInteger(L, I);
+ lua_settable(L, -3);
+
+ Inc(Index);
+ end;
+end;
+
+{ pushes a table with position and size of a rectangle
+ t.x => position of the rectangle in pixels at x-axis
+ t.y => position of the rectangle in pixels at y-axis
+ t.w => width of the rectangle
+ t.h => height of the rectangle }
+procedure Lua_PushRect(L: PLua_State; X, Y, W, H: Double);
+begin
+ lua_createtable(L, 0, 4); // table w/ 4 record fields
+
+ // x pos
+ lua_pushNumber(L, X);
+ lua_setField(L, -2, 'x');
+
+ // y pos
+ lua_pushNumber(L, Y);
+ lua_setField(L, -2, 'y');
+
+ // width
+ lua_pushNumber(L, W);
+ lua_setField(L, -2, 'w');
+
+ // height
+ lua_pushNumber(L, H);
+ lua_setField(L, -2, 'h');
+end;
+
+{ returns plugin that is the owner of the given state
+ may raise a lua error if the parent id is not found
+ in states registry, if state owner does not exists
+ or is not loaded. So a check for a nil value is not
+ necessary }
+function Lua_GetOwner(L: PLua_State): TLuaPlugin;
+begin
+ lua_checkstack(L, 1);
+
+ lua_getfield (L, LUA_REGISTRYINDEX, '_USDX_STATE_ID');
+ if (not lua_isNumber(L, -1)) then
+ luaL_error(L, 'unable to get _USDX_STATE_ID');
+
+ Result := LuaCore.GetPluginById(lua_toInteger(L, -1));
+
+ lua_pop(L, 1); //< remove state id from stack
+
+ if (Result = nil) then
+ luaL_error(L, '_USDX_STATE_ID has invalid value')
+ else if (Result.Status > psRunning) then
+ luaL_error(L, 'owning plugin is not loaded or already unloaded in Lua_GetOwner');
+end;
+
+{ this is a helper in case an evenet owner don't has no use for the results
+ returns number of popped elements }
+function Lua_ClearStack(L: Plua_State): Integer;
+begin
+ Result := lua_gettop(L);
+ lua_pop(L, Result);
+end;
+
+end.
\ No newline at end of file diff --git a/cmake/src/media/UAudioCore_Bass.pas b/cmake/src/media/UAudioCore_Bass.pas index 12623dc1..3a84dcd7 100644 --- a/cmake/src/media/UAudioCore_Bass.pas +++ b/cmake/src/media/UAudioCore_Bass.pas @@ -44,10 +44,13 @@ type public constructor Create(); class function GetInstance(): TAudioCore_Bass; + function CheckVersion(): boolean; function ErrorGetString(): string; overload; function ErrorGetString(errCode: integer): string; overload; function ConvertAudioFormatToBASSFlags(Format: TAudioSampleFormat; out Flags: DWORD): boolean; function ConvertBASSFlagsToAudioFormat(Flags: DWORD; out Format: TAudioSampleFormat): boolean; + private + function DecodeVersion(VersionHex: integer): string; end; implementation @@ -56,6 +59,11 @@ uses UMain, ULog; +const + // BASS 2.4.2 is not ABI compatible with older versions + // as (BASS_RECORDINFO.driver was removed) + BASS_MIN_REQUIRED_VERSION = $02040201; + var Instance: TAudioCore_Bass; @@ -71,6 +79,27 @@ begin Result := Instance; end; +function TAudioCore_Bass.DecodeVersion(VersionHex: integer): string; +var + Version: array [0..3] of integer; +begin + Version[0] := (VersionHex shr 24) and $FF; + Version[1] := (VersionHex shr 16) and $FF; + Version[2] := (VersionHex shr 8) and $FF; + Version[3] := (VersionHex shr 0) and $FF; + Result := Format('%x.%x.%x.%x', [Version[0], Version[1], Version[2], Version[3]]); +end; + +function TAudioCore_Bass.CheckVersion(): boolean; +begin + Result := BASS_GetVersion() >= BASS_MIN_REQUIRED_VERSION; + if (not Result) then + begin + Log.LogWarn('Could not init BASS audio library. ''bass.dll'' version is ' + DecodeVersion(BASS_GetVersion()) + ' but ' + DecodeVersion(BASS_MIN_REQUIRED_VERSION) + ' or higher is required.', + 'TAudioCore_Bass.CheckVersion'); + end; +end; + function TAudioCore_Bass.ErrorGetString(): string; begin Result := ErrorGetString(BASS_ErrorGetCode()); diff --git a/cmake/src/media/UAudioCore_Portaudio.pas b/cmake/src/media/UAudioCore_Portaudio.pas index 25ceae3c..c97b5d10 100644 --- a/cmake/src/media/UAudioCore_Portaudio.pas +++ b/cmake/src/media/UAudioCore_Portaudio.pas @@ -40,11 +40,15 @@ uses type TAudioCore_Portaudio = class + private + InitCount: integer; ///< keeps track of the number of Initialize/Terminate calls public constructor Create(); class function GetInstance(): TAudioCore_Portaudio; + function Initialize(): boolean; + function Terminate(): boolean; function GetPreferredApiIndex(): TPaHostApiIndex; - function TestDevice(inParams, outParams: PPaStreamParameters; var sampleRate: Double): boolean; + function TestDevice(inParams, outParams: PPaStreamParameters; var sampleRate: double): boolean; end; implementation @@ -92,6 +96,7 @@ var constructor TAudioCore_Portaudio.Create(); begin inherited; + InitCount := 0; end; class function TAudioCore_Portaudio.GetInstance(): TAudioCore_Portaudio; @@ -101,9 +106,60 @@ begin Result := Instance; end; +function TAudioCore_Portaudio.Initialize(): boolean; +var + Err: TPaError; +begin + // initialize only once + if (InitCount > 0) then + begin + Inc(InitCount); + Result := true; + Exit; + end; + + // init Portaudio + Err := Pa_Initialize(); + if (Err <> paNoError) then + begin + Log.LogError(Pa_GetErrorText(Err), 'TAudioCore_Portaudio.Initialize'); + Result := false; + Exit; + end; + + // only increment on success + Inc(InitCount); + Result := true; +end; + +function TAudioCore_Portaudio.Terminate(): boolean; +var + Err: TPaError; +begin + // decrement usage count + Dec(InitCount); + if (InitCount > 0) then + begin + // do not terminate yet + Result := true; + Exit; + end; + + // terminate if usage count is 0 + Err := Pa_Terminate(); + if (Err <> paNoError) then + begin + Log.LogError(Pa_GetErrorText(Err), 'TAudioCore_Portaudio.Terminate'); + Result := false; + Exit; + end; + + Result := true; +end; + function TAudioCore_Portaudio.GetPreferredApiIndex(): TPaHostApiIndex; var - i: integer; + i: integer; apiIndex: TPaHostApiIndex; apiInfo: PPaHostApiInfo; begin @@ -112,11 +168,11 @@ begin // select preferred sound-API for i:= 0 to High(ApiPreferenceOrder) do begin - if(ApiPreferenceOrder[i] <> paDefaultApi) then + if (ApiPreferenceOrder[i] <> paDefaultApi) then begin // check if API is available apiIndex := Pa_HostApiTypeIdToHostApiIndex(ApiPreferenceOrder[i]); - if(apiIndex >= 0) then + if (apiIndex >= 0) then begin // we found an API but we must check if it works // (on linux portaudio might detect OSS but does not provide @@ -132,7 +188,7 @@ begin end; // None of the preferred APIs is available -> use default - if(result < 0) then + if (result < 0) then begin result := Pa_GetDefaultHostApi(); end; @@ -141,9 +197,9 @@ end; {* * Portaudio test callback used by TestDevice(). *} -function TestCallback(input: Pointer; output: Pointer; frameCount: Longword; +function TestCallback(input: pointer; output: pointer; frameCount: longword; timeInfo: PPaStreamCallbackTimeInfo; statusFlags: TPaStreamCallbackFlags; - inputDevice: Pointer): Integer; cdecl; + inputDevice: pointer): integer; cdecl; begin // this callback is called only once result := paAbort; @@ -189,15 +245,15 @@ end; * So we have to provide the possibility to manually select an output device * in the UltraStar options if we want to use portaudio instead of SDL. *) -function TAudioCore_Portaudio.TestDevice(inParams, outParams: PPaStreamParameters; var sampleRate: Double): boolean; +function TAudioCore_Portaudio.TestDevice(inParams, outParams: PPaStreamParameters; var sampleRate: double): boolean; +const + altSampleRates: array[0..1] of double = (44100, 48000); // alternative sample-rates var - stream: PPaStream; - err: TPaError; + stream: PPaStream; + err: TPaError; cbWorks: boolean; cbPolls: integer; - i: integer; -const - altSampleRates: array[0..1] of Double = (44100, 48000); // alternative sample-rates + i: integer; begin Result := false; @@ -206,7 +262,7 @@ begin // check if device supports our input-format err := Pa_IsFormatSupported(inParams, outParams, sampleRate); - if(err <> paNoError) then + if (err <> paNoError) then begin // we cannot fix the error -> exit if (err <> paInvalidSampleRate) then @@ -244,14 +300,14 @@ begin err := Pa_OpenStream(stream, inParams, outParams, sampleRate, paFramesPerBufferUnspecified, paNoFlag, @TestCallback, nil); - if(err <> paNoError) then + if (err <> paNoError) then begin exit; end; // start the callback err := Pa_StartStream(stream); - if(err <> paNoError) then + if (err <> paNoError) then begin Pa_CloseStream(stream); exit; diff --git a/cmake/src/media/UAudioDecoder_Bass.pas b/cmake/src/media/UAudioDecoder_Bass.pas index 6bbdaeaa..d6d2425a 100644 --- a/cmake/src/media/UAudioDecoder_Bass.pas +++ b/cmake/src/media/UAudioDecoder_Bass.pas @@ -38,11 +38,12 @@ implementation uses Classes, SysUtils, + bass, UMain, UMusic, UAudioCore_Bass, ULog, - bass; + UPath; type TBassDecodeStream = class(TAudioDecodeStream) @@ -75,7 +76,7 @@ type function InitializeDecoder(): boolean; function FinalizeDecoder(): boolean; - function Open(const Filename: string): TAudioDecodeStream; + function Open(const Filename: IPath): TAudioDecodeStream; end; var @@ -213,7 +214,10 @@ end; function TAudioDecoder_Bass.InitializeDecoder(): boolean; begin + Result := false; BassCore := TAudioCore_Bass.GetInstance(); + if not BassCore.CheckVersion then + Exit; Result := true; end; @@ -222,7 +226,7 @@ begin Result := true; end; -function TAudioDecoder_Bass.Open(const Filename: string): TAudioDecodeStream; +function TAudioDecoder_Bass.Open(const Filename: IPath): TAudioDecodeStream; var Stream: HSTREAM; ChannelInfo: BASS_CHANNELINFO; @@ -237,7 +241,14 @@ begin // TODO: use BASS_STREAM_PRESCAN for accurate seeking in VBR-files? // disadvantage: seeking will slow down. - Stream := BASS_StreamCreateFile(False, PAnsiChar(Filename), 0, 0, BASS_STREAM_DECODE); + + {$IFDEF MSWINDOWS} + // Windows: Use UTF-16 version + Stream := BASS_StreamCreateFile(False, PWideChar(Filename.ToWide), 0, 0, BASS_STREAM_DECODE or BASS_UNICODE); + {$ELSE} + // Mac OS X: Use UTF8/ANSI version + Stream := BASS_StreamCreateFile(False, PAnsiChar(Filename.ToNative), 0, 0, BASS_STREAM_DECODE); + {$ENDIF} if (Stream = 0) then begin //Log.LogError(BassCore.ErrorGetString(), 'TAudioDecoder_Bass.Open'); @@ -247,7 +258,7 @@ begin // check if BASS opened some erroneously recognized file-formats if BASS_ChannelGetInfo(Stream, channelInfo) then begin - fileExt := ExtractFileExt(Filename); + fileExt := Filename.GetExtension.ToUTF8; // BASS opens FLV-files (maybe others too) although it cannot handle them. // Setting BASS_CONFIG_VERIFY to the max. value (100000) does not help. if ((fileExt = '.flv') and (channelInfo.ctype = BASS_CTYPE_STREAM_MP1)) then diff --git a/cmake/src/media/UAudioDecoder_FFmpeg.pas b/cmake/src/media/UAudioDecoder_FFmpeg.pas index 97d8a8df..7ca98885 100644 --- a/cmake/src/media/UAudioDecoder_FFmpeg.pas +++ b/cmake/src/media/UAudioDecoder_FFmpeg.pas @@ -56,23 +56,24 @@ interface implementation uses + SDL, // SDL redefines some base types -> include before SysUtils to ignore them Classes, Math, - UMusic, - UIni, - UMain, + SysUtils, avcodec, avformat, avutil, avio, mathematics, // used for av_rescale_q rational, - SDL, - SysUtils, + UMusic, + UIni, + UMain, UMediaCore_FFmpeg, ULog, UCommon, - UConfig; + UConfig, + UPath; const MAX_AUDIOQ_SIZE = (5 * 16 * 1024); @@ -138,7 +139,7 @@ type AudioBufferSize: integer; AudioBuffer: PByteArray; - Filename: string; + Filename: IPath; procedure SetPositionIntern(Time: real; Flush: boolean; Blocking: boolean); procedure SetEOF(State: boolean); {$IFDEF HasInline}inline;{$ENDIF} @@ -161,7 +162,7 @@ type constructor Create(); destructor Destroy(); override; - function Open(const Filename: string): boolean; + function Open(const Filename: IPath): boolean; procedure Close(); override; function GetLength(): real; override; @@ -183,7 +184,7 @@ type function InitializeDecoder(): boolean; function FinalizeDecoder(): boolean; - function Open(const Filename: string): TAudioDecodeStream; + function Open(const Filename: IPath): TAudioDecodeStream; end; var @@ -270,7 +271,7 @@ begin inherited; end; -function TFFmpegDecodeStream.Open(const Filename: string): boolean; +function TFFmpegDecodeStream.Open(const Filename: IPath): boolean; var SampleFormat: TAudioSampleFormat; AVResult: integer; @@ -280,18 +281,18 @@ begin Close(); Reset(); - if (not FileExists(Filename)) then + if (not Filename.IsFile) then begin - Log.LogError('Audio-file does not exist: "' + Filename + '"', 'UAudio_FFmpeg'); + Log.LogError('Audio-file does not exist: "' + Filename.ToNative + '"', 'UAudio_FFmpeg'); Exit; end; Self.Filename := Filename; - // open audio file - if (av_open_input_file(FormatCtx, PAnsiChar(Filename), nil, 0, nil) <> 0) then + // use custom 'ufile' protocol for UTF-8 support + if (av_open_input_file(FormatCtx, PAnsiChar('ufile:'+FileName.ToUTF8), nil, 0, nil) <> 0) then begin - Log.LogError('av_open_input_file failed: "' + Filename + '"', 'UAudio_FFmpeg'); + Log.LogError('av_open_input_file failed: "' + Filename.ToNative + '"', 'UAudio_FFmpeg'); Exit; end; @@ -301,7 +302,7 @@ begin // retrieve stream information if (av_find_stream_info(FormatCtx) < 0) then begin - Log.LogError('av_find_stream_info failed: "' + Filename + '"', 'UAudio_FFmpeg'); + Log.LogError('av_find_stream_info failed: "' + Filename.ToNative + '"', 'UAudio_FFmpeg'); Close(); Exit; end; @@ -310,13 +311,13 @@ begin FormatCtx^.pb.eof_reached := 0; {$IFDEF DebugFFmpegDecode} - dump_format(FormatCtx, 0, PAnsiChar(Filename), 0); + dump_format(FormatCtx, 0, PAnsiChar(Filename.ToNative), 0); {$ENDIF} AudioStreamIndex := FFmpegCore.FindAudioStreamIndex(FormatCtx); if (AudioStreamIndex < 0) then begin - Log.LogError('FindAudioStreamIndex: No Audio-stream found "' + Filename + '"', 'UAudio_FFmpeg'); + Log.LogError('FindAudioStreamIndex: No Audio-stream found "' + Filename.ToNative + '"', 'UAudio_FFmpeg'); Close(); Exit; end; @@ -324,6 +325,7 @@ begin //Log.LogStatus('AudioStreamIndex is: '+ inttostr(ffmpegStreamID), 'UAudio_FFmpeg'); AudioStream := FormatCtx.streams[AudioStreamIndex]; + AudioStreamPos := 0; CodecCtx := AudioStream^.codec; // TODO: should we use this or not? Should we allow 5.1 channel audio? @@ -574,30 +576,38 @@ begin PauseParser(); PauseDecoder(); SDL_mutexP(StateLock); - - // configure seek parameters - SeekPos := Time; - SeekFlush := Flush; - SeekFlags := AVSEEK_FLAG_ANY; - SeekRequest := true; - - // Note: the BACKWARD-flag seeks to the first position <= the position - // searched for. Otherwise e.g. position 0 might not be seeked correct. - // For some reason ffmpeg sometimes doesn't use position 0 but the key-frame - // following. In streams with few key-frames (like many flv-files) the next - // key-frame after 0 might be 5secs ahead. - if (Time < AudioStreamPos) then - SeekFlags := SeekFlags or AVSEEK_FLAG_BACKWARD; - - EOFState := false; - ErrorState := false; - - // send a reuse signal in case the parser was stopped (e.g. because of an EOF) - SDL_CondSignal(ParserIdleCond); - - SDL_mutexV(StateLock); - ResumeDecoder(); - ResumeParser(); + try + EOFState := false; + ErrorState := false; + + // do not seek if we are already at the correct position. + // This is important especially for seeking to position 0 if we already are + // at the beginning. Although seeking with AVSEEK_FLAG_BACKWARD for pos 0 works, + // it is still a bit choppy (although much better than w/o AVSEEK_FLAG_BACKWARD). + if (Time = AudioStreamPos) then + Exit; + + // configure seek parameters + SeekPos := Time; + SeekFlush := Flush; + SeekFlags := AVSEEK_FLAG_ANY; + SeekRequest := true; + + // Note: the BACKWARD-flag seeks to the first position <= the position + // searched for. Otherwise e.g. position 0 might not be seeked correct. + // For some reason ffmpeg sometimes doesn't use position 0 but the key-frame + // following. In streams with few key-frames (like many flv-files) the next + // key-frame after 0 might be 5secs ahead. + if (Time <= AudioStreamPos) then + SeekFlags := SeekFlags or AVSEEK_FLAG_BACKWARD; + + // send a reuse signal in case the parser was stopped (e.g. because of an EOF) + SDL_CondSignal(ParserIdleCond); + finally + SDL_mutexV(StateLock); + ResumeDecoder(); + ResumeParser(); + end; // in blocking mode, wait until seeking is done if (Blocking) then @@ -1117,7 +1127,7 @@ begin Result := true; end; -function TAudioDecoder_FFmpeg.Open(const Filename: string): TAudioDecodeStream; +function TAudioDecoder_FFmpeg.Open(const Filename: IPath): TAudioDecodeStream; var Stream: TFFmpegDecodeStream; begin diff --git a/cmake/src/media/UAudioInput_Bass.pas b/cmake/src/media/UAudioInput_Bass.pas index ad6c3818..b8f914c5 100644 --- a/cmake/src/media/UAudioInput_Bass.pas +++ b/cmake/src/media/UAudioInput_Bass.pas @@ -46,6 +46,7 @@ uses UIni, ULog, UAudioCore_Bass, + UTextEncoding, UCommon, // (Note: for MakeLong on non-windows platforms) {$IFDEF MSWINDOWS} Windows, // (Note: for MakeLong) @@ -352,7 +353,7 @@ end; function TAudioInput_Bass.EnumDevices(): boolean; var - Descr: PChar; + Descr: UTF8String; SourceName: PChar; Flags: integer; BassDeviceID: integer; @@ -389,9 +390,12 @@ begin BassDevice := TBassInputDevice.Create(); AudioInputProcessor.DeviceList[DeviceIndex] := BassDevice; - Descr := DeviceInfo.name; - BassDevice.BassDeviceID := BassDeviceID; + + // BASS device names seem to be encoded with local encoding + // TODO: works for windows, check Linux + Mac OS X + Descr := DecodeStringUTF8(DeviceInfo.name, encLocale); + BassDevice.Name := UnifyDeviceName(Descr, DeviceIndex); // zero info-struct as some fields might not be set (e.g. freq is just set on Vista and MacOSX) @@ -459,7 +463,9 @@ begin break; SetLength(BassDevice.Source, Length(BassDevice.Source)+1); - BassDevice.Source[SourceIndex].Name := SourceName; + // BASS source names seem to be encoded with local encoding + // TODO: works for windows, check Linux + Mac OS X + BassDevice.Source[SourceIndex].Name := DecodeStringUTF8(SourceName, encLocale); // get input-source info Flags := BASS_RecordGetInput(SourceIndex, PSingle(nil)^); @@ -489,6 +495,11 @@ end; function TAudioInput_Bass.InitializeRecord(): boolean; begin BassCore := TAudioCore_Bass.GetInstance(); + if not BassCore.CheckVersion then + begin + Result := false; + Exit; + end; Result := EnumDevices(); end; diff --git a/cmake/src/media/UAudioInput_Portaudio.pas b/cmake/src/media/UAudioInput_Portaudio.pas index 31d2882b..c7364eb4 100644 --- a/cmake/src/media/UAudioInput_Portaudio.pas +++ b/cmake/src/media/UAudioInput_Portaudio.pas @@ -45,11 +45,14 @@ uses portmixer, {$ENDIF} portaudio, + ctypes, UAudioCore_Portaudio, - URecord, + UUnicodeUtils, + UTextEncoding, UIni, ULog, - UMain; + UMain, + URecord; type TAudioInput_Portaudio = class(TAudioInputBase) @@ -57,7 +60,7 @@ type AudioCore: TAudioCore_Portaudio; function EnumDevices(): boolean; public - function GetName: String; override; + function GetName: string; override; function InitializeRecord: boolean; override; function FinalizeRecord: boolean; override; end; @@ -70,31 +73,76 @@ type {$ENDIF} PaDeviceIndex: TPaDeviceIndex; public - function Open(): boolean; + function Open(): boolean; function Close(): boolean; function Start(): boolean; override; - function Stop(): boolean; override; + function Stop(): boolean; override; + + function DetermineInputLatency(Info: PPaDeviceInfo): TPaTime; function GetVolume(): single; override; procedure SetVolume(Volume: single); override; end; -function MicrophoneCallback(input: Pointer; output: Pointer; frameCount: Longword; +function MicrophoneCallback(input: pointer; output: pointer; frameCount: culong; timeInfo: PPaStreamCallbackTimeInfo; statusFlags: TPaStreamCallbackFlags; - inputDevice: Pointer): Integer; cdecl; forward; + inputDevice: pointer): cint; cdecl; forward; -function MicrophoneTestCallback(input: Pointer; output: Pointer; frameCount: Longword; +function MicrophoneTestCallback(input: pointer; output: pointer; frameCount: culong; timeInfo: PPaStreamCallbackTimeInfo; statusFlags: TPaStreamCallbackFlags; - inputDevice: Pointer): Integer; cdecl; forward; + inputDevice: pointer): cint; cdecl; forward; + +{** + * Converts a string returned by Portaudio into UTF8. + * If the string already is in UTF8 no conversion is performed, otherwise + * the local encoding is used. + *} +function ConvertPaStringToUTF8(const Str: RawByteString): UTF8String; +begin + if (IsUTF8String(Str)) then + Result := Str + else + Result := DecodeStringUTF8(Str, encLocale); +end; { TPortaudioInputDevice } +function TPortaudioInputDevice.DetermineInputLatency(Info: PPaDeviceInfo): TPaTime; +begin + if (Ini.InputDeviceConfig[CfgIndex].Latency <> -1) then + begin + // autodetection off -> set user latency + Result := Ini.InputDeviceConfig[CfgIndex].Latency / 1000 + end + else + begin + // on vista and xp the defaultLowInputLatency may be set to 0 but it works. + // TODO: correct too low latencies (what is a too low latency, maybe < 10ms?) + // TODO: retry with input-latency set to 20ms (defaultLowInputLatency might + // not be set correctly in OSS) + + // FIXME: according to the portaudio headers defaultHighInputLatency (approx. 40ms) is + // for robust non-interactive applications and defaultLowInputLatency (approx. 15ms) + // for interactive performance. + // We need defaultLowInputLatency here but this setting is far too buggy. If the callback + // does not return quickly the stream will be stuck after returning from the callback + // and the callback will not be called anymore and mic-capturing stops. + // Audacity (in AudioIO.cpp) uses defaultHighInputLatency if software playthrough is on + // and even higher latencies (100ms) without playthrough so this should be ok for now. + //Result := Info^.defaultLowInputLatency; + Result := Info^.defaultHighInputLatency; + end; +end; + function TPortaudioInputDevice.Open(): boolean; var Error: TPaError; inputParams: TPaStreamParameters; deviceInfo: PPaDeviceInfo; + {$IFDEF UsePortmixer} + SourceIndex: integer; + {$ENDIF} begin Result := false; @@ -107,19 +155,19 @@ begin device := PaDeviceIndex; channelCount := AudioFormat.Channels; sampleFormat := paInt16; - suggestedLatency := deviceInfo^.defaultLowInputLatency; + suggestedLatency := DetermineInputLatency(deviceInfo); hostApiSpecificStreamInfo := nil; end; - //Log.LogStatus(deviceInfo^.name, 'Portaudio'); - //Log.LogStatus(floattostr(deviceInfo^.defaultLowInputLatency), 'Portaudio'); + Log.LogStatus('Open ' + deviceInfo^.name, 'Portaudio'); + Log.LogStatus('Latency of ' + deviceInfo^.name + ': ' + floatToStr(inputParams.suggestedLatency), 'Portaudio'); // open input stream Error := Pa_OpenStream(RecordStream, @inputParams, nil, AudioFormat.SampleRate, paFramesPerBufferUnspecified, paNoFlag, - @MicrophoneCallback, Pointer(Self)); - if(Error <> paNoError) then + @MicrophoneCallback, pointer(Self)); + if (Error <> paNoError) then begin Log.LogError('Error opening stream: ' + Pa_GetErrorText(Error), 'TPortaudioInputDevice.Open'); Exit; @@ -155,7 +203,7 @@ end; function TPortaudioInputDevice.Start(): boolean; var - Error: TPaError; + Error: TPaError; begin Result := false; @@ -169,7 +217,7 @@ begin // start capture Error := Pa_StartStream(RecordStream); - if(Error <> paNoError) then + if (Error <> paNoError) then begin Log.LogError('Error starting stream: ' + Pa_GetErrorText(Error), 'TPortaudioInputDevice.Start'); Close(); @@ -268,34 +316,36 @@ end; function TAudioInput_Portaudio.EnumDevices(): boolean; var - i: integer; - paApiIndex: TPaHostApiIndex; - paApiInfo: PPaHostApiInfo; - deviceName: string; - deviceIndex: TPaDeviceIndex; - deviceInfo: PPaDeviceInfo; - channelCnt: integer; - SC: integer; // soundcard - err: TPaError; - errMsg: string; - paDevice: TPortaudioInputDevice; - inputParams: TPaStreamParameters; - stream: PPaStream; - streamInfo: PPaStreamInfo; - sampleRate: double; - latency: TPaTime; + i: integer; + deviceName: UTF8String; + paApiIndex: TPaHostApiIndex; + paApiInfo: PPaHostApiInfo; + paDeviceIndex:TPaDeviceIndex; + paDeviceInfo: PPaDeviceInfo; + channelCnt: integer; + deviceIndex: integer; + err: TPaError; + errMsg: string; + paDevice: TPortaudioInputDevice; + inputParams: TPaStreamParameters; + stream: PPaStream; + streamInfo: PPaStreamInfo; + sampleRate: double; + latency: TPaTime; {$IFDEF UsePortmixer} - mixer: PPxMixer; - sourceCnt: integer; - sourceIndex: integer; - sourceName: string; + mixer: PPxMixer; + sourceCnt: integer; + sourceIndex: integer; + sourceName: UTF8String; {$ENDIF} +const + MIN_TEST_LATENCY = 100 / 1000; // min. test latency of 100 ms to avoid removal of working devices begin Result := false; // choose the best available Audio-API paApiIndex := AudioCore.GetPreferredApiIndex(); - if(paApiIndex = -1) then + if (paApiIndex = -1) then begin Log.LogError('No working Audio-API found', 'TAudioInput_Portaudio.EnumDevices'); Exit; @@ -303,17 +353,17 @@ begin paApiInfo := Pa_GetHostApiInfo(paApiIndex); - SC := 0; + deviceIndex := 0; // init array-size to max. input-devices count SetLength(AudioInputProcessor.DeviceList, paApiInfo^.deviceCount); for i:= 0 to High(AudioInputProcessor.DeviceList) do begin // convert API-specific device-index to global index - deviceIndex := Pa_HostApiDeviceIndexToDeviceIndex(paApiIndex, i); - deviceInfo := Pa_GetDeviceInfo(deviceIndex); + paDeviceIndex := Pa_HostApiDeviceIndexToDeviceIndex(paApiIndex, i); + paDeviceInfo := Pa_GetDeviceInfo(paDeviceIndex); - channelCnt := deviceInfo^.maxInputChannels; + channelCnt := paDeviceInfo^.maxInputChannels; // current device is no input device -> skip if (channelCnt <= 0) then @@ -326,25 +376,25 @@ begin channelCnt := 2; paDevice := TPortaudioInputDevice.Create(); - AudioInputProcessor.DeviceList[SC] := paDevice; + AudioInputProcessor.DeviceList[deviceIndex] := paDevice; // retrieve device-name - deviceName := deviceInfo^.name; - paDevice.Name := deviceName; - paDevice.PaDeviceIndex := deviceIndex; + deviceName := ConvertPaStringToUTF8(paDeviceInfo^.name); + paDevice.Name := UnifyDeviceName(deviceName, deviceIndex); + paDevice.PaDeviceIndex := paDeviceIndex; - sampleRate := deviceInfo^.defaultSampleRate; + sampleRate := paDeviceInfo^.defaultSampleRate; - // on vista and xp the defaultLowInputLatency may be set to 0 but it works. - // TODO: correct too low latencies (what is a too low latency, maybe < 10ms?) - latency := deviceInfo^.defaultLowInputLatency; + // use a stable (high) latency so we do not remove working devices + if (paDeviceInfo^.defaultHighInputLatency > MIN_TEST_LATENCY) then + latency := paDeviceInfo^.defaultHighInputLatency + else + latency := MIN_TEST_LATENCY; // setup desired input parameters - // TODO: retry with input-latency set to 20ms (defaultLowInputLatency might - // not be set correctly in OSS) with inputParams do begin - device := deviceIndex; + device := paDeviceIndex; channelCount := channelCnt; sampleFormat := paInt16; suggestedLatency := latency; @@ -364,7 +414,7 @@ begin // open device for further info err := Pa_OpenStream(stream, @inputParams, nil, sampleRate, paFramesPerBufferUnspecified, paNoFlag, @MicrophoneTestCallback, nil); - if(err <> paNoError) then + if (err <> paNoError) then begin // unable to open device -> skip errMsg := Pa_GetErrorText(err); @@ -421,7 +471,7 @@ begin for sourceIndex := 1 to sourceCnt do begin sourceName := Px_GetInputSourceName(mixer, sourceIndex-1); - paDevice.Source[sourceIndex].Name := sourceName; + paDevice.Source[sourceIndex].Name := ConvertPaStringToUTF8(sourceName); end; Px_CloseMixer(mixer); @@ -430,48 +480,41 @@ begin // close test-stream Pa_CloseStream(stream); - Inc(SC); + Inc(deviceIndex); end; // adjust size to actual input-device count - SetLength(AudioInputProcessor.DeviceList, SC); + SetLength(AudioInputProcessor.DeviceList, deviceIndex); - Log.LogStatus('#Input-Devices: ' + inttostr(SC), 'Portaudio'); + Log.LogStatus('#Input-Devices: ' + inttostr(deviceIndex), 'Portaudio'); Result := true; end; function TAudioInput_Portaudio.InitializeRecord(): boolean; -var - err: TPaError; begin + Result := false; AudioCore := TAudioCore_Portaudio.GetInstance(); // initialize portaudio - err := Pa_Initialize(); - if(err <> paNoError) then - begin - Log.LogError(Pa_GetErrorText(err), 'TAudioInput_Portaudio.InitializeRecord'); - Result := false; - Exit; - end; - + if (not AudioCore.Initialize()) then + Exit; Result := EnumDevices(); end; function TAudioInput_Portaudio.FinalizeRecord: boolean; begin CaptureStop; - Pa_Terminate(); + AudioCore.Terminate(); Result := inherited FinalizeRecord(); end; {* * Portaudio input capture callback. *} -function MicrophoneCallback(input: Pointer; output: Pointer; frameCount: Longword; +function MicrophoneCallback(input: pointer; output: pointer; frameCount: culong; timeInfo: PPaStreamCallbackTimeInfo; statusFlags: TPaStreamCallbackFlags; - inputDevice: Pointer): Integer; cdecl; + inputDevice: pointer): cint; cdecl; begin AudioInputProcessor.HandleMicrophoneData(input, frameCount*4, inputDevice); result := paContinue; @@ -480,15 +523,14 @@ end; {* * Portaudio test capture callback. *} -function MicrophoneTestCallback(input: Pointer; output: Pointer; frameCount: Longword; +function MicrophoneTestCallback(input: pointer; output: pointer; frameCount: culong; timeInfo: PPaStreamCallbackTimeInfo; statusFlags: TPaStreamCallbackFlags; - inputDevice: Pointer): Integer; cdecl; + inputDevice: pointer): cint; cdecl; begin // this callback is called only once result := paAbort; end; - initialization MediaManager.add(TAudioInput_Portaudio.Create); diff --git a/cmake/src/media/UAudioPlaybackBase.pas b/cmake/src/media/UAudioPlaybackBase.pas index 7d143fdc..5f317257 100644 --- a/cmake/src/media/UAudioPlaybackBase.pas +++ b/cmake/src/media/UAudioPlaybackBase.pas @@ -34,7 +34,9 @@ interface {$I switches.inc} uses - UMusic; + UMusic, + UTime, + UPath; type TAudioPlaybackBase = class(TInterfacedObject, IAudioPlayback) @@ -46,12 +48,12 @@ type function GetLatency(): double; virtual; abstract; // open sound or music stream (used by Open() and OpenSound()) - function OpenStream(const Filename: string): TAudioPlaybackStream; - function OpenDecodeStream(const Filename: string): TAudioDecodeStream; + function OpenStream(const Filename: IPath): TAudioPlaybackStream; + function OpenDecodeStream(const Filename: IPath): TAudioDecodeStream; public function GetName: string; virtual; abstract; - function Open(const Filename: string): boolean; // true if succeed + function Open(const Filename: IPath): boolean; // true if succeed procedure Close; procedure Play; @@ -79,7 +81,7 @@ type function Length: real; // Sounds - function OpenSound(const Filename: string): TAudioPlaybackStream; + function OpenSound(const Filename: IPath): TAudioPlaybackStream; procedure PlaySound(Stream: TAudioPlaybackStream); procedure StopSound(Stream: TAudioPlaybackStream); @@ -108,7 +110,7 @@ begin Result := true; end; -function TAudioPlaybackBase.Open(const Filename: string): boolean; +function TAudioPlaybackBase.Open(const Filename: IPath): boolean; begin // free old MusicStream MusicStream.Free; @@ -130,7 +132,7 @@ begin FreeAndNil(MusicStream); end; -function TAudioPlaybackBase.OpenDecodeStream(const Filename: String): TAudioDecodeStream; +function TAudioPlaybackBase.OpenDecodeStream(const Filename: IPath): TAudioDecodeStream; var i: integer; begin @@ -140,7 +142,7 @@ begin if (assigned(Result)) then begin Log.LogInfo('Using decoder ' + IAudioDecoder(AudioDecoders[i]).GetName() + - ' for "' + Filename + '"', 'TAudioPlaybackBase.OpenDecodeStream'); + ' for "' + Filename.ToNative + '"', 'TAudioPlaybackBase.OpenDecodeStream'); Exit; end; end; @@ -157,7 +159,7 @@ begin SourceStream.Free; end; -function TAudioPlaybackBase.OpenStream(const Filename: string): TAudioPlaybackStream; +function TAudioPlaybackBase.OpenStream(const Filename: IPath): TAudioPlaybackStream; var PlaybackStream: TAudioPlaybackStream; DecodeStream: TAudioDecodeStream; @@ -169,7 +171,7 @@ begin DecodeStream := OpenDecodeStream(Filename); if (not assigned(DecodeStream)) then begin - Log.LogStatus('Could not open "' + Filename + '"', 'TAudioPlayback_Bass.OpenStream'); + Log.LogStatus('Could not open "' + Filename.ToNative + '"', 'TAudioPlayback_Bass.OpenStream'); Exit; end; @@ -283,7 +285,7 @@ begin Result := 0; end; -function TAudioPlaybackBase.OpenSound(const Filename: string): TAudioPlaybackStream; +function TAudioPlaybackBase.OpenSound(const Filename: IPath): TAudioPlaybackStream; begin Result := OpenStream(Filename); end; diff --git a/cmake/src/media/UAudioPlayback_Bass.pas b/cmake/src/media/UAudioPlayback_Bass.pas index 923c1d7b..1d7a44dc 100644 --- a/cmake/src/media/UAudioPlayback_Bass.pas +++ b/cmake/src/media/UAudioPlayback_Bass.pas @@ -684,9 +684,11 @@ end; function TAudioPlayback_Bass.InitializePlayback(): boolean; begin - result := false; + Result := false; BassCore := TAudioCore_Bass.GetInstance(); + if not BassCore.CheckVersion then + Exit; EnumDevices(); @@ -706,7 +708,7 @@ begin //BASS_SetConfig(BASS_CONFIG_UPDATEPERIOD, 10); //BASS_SetConfig(BASS_CONFIG_BUFFER, 100); - result := true; + Result := true; end; function TAudioPlayback_Bass.FinalizePlayback(): boolean; diff --git a/cmake/src/media/UAudioPlayback_Portaudio.pas b/cmake/src/media/UAudioPlayback_Portaudio.pas index ddbd03d6..6fbae6e3 100644 --- a/cmake/src/media/UAudioPlayback_Portaudio.pas +++ b/cmake/src/media/UAudioPlayback_Portaudio.pas @@ -307,22 +307,16 @@ var paApiIndex : TPaHostApiIndex; paApiInfo : PPaHostApiInfo; paOutDevice : TPaDeviceIndex; - err: TPaError; begin Result := false; - AudioCore := TAudioCore_Portaudio.GetInstance(); // initialize portaudio - err := Pa_Initialize(); - if(err <> paNoError) then - begin - Log.LogError(Pa_GetErrorText(err), 'TAudioInput_Portaudio.InitializeRecord'); + if (not AudioCore.Initialize()) then Exit; - end; paApiIndex := AudioCore.GetPreferredApiIndex(); - if(paApiIndex = -1) then + if (paApiIndex = -1) then begin Log.LogError('No working Audio-API found', 'TAudioPlayback_Portaudio.InitializeAudioPlaybackEngine'); Exit; @@ -364,13 +358,19 @@ end; procedure TAudioPlayback_Portaudio.StopAudioPlaybackEngine(); begin if (paStream <> nil) then - Pa_StopStream(paStream); + begin + Pa_CloseStream(paStream); + // wait until stream is closed, otherwise Terminate() might cause a segfault + while (Pa_IsStreamActive(paStream) = 1) do + ; + paStream := nil; + end; end; function TAudioPlayback_Portaudio.FinalizeAudioPlaybackEngine(): boolean; begin - Pa_Terminate(); - Result := true; + StopAudioPlaybackEngine(); + Result := AudioCore.Terminate(); end; function TAudioPlayback_Portaudio.GetLatency(): double; diff --git a/cmake/src/media/UAudioPlayback_SoftMixer.pas b/cmake/src/media/UAudioPlayback_SoftMixer.pas index c87e461d..11df4df5 100644 --- a/cmake/src/media/UAudioPlayback_SoftMixer.pas +++ b/cmake/src/media/UAudioPlayback_SoftMixer.pas @@ -47,6 +47,8 @@ type TGenericPlaybackStream = class(TAudioPlaybackStream) private Engine: TAudioPlayback_SoftMixer; + LastReadSize: integer; // size of data returned by the last ReadData() call + LastReadTime: Cardinal; // time of the last ReadData() call SampleBuffer: PByteArray; SampleBufferSize: integer; @@ -58,7 +60,7 @@ type SourceBufferCount: integer; // number of available bytes in SourceBuffer Converter: TAudioConverter; - Status: TStreamStatus; + Status: TStreamStatus; InternalLock: PSDL_Mutex; SoundEffects: TList; fVolume: single; @@ -86,6 +88,8 @@ type procedure SetLoop(Enabled: boolean); override; function GetPosition: real; override; procedure SetPosition(Time: real); override; + + function GetRemainingBufferSize(): integer; public constructor Create(Engine: TAudioPlayback_SoftMixer); destructor Destroy(); override; @@ -102,7 +106,7 @@ type function ReadData(Buffer: PByteArray; BufferSize: integer): integer; - function GetPCMData(var Data: TPCMData): Cardinal; override; + function GetPCMData(var Data: TPCMData): cardinal; override; procedure GetFFTData(var Data: TFFTData); override; procedure AddSoundEffect(Effect: TSoundEffect); override; @@ -148,7 +152,7 @@ type function CreatePlaybackStream(): TAudioPlaybackStream; override; public - function GetName: String; override; abstract; + function GetName: string; override; abstract; function InitializePlayback(): boolean; override; function FinalizePlayback: boolean; override; @@ -159,7 +163,7 @@ type function GetMixer(): TAudioMixerStream; {$IFDEF HasInline}inline;{$ENDIF} function GetAudioFormatInfo(): TAudioFormatInfo; - procedure MixBuffers(DstBuffer, SrcBuffer: PByteArray; Size: Cardinal; Volume: Single); virtual; + procedure MixBuffers(DstBuffer, SrcBuffer: PByteArray; Size: cardinal; Volume: single); virtual; end; type @@ -369,6 +373,8 @@ begin fVolume := 0; SoundEffects.Clear; FadeInTime := 0; + + LastReadSize := 0; end; function TGenericPlaybackStream.Open(SourceStream: TAudioSourceStream): boolean; @@ -377,11 +383,11 @@ begin Close(); - if (not assigned(SourceStream)) then + if not assigned(SourceStream) then Exit; Self.SourceStream := SourceStream; - if (not InitFormatConversion()) then + if not InitFormatConversion() then begin // reset decode-stream so it will not be freed on destruction Self.SourceStream := nil; @@ -495,7 +501,11 @@ begin Exit; Status := ssStopped; + // stop fading + FadeInTime := 0; + LastReadSize := 0; + Mixer := Engine.GetMixer(); if (Mixer <> nil) then Mixer.RemoveStream(Self); @@ -543,6 +553,7 @@ begin SampleBufferCount := 0; SampleBufferPos := 0; SourceBufferCount := 0; + LastReadSize := 0; end; procedure TGenericPlaybackStream.ApplySoundEffects(Buffer: PByteArray; BufferSize: integer); @@ -576,6 +587,8 @@ var begin Result := -1; + LastReadSize := 0; + // sanity check for the source-stream if (not assigned(SourceStream)) then Exit; @@ -747,10 +760,12 @@ begin end; // BytesNeeded now contains the number of remaining bytes we were not able to fetch - Result := BufferSize - BytesNeeded; + LastReadTime := SDL_GetTicks; + LastReadSize := BufferSize - BytesNeeded; + Result := LastReadSize; end; -function TGenericPlaybackStream.GetPCMData(var Data: TPCMData): Cardinal; +function TGenericPlaybackStream.GetPCMData(var Data: TPCMData): cardinal; var ByteCount: integer; begin @@ -790,7 +805,7 @@ begin // only works with SInt16 and Float values at the moment AudioFormat := GetAudioFormatInfo(); - DataIn := AllocMem(FFTSize * SizeOf(Single)); + DataIn := AllocMem(FFTSize * SizeOf(single)); if (DataIn = nil) then Exit; @@ -842,6 +857,28 @@ begin UnlockSampleBuffer(); end; +{** + * Returns the approximate number of bytes left in the audio engines buffer queue. + *} +function TGenericPlaybackStream.GetRemainingBufferSize(): integer; +var + TimeDiff: double; +begin + if (LastReadSize <= 0) then + begin + Result := 0; + end + else + begin + TimeDiff := (SDL_GetTicks() - LastReadTime) / 1000; + // we gave the data-sink LastReadSize bytes at the last call to ReadData(). + // Calculate how much of this should be left in the data-sink + Result := LastReadSize - Trunc(TimeDiff * Engine.FormatInfo.BytesPerSec); + if (Result < 0) then + Result := 0; + end; +end; + function TGenericPlaybackStream.GetPosition: real; var BufferedTime: double; @@ -850,11 +887,24 @@ begin begin LockSampleBuffer(); - // calc the time of source data that is buffered (in the SampleBuffer and SourceBuffer) - // but not yet outputed - BufferedTime := (SampleBufferCount - SampleBufferPos) / Engine.FormatInfo.BytesPerSec + - SourceBufferCount / SourceStream.GetAudioFormatInfo().BytesPerSec; - // and subtract it from the source position + // the duration of source stream data that is buffered in this stream. + // (this is the data retrieved from the source but has not been resampled) + BufferedTime := SourceBufferCount / SourceStream.GetAudioFormatInfo().BytesPerSec; + + // the duration of data that is buffered in this stream. + // (this is the already resampled data that has not yet been passed to the audio engine) + BufferedTime := BufferedTime + (SampleBufferCount - SampleBufferPos) / Engine.FormatInfo.BytesPerSec; + + // Now consider the samples left in the engine's (e.g. SDL) buffer. + // Otherwise the result calculated so far will not change until the callback + // is called the next time. + // For example, if the buffer has a size of 2048 frames we would not be + // able to return a new new position for approx. 40ms (at 44.1kHz) which + // would be very bad for synching. + BufferedTime := BufferedTime + GetRemainingBufferSize() / Engine.FormatInfo.BytesPerSec; + + // use the timestamp of the source as reference and subtract the time of + // the data that is still buffered and not yet output. Result := SourceStream.Position - BufferedTime; UnlockSampleBuffer(); @@ -885,7 +935,7 @@ end; function TGenericPlaybackStream.GetVolume(): single; var - FadeAmount: Single; + FadeAmount: single; begin LockSampleBuffer(); // adjust volume if fading is enabled @@ -1033,12 +1083,12 @@ begin //Log.LogStatus('InitializePlayback', 'UAudioPlayback_SoftMixer'); - if(not InitializeAudioPlaybackEngine()) then + if (not InitializeAudioPlaybackEngine()) then Exit; MixerStream := TAudioMixerStream.Create(Self); - if(not StartAudioPlaybackEngine()) then + if (not StartAudioPlaybackEngine()) then Exit; Result := true; @@ -1100,11 +1150,11 @@ begin MixerStream.Volume := Volume; end; -procedure TAudioPlayback_SoftMixer.MixBuffers(DstBuffer, SrcBuffer: PByteArray; Size: Cardinal; Volume: Single); +procedure TAudioPlayback_SoftMixer.MixBuffers(DstBuffer, SrcBuffer: PByteArray; Size: cardinal; Volume: single); var - SampleIndex: Cardinal; - SampleInt: Integer; - SampleFlt: Single; + SampleIndex: cardinal; + SampleInt: integer; + SampleFlt: single; begin SampleIndex := 0; case FormatInfo.Format of @@ -1141,7 +1191,7 @@ begin // assign result PSingle(@DstBuffer[SampleIndex])^ := SampleFlt; // increase index by one sample - Inc(SampleIndex, SizeOf(Single)); + Inc(SampleIndex, SizeOf(single)); end; end; else diff --git a/cmake/src/media/UMediaCore_FFmpeg.pas b/cmake/src/media/UMediaCore_FFmpeg.pas index 9ad19a5b..2d572ff2 100644 --- a/cmake/src/media/UMediaCore_FFmpeg.pas +++ b/cmake/src/media/UMediaCore_FFmpeg.pas @@ -34,12 +34,16 @@ interface {$I switches.inc} uses - UMusic, + Classes, + ctypes, + sdl, avcodec, avformat, avutil, + avio, + UMusic, ULog, - sdl; + UPath; type PPacketQueue = ^TPacketQueue; @@ -95,7 +99,24 @@ type implementation uses - SysUtils; + SysUtils, + UConfig; + +function FFmpegStreamOpen(h: PURLContext; filename: PChar; flags: cint): cint; cdecl; forward; +function FFmpegStreamRead(h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; forward; +function FFmpegStreamWrite(h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; forward; +function FFmpegStreamSeek(h: PURLContext; pos: int64; whence: cint): int64; cdecl; forward; +function FFmpegStreamClose(h: PURLContext): cint; cdecl; forward; + +const + UTF8FileProtocol: TURLProtocol = ( + name: 'ufile'; + url_open: FFmpegStreamOpen; + url_read: FFmpegStreamRead; + url_write: FFmpegStreamWrite; + url_seek: FFmpegStreamSeek; + url_close: FFmpegStreamClose; + ); var Instance: TMediaCore_FFmpeg; @@ -103,6 +124,7 @@ var constructor TMediaCore_FFmpeg.Create(); begin inherited; + av_register_protocol(@UTF8FileProtocol); AVCodecLock := SDL_CreateMutex(); end; @@ -163,6 +185,7 @@ begin begin Stream := FormatCtx.streams[i]; +{$IF LIBAVCODEC_VERSION < 52064000} // < 52.64.0 if (Stream.codec.codec_type = CODEC_TYPE_VIDEO) and (FirstVideoStream < 0) then begin @@ -175,6 +198,20 @@ begin FirstAudioStream := i; end; end; +{$ELSE} + if (Stream.codec.codec_type = AVMEDIA_TYPE_VIDEO) and + (FirstVideoStream < 0) then + begin + FirstVideoStream := i; + end; + + if (Stream.codec.codec_type = AVMEDIA_TYPE_AUDIO) and + (FirstAudioStream < 0) then + begin + FirstAudioStream := i; + end; + end; +{$IFEND} // return true if either an audio- or video-stream was found Result := (FirstAudioStream > -1) or @@ -194,7 +231,11 @@ begin begin Stream := FormatCtx^.streams[i]; +{$IF LIBAVCODEC_VERSION < 52064000} // < 52.64.0 if (Stream.codec^.codec_type = CODEC_TYPE_AUDIO) then +{$ELSE} + if (Stream.codec^.codec_type = AVMEDIA_TYPE_AUDIO) then +{$IFEND} begin StreamIndex := i; Break; @@ -220,6 +261,105 @@ begin Result := true; end; + +{** + * UTF-8 Filename wrapper based on: + * http://www.mail-archive.com/libav-user@mplayerhq.hu/msg02460.html + *} + +function FFmpegStreamOpen(h: PURLContext; filename: PChar; flags: cint): cint; cdecl; +var + Stream: TStream; + Mode: word; + ProtPrefix: string; + FilePath: IPath; +begin + // check for protocol prefix ('ufile:') and strip it + ProtPrefix := Format('%s:', [UTF8FileProtocol.name]); + if (StrLComp(filename, PChar(ProtPrefix), Length(ProtPrefix)) = 0) then + begin + Inc(filename, Length(ProtPrefix)); + end; + + FilePath := Path(filename); + + if ((flags and URL_RDWR) <> 0) then + Mode := fmCreate + else if ((flags and URL_WRONLY) <> 0) then + Mode := fmCreate // TODO: fmCreate is Read+Write -> reopen with fmOpenWrite + else + Mode := fmOpenRead or fmShareDenyWrite; + + Result := 0; + + try + Stream := TBinaryFileStream.Create(FilePath, Mode); + h.priv_data := Stream; + except + Result := AVERROR_NOENT; + end; +end; + +function FFmpegStreamRead(h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; +var + Stream: TStream; +begin + Stream := TStream(h.priv_data); + if (Stream = nil) then + raise EInvalidContainer.Create('FFmpegStreamRead on nil'); + try + Result := Stream.Read(buf[0], size); + except + Result := -1; + end; +end; + +function FFmpegStreamWrite(h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; +var + Stream: TStream; +begin + Stream := TStream(h.priv_data); + if (Stream = nil) then + raise EInvalidContainer.Create('FFmpegStreamWrite on nil'); + try + Result := Stream.Write(buf[0], size); + except + Result := -1; + end; +end; + +function FFmpegStreamSeek(h: PURLContext; pos: int64; whence: cint): int64; cdecl; +var + Stream : TStream; + Origin : TSeekOrigin; +begin + Stream := TStream(h.priv_data); + if (Stream = nil) then + raise EInvalidContainer.Create('FFmpegStreamSeek on nil'); + case whence of + 0 {SEEK_SET}: Origin := soBeginning; + 1 {SEEK_CUR}: Origin := soCurrent; + 2 {SEEK_END}: Origin := soEnd; + AVSEEK_SIZE: begin + Result := Stream.Size; + Exit; + end + else + Origin := soBeginning; + end; + Result := Stream.Seek(pos, Origin); +end; + +function FFmpegStreamClose(h: PURLContext): cint; cdecl; +var + Stream : TStream; +begin + Stream := TStream(h.priv_data); + Stream.Free; + Result := 0; +end; + + { TPacketQueue } constructor TPacketQueue.Create(); diff --git a/cmake/src/media/UMedia_dummy.pas b/cmake/src/media/UMedia_dummy.pas index 7558dd0b..8ebfd3a9 100644 --- a/cmake/src/media/UMedia_dummy.pas +++ b/cmake/src/media/UMedia_dummy.pas @@ -36,22 +36,24 @@ interface implementation uses - SysUtils, - math, - UMusic; + SysUtils, + math, + UTime, + UMusic, + UPath; type - TMedia_dummy = class( TInterfacedObject, IVideoPlayback, IVideoVisualization, IAudioPlayback, IAudioInput ) + TAudio_Dummy = class( TInterfacedObject, IAudioPlayback, IAudioInput ) private DummyOutputDeviceList: TAudioOutputDeviceList; public constructor Create(); - function GetName: string; + function GetName: string; function Init(): boolean; function Finalize(): boolean; - function Open(const aFileName : string): boolean; // true if succeed + function Open(const aFileName: IPath): boolean; // true if succeed procedure Close; procedure Play; @@ -63,9 +65,6 @@ type procedure SetSyncSource(SyncSource: TSyncSource); - procedure GetFrame(Time: Extended); - procedure DrawGL(Screen: integer); - // IAudioInput function InitializeRecord: boolean; function FinalizeRecord: boolean; @@ -82,13 +81,15 @@ type procedure FadeIn(Time: real; TargetVolume: single); procedure SetAppVolume(Volume: single); procedure SetVolume(Volume: single); - procedure SetLoop(Enabled: boolean); procedure Rewind; + procedure SetLoop(Enabled: boolean); + function GetLoop(): boolean; + function Finished: boolean; function Length: real; - function OpenSound(const Filename: string): TAudioPlaybackStream; + function OpenSound(const Filename: IPath): TAudioPlaybackStream; procedure CloseSound(var PlaybackStream: TAudioPlaybackStream); procedure PlaySound(stream: TAudioPlaybackStream); procedure StopSound(stream: TAudioPlaybackStream); @@ -97,98 +98,122 @@ type procedure CloseVoiceStream(var VoiceStream: TAudioVoiceStream); end; -function TMedia_dummy.GetName: string; -begin - Result := 'dummy'; -end; + TVideo_Dummy = class( TInterfacedObject, IVideo ) + public + procedure Close; -procedure TMedia_dummy.GetFrame(Time: Extended); -begin -end; + procedure Play; + procedure Pause; + procedure Stop; + + procedure SetLoop(Enable: boolean); + function GetLoop(): boolean; + + procedure SetPosition(Time: real); + function GetPosition: real; + + procedure GetFrame(Time: Extended); + procedure DrawGL(Screen: integer); + + property Loop: boolean read GetLoop write SetLoop; + property Position: real read GetPosition write SetPosition; + end; -procedure TMedia_dummy.DrawGL(Screen: integer); + TVideoPlayback_Dummy = class( TInterfacedObject, IVideoPlayback, IVideoVisualization ) + public + constructor Create(); + function GetName: string; + + function Init(): boolean; + function Finalize(): boolean; + + function Open(const FileName: IPath): IVideo; + end; + +function TAudio_Dummy.GetName: string; begin + Result := 'AudioDummy'; end; -constructor TMedia_dummy.Create(); +constructor TAudio_Dummy.Create(); begin inherited; end; -function TMedia_dummy.Init(): boolean; +function TAudio_Dummy.Init(): boolean; begin Result := true; end; -function TMedia_dummy.Finalize(): boolean; +function TAudio_Dummy.Finalize(): boolean; begin Result := true; end; -function TMedia_dummy.Open(const aFileName : string): boolean; // true if succeed +function TAudio_Dummy.Open(const aFileName : IPath): boolean; // true if succeed begin Result := false; end; -procedure TMedia_dummy.Close; +procedure TAudio_Dummy.Close; begin end; -procedure TMedia_dummy.Play; +procedure TAudio_Dummy.Play; begin end; -procedure TMedia_dummy.Pause; +procedure TAudio_Dummy.Pause; begin end; -procedure TMedia_dummy.Stop; +procedure TAudio_Dummy.Stop; begin end; -procedure TMedia_dummy.SetPosition(Time: real); +procedure TAudio_Dummy.SetPosition(Time: real); begin end; -function TMedia_dummy.GetPosition: real; +function TAudio_Dummy.GetPosition: real; begin Result := 0; end; -procedure TMedia_dummy.SetSyncSource(SyncSource: TSyncSource); +procedure TAudio_Dummy.SetSyncSource(SyncSource: TSyncSource); begin end; // IAudioInput -function TMedia_dummy.InitializeRecord: boolean; +function TAudio_Dummy.InitializeRecord: boolean; begin Result := true; end; -function TMedia_dummy.FinalizeRecord: boolean; +function TAudio_Dummy.FinalizeRecord: boolean; begin Result := true; end; -procedure TMedia_dummy.CaptureStart; +procedure TAudio_Dummy.CaptureStart; begin end; -procedure TMedia_dummy.CaptureStop; +procedure TAudio_Dummy.CaptureStop; begin end; -procedure TMedia_dummy.GetFFTData(var data: TFFTData); +procedure TAudio_Dummy.GetFFTData(var data: TFFTData); begin end; -function TMedia_dummy.GetPCMData(var data: TPCMData): Cardinal; +function TAudio_Dummy.GetPCMData(var data: TPCMData): Cardinal; begin Result := 0; end; // IAudioPlayback -function TMedia_dummy.InitializePlayback: boolean; +function TAudio_Dummy.InitializePlayback: boolean; begin SetLength(DummyOutputDeviceList, 1); DummyOutputDeviceList[0] := TAudioOutputDevice.Create(); @@ -196,73 +221,152 @@ begin Result := true; end; -function TMedia_dummy.FinalizePlayback: boolean; +function TAudio_Dummy.FinalizePlayback: boolean; begin Result := true; end; -function TMedia_dummy.GetOutputDeviceList(): TAudioOutputDeviceList; +function TAudio_Dummy.GetOutputDeviceList(): TAudioOutputDeviceList; begin Result := DummyOutputDeviceList; end; -procedure TMedia_dummy.SetAppVolume(Volume: single); +procedure TAudio_Dummy.SetAppVolume(Volume: single); +begin +end; + +procedure TAudio_Dummy.SetVolume(Volume: single); begin end; -procedure TMedia_dummy.SetVolume(Volume: single); +procedure TAudio_Dummy.SetLoop(Enabled: boolean); begin end; -procedure TMedia_dummy.SetLoop(Enabled: boolean); +function TAudio_Dummy.GetLoop(): boolean; begin + Result := false; end; -procedure TMedia_dummy.FadeIn(Time: real; TargetVolume: single); +procedure TAudio_Dummy.FadeIn(Time: real; TargetVolume: single); begin end; -procedure TMedia_dummy.Rewind; +procedure TAudio_Dummy.Rewind; begin end; -function TMedia_dummy.Finished: boolean; +function TAudio_Dummy.Finished: boolean; begin Result := false; end; -function TMedia_dummy.Length: real; +function TAudio_Dummy.Length: real; begin Result := 60; end; -function TMedia_dummy.OpenSound(const Filename: string): TAudioPlaybackStream; +function TAudio_Dummy.OpenSound(const Filename: IPath): TAudioPlaybackStream; begin Result := nil; end; -procedure TMedia_dummy.CloseSound(var PlaybackStream: TAudioPlaybackStream); +procedure TAudio_Dummy.CloseSound(var PlaybackStream: TAudioPlaybackStream); begin end; -procedure TMedia_dummy.PlaySound(stream: TAudioPlaybackStream); +procedure TAudio_Dummy.PlaySound(stream: TAudioPlaybackStream); begin end; -procedure TMedia_dummy.StopSound(stream: TAudioPlaybackStream); +procedure TAudio_Dummy.StopSound(stream: TAudioPlaybackStream); begin end; -function TMedia_dummy.CreateVoiceStream(Channel: integer; FormatInfo: TAudioFormatInfo): TAudioVoiceStream; +function TAudio_Dummy.CreateVoiceStream(Channel: integer; FormatInfo: TAudioFormatInfo): TAudioVoiceStream; begin Result := nil; end; -procedure TMedia_dummy.CloseVoiceStream(var VoiceStream: TAudioVoiceStream); +procedure TAudio_Dummy.CloseVoiceStream(var VoiceStream: TAudioVoiceStream); +begin +end; + + +{ TVideoPlayback_Dummy } + +procedure TVideo_Dummy.Close; begin end; +procedure TVideo_Dummy.Play; +begin +end; + +procedure TVideo_Dummy.Pause; +begin +end; + +procedure TVideo_Dummy.Stop; +begin +end; + +procedure TVideo_Dummy.SetLoop(Enable: boolean); +begin +end; + +function TVideo_Dummy.GetLoop(): boolean; +begin + Result := false; +end; + +procedure TVideo_Dummy.SetPosition(Time: real); +begin +end; + +function TVideo_Dummy.GetPosition: real; +begin + Result := 0; +end; + +procedure TVideo_Dummy.GetFrame(Time: Extended); +begin +end; + +procedure TVideo_Dummy.DrawGL(Screen: integer); +begin +end; + + +{ TVideoPlayback_Dummy } + +constructor TVideoPlayback_Dummy.Create(); +begin +end; + +function TVideoPlayback_Dummy.GetName: string; +begin + Result := 'VideoDummy'; +end; + +function TVideoPlayback_Dummy.Init(): boolean; +begin + Result := true; +end; + +function TVideoPlayback_Dummy.Finalize(): boolean; +begin + Result := true; +end; + +function TVideoPlayback_Dummy.Open(const FileName: IPath): IVideo; +begin + Result := TVideo_Dummy.Create; +end; + + initialization - MediaManager.Add(TMedia_dummy.Create); + MediaManager.Add(TAudio_Dummy.Create); + MediaManager.Add(TVideoPlayback_Dummy.Create); end. diff --git a/cmake/src/media/UVideo.pas b/cmake/src/media/UVideo.pas index f55690b2..c7d59fc8 100644 --- a/cmake/src/media/UVideo.pas +++ b/cmake/src/media/UVideo.pas @@ -22,7 +22,7 @@ * $URL$ * $Id$ *} - + unit UVideo; {* @@ -69,8 +69,9 @@ type implementation uses + SysUtils, + Math, SDL, - textgl, avcodec, avformat, avutil, @@ -79,25 +80,36 @@ uses {$IFDEF UseSWScale} swscale, {$ENDIF} - UMediaCore_FFmpeg, - math, gl, + glu, glext, - SysUtils, + textgl, + UMediaCore_FFmpeg, UCommon, UConfig, ULog, UMusic, UGraphicClasses, - UGraphic; + UGraphic, + UPath; + +{$DEFINE PIXEL_FMT_BGR} const {$IFDEF PIXEL_FMT_BGR} PIXEL_FMT_OPENGL = GL_BGR; PIXEL_FMT_FFMPEG = PIX_FMT_BGR24; + PIXEL_FMT_SIZE = 3; + + // looks strange on linux: + //PIXEL_FMT_OPENGL = GL_RGBA; + //PIXEL_FMT_FFMPEG = PIX_FMT_BGR32; + //PIXEL_FMT_SIZE = 4; {$ELSE} + // looks strange on linux: PIXEL_FMT_OPENGL = GL_RGB; PIXEL_FMT_FFMPEG = PIX_FMT_RGB24; + PIXEL_FMT_SIZE = 3; {$ENDIF} type @@ -106,11 +118,15 @@ type Upper, Lower: double; end; - TVideoPlayback_FFmpeg = class( TInterfacedObject, IVideoPlayback ) + IVideo_FFmpeg = interface (IVideo) + ['{E640E130-C8C0-4399-AF02-67A3569313AB}'] + function Open(const FileName: IPath): boolean; + end; + + TVideo_FFmpeg = class( TInterfacedObject, IVideo_FFmpeg ) private fOpened: boolean; //**< stream successfully opened fPaused: boolean; //**< stream paused - fInitialized: boolean; fEOF: boolean; //**< end-of-file state fLoop: boolean; //**< looping enabled @@ -135,43 +151,59 @@ type fAspect: real; //**< width/height ratio fAspectCorrection: TAspectCorrection; - + fTimeBase: extended; //**< FFmpeg time base per time unit - fTime: extended; //**< video time position (absolute) + fFrameTime: extended; //**< video time position (absolute) fLoopTime: extended; //**< start time of the current loop + fPboEnabled: boolean; + fPboId: GLuint; procedure Reset(); function DecodeFrame(): boolean; procedure SynchronizeTime(Frame: PAVFrame; var pts: double); procedure GetVideoRect(var ScreenRect, TexRect: TRectCoords); - + procedure ShowDebugInfo(); public - function GetName: String; + constructor Create; + destructor Destroy; override; + + function Open(const FileName: IPath): boolean; + procedure Close; + + procedure Play; + procedure Pause; + procedure Stop; + + procedure SetLoop(Enable: boolean); + function GetLoop(): boolean; - function Init(): boolean; - function Finalize: boolean; + procedure SetPosition(Time: real); + function GetPosition: real; - function Open(const aFileName : string): boolean; // true if succeed - procedure Close; + procedure GetFrame(Time: Extended); + procedure DrawGL(Screen: integer); + end; + + TVideoPlayback_FFmpeg = class( TInterfacedObject, IVideoPlayback ) + private + fInitialized: boolean; - procedure Play; - procedure Pause; - procedure Stop; + public + function GetName: String; - procedure SetPosition(Time: real); - function GetPosition: real; + function Init(): boolean; + function Finalize: boolean; - procedure GetFrame(Time: Extended); - procedure DrawGL(Screen: integer); + function Open(const FileName : IPath): IVideo; end; var FFmpegCore: TMediaCore_FFmpeg; - + // These are called whenever we allocate a frame buffer. // We use this to store the global_pts in a frame at the time it is allocated. function PtsGetBuffer(CodecCtx: PAVCodecContext; Frame: PAVFrame): integer; cdecl; @@ -218,53 +250,56 @@ begin FFmpegCore := TMediaCore_FFmpeg.GetInstance(); - Reset(); av_register_all(); - glGenTextures(1, PGLuint(@fFrameTex)); end; function TVideoPlayback_FFmpeg.Finalize(): boolean; begin - Close(); - glDeleteTextures(1, PGLuint(@fFrameTex)); Result := true; end; -procedure TVideoPlayback_FFmpeg.Reset(); +function TVideoPlayback_FFmpeg.Open(const FileName : IPath): IVideo; +var + Video: IVideo_FFmpeg; begin - // close previously opened video - Close(); + Video := TVideo_FFmpeg.Create; + if Video.Open(FileName) then + Result := Video + else + Result := nil; +end; - fOpened := False; - fPaused := False; - fTimeBase := 0; - fTime := 0; - fStream := nil; - fStreamIndex := -1; - fFrameTexValid := false; - fEOF := false; +{* TVideo_FFmpeg *} - // TODO: do we really want this by default? - fLoop := true; - fLoopTime := 0; - - fAspectCorrection := acoCrop; +constructor TVideo_FFmpeg.Create; +begin + glGenTextures(1, PGLuint(@fFrameTex)); + Reset(); end; -function TVideoPlayback_FFmpeg.Open(const aFileName : string): boolean; // true if succeed +destructor TVideo_FFmpeg.Destroy; +begin + Close(); + glDeleteTextures(1, PGLuint(@fFrameTex)); +end; + +function TVideo_FFmpeg.Open(const FileName : IPath): boolean; var errnum: Integer; + glErr: GLenum; AudioStreamIndex: integer; begin Result := false; - Reset(); - errnum := av_open_input_file(fFormatContext, PChar(aFileName), nil, 0, nil); + fPboEnabled := PboSupported; + + // use custom 'ufile' protocol for UTF-8 support + errnum := av_open_input_file(fFormatContext, PAnsiChar('ufile:'+FileName.ToUTF8), nil, 0, nil); if (errnum <> 0) then begin - Log.LogError('Failed to open file "'+aFileName+'" ('+FFmpegCore.GetErrorString(errnum)+')'); + Log.LogError('Failed to open file "'+ FileName.ToNative +'" ('+FFmpegCore.GetErrorString(errnum)+')'); Exit; end; @@ -409,20 +444,63 @@ begin fTexWidth := Round(Power(2, Ceil(Log2(fCodecContext^.width)))); fTexHeight := Round(Power(2, Ceil(Log2(fCodecContext^.height)))); + if (fPboEnabled) then + begin + glGetError(); + + glGenBuffersARB(1, @fPboId); + glBindBufferARB(GL_PIXEL_UNPACK_BUFFER_ARB, fPboId); + glBufferDataARB( + GL_PIXEL_UNPACK_BUFFER_ARB, + fCodecContext^.width * fCodecContext^.height * PIXEL_FMT_SIZE, + nil, + GL_STREAM_DRAW_ARB); + glBindBufferARB(GL_PIXEL_UNPACK_BUFFER_ARB, 0); + + glErr := glGetError(); + if (glErr <> GL_NO_ERROR) then + begin + fPboEnabled := false; + Log.LogError('PBO initialization failed: ' + gluErrorString(glErr), 'TVideo_FFmpeg.Open'); + end; + end; + // we retrieve a texture just once with glTexImage2D and update it with glTexSubImage2D later. // Benefits: glTexSubImage2D is faster and supports non-power-of-two widths/height. glBindTexture(GL_TEXTURE_2D, fFrameTex); - glTexEnvi(GL_TEXTURE_2D, GL_TEXTURE_ENV_MODE, GL_REPLACE); glTexImage2D(GL_TEXTURE_2D, 0, 3, fTexWidth, fTexHeight, 0, PIXEL_FMT_OPENGL, GL_UNSIGNED_BYTE, nil); glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); - fOpened := True; + fOpened := true; Result := true; end; -procedure TVideoPlayback_FFmpeg.Close; +procedure TVideo_FFmpeg.Reset(); +begin + // close previously opened video + Close(); + + fOpened := False; + fPaused := False; + fTimeBase := 0; + fFrameTime := 0; + fStream := nil; + fStreamIndex := -1; + fFrameTexValid := false; + + fEOF := false; + + fLoop := false; + fLoopTime := 0; + + fPboId := 0; + + fAspectCorrection := acoCrop; +end; + +procedure TVideo_FFmpeg.Close; begin if (fFrameBuffer <> nil) then av_free(fFrameBuffer); @@ -434,7 +512,7 @@ begin fAVFrame := nil; fAVFrameRGB := nil; fFrameBuffer := nil; - + if (fCodecContext <> nil) then begin // avcodec_close() is not thread-safe @@ -452,37 +530,40 @@ begin fCodecContext := nil; fFormatContext := nil; + if (fPboId <> 0) then + glDeleteBuffersARB(1, @fPboId); + fOpened := False; end; -procedure TVideoPlayback_FFmpeg.SynchronizeTime(Frame: PAVFrame; var pts: double); +procedure TVideo_FFmpeg.SynchronizeTime(Frame: PAVFrame; var pts: double); var FrameDelay: double; begin if (pts <> 0) then begin // if we have pts, set video clock to it - fTime := pts; + fFrameTime := pts; end else begin // if we aren't given a pts, set it to the clock - pts := fTime; + pts := fFrameTime; end; // update the video clock FrameDelay := av_q2d(fCodecContext^.time_base); // if we are repeating a frame, adjust clock accordingly FrameDelay := FrameDelay + Frame^.repeat_pict * (FrameDelay * 0.5); - fTime := fTime + FrameDelay; + fFrameTime := fFrameTime + FrameDelay; end; {** * Decode a new frame from the video stream. - * The decoded frame is stored in fAVFrame. fTime is updated to the new frame's + * The decoded frame is stored in fAVFrame. fFrameTime is updated to the new frame's * time. - * @param pts will be updated to the presentation time of the decoded frame. + * @param pts will be updated to the presentation time of the decoded frame. * returns true if a frame could be decoded. False if an error or EOF occured. *} -function TVideoPlayback_FFmpeg.DecodeFrame(): boolean; +function TVideo_FFmpeg.DecodeFrame(): boolean; var FrameFinished: Integer; VideoPktPts: int64; @@ -520,7 +601,10 @@ begin // check for errors if (url_ferror(pbIOCtx) <> 0) then + begin + Log.LogError('Video decoding file error', 'TVideoPlayback_FFmpeg.DecodeFrame'); Exit; + end; // url_feof() does not detect an EOF for some mov-files (e.g. deluxe.mov) // so we have to do it this way. @@ -531,18 +615,9 @@ begin Exit; end; - // no error -> wait for user input -{ - SDL_Delay(100); // initial version, left for documentation - continue; -} - - // Patch by Hawkear: - // Why should this function loop in an endless loop if there is an error? - // This runs in the main thread, so it halts the whole program - // Therefore, it is better to exit when an error occurs + // error occured, log and exit + Log.LogError('Video decoding error', 'TVideoPlayback_FFmpeg.DecodeFrame'); Exit; - end; // if we got a packet from the video stream, then decode it @@ -573,6 +648,10 @@ begin begin pts := 0; end; + + if fStream^.start_time <> AV_NOPTS_VALUE then + pts := pts - fStream^.start_time; + pts := pts * av_q2d(fStream^.time_base); // synchronize time on each complete frame @@ -587,16 +666,18 @@ begin Result := true; end; -procedure TVideoPlayback_FFmpeg.GetFrame(Time: Extended); +procedure TVideo_FFmpeg.GetFrame(Time: Extended); var errnum: Integer; - NewTime: Extended; - TimeDifference: Extended; + glErr: GLenum; + CurrentTime: Extended; + TimeDiff: Extended; DropFrameCount: Integer; i: Integer; Success: boolean; + BufferPtr: PGLvoid; const - FRAME_DROPCOUNT = 3; + SKIP_FRAME_DIFF = 0.010; // start skipping if we are >= 10ms too late begin if not fOpened then Exit; @@ -604,24 +685,37 @@ begin if fPaused then Exit; + {* + * TODO: + * Check if it is correct to assume that fTimeBase is the time of one frame? + * The tutorial and FFPlay do not make this assumption. + *} + + {* + * Synchronization - begin + *} + // requested stream position (relative to the last loop's start) - NewTime := Time - fLoopTime; + if (fLoop) then + CurrentTime := Time - fLoopTime + else + CurrentTime := Time; // check if current texture still contains the active frame if (fFrameTexValid) then begin // time since the last frame was returned - TimeDifference := NewTime - fTime; + TimeDiff := CurrentTime - fFrameTime; {$IFDEF DebugDisplay} DebugWriteln('Time: '+inttostr(floor(Time*1000)) + sLineBreak + - 'VideoTime: '+inttostr(floor(fTime*1000)) + sLineBreak + + 'VideoTime: '+inttostr(floor(fFrameTime*1000)) + sLineBreak + 'TimeBase: '+inttostr(floor(fTimeBase*1000)) + sLineBreak + 'TimeDiff: '+inttostr(floor(TimeDifference*1000))); {$endif} - // check if last time is more than one frame in the past - if (TimeDifference < fTimeBase) then + // check if time has reached the next frame + if (TimeDiff < fTimeBase) then begin {$ifdef DebugFrames} // frame delay debug display @@ -631,7 +725,7 @@ begin {$IFDEF DebugDisplay} DebugWriteln('not getting new frame' + sLineBreak + 'Time: '+inttostr(floor(Time*1000)) + sLineBreak + - 'VideoTime: '+inttostr(floor(fTime*1000)) + sLineBreak + + 'VideoTime: '+inttostr(floor(fFrameTime*1000)) + sLineBreak + 'TimeBase: '+inttostr(floor(fTimeBase*1000)) + sLineBreak + 'TimeDiff: '+inttostr(floor(TimeDifference*1000))); {$endif} @@ -644,13 +738,16 @@ begin {$IFDEF VideoBenchmark} Log.BenchmarkStart(15); {$ENDIF} - - // fetch new frame (updates fTime) + + // fetch new frame (updates fFrameTime) Success := DecodeFrame(); - TimeDifference := NewTime - fTime; + TimeDiff := CurrentTime - fFrameTime; // check if we have to skip frames - if (TimeDifference >= FRAME_DROPCOUNT*fTimeBase) then + // Either if we are one frame behind or if the skip threshold has been reached. + // Do not skip if the difference is less than fTimeBase as there is no next frame. + // Note: We assume that fTimeBase is the length of one frame. + if (TimeDiff >= Max(fTimeBase, SKIP_FRAME_DIFF)) then begin {$IFDEF DebugFrames} //frame drop debug display @@ -663,15 +760,15 @@ begin {$endif} // update video-time - DropFrameCount := Trunc(TimeDifference / fTimeBase); - fTime := fTime + DropFrameCount*fTimeBase; + DropFrameCount := Trunc(TimeDiff / fTimeBase); + fFrameTime := fFrameTime + DropFrameCount*fTimeBase; - // skip half of the frames, this is much smoother than to skip all at once - for i := 1 to DropFrameCount (*div 2*) do + // skip frames + for i := 1 to DropFrameCount do Success := DecodeFrame(); end; - // check if we got an EOF or error + // check if we got an EOF or error if (not Success) then begin if fLoop then @@ -679,12 +776,16 @@ begin // we have to loop, so rewind SetPosition(0); // record the start-time of the current loop, so we can - // determine the position in the stream (fTime-fLoopTime) later. + // determine the position in the stream (fFrameTime-fLoopTime) later. fLoopTime := Time; end; Exit; end; + {* + * Synchronization - end + *} + // TODO: support for pan&scan //if (fAVFrame.pan_scan <> nil) then //begin @@ -693,11 +794,11 @@ begin // otherwise we convert the pixeldata from YUV to RGB {$IFDEF UseSWScale} - errnum := sws_scale(fSwScaleContext, @(fAVFrame.data), @(fAVFrame.linesize), + errnum := sws_scale(fSwScaleContext, @fAVFrame.data, @fAVFrame.linesize, 0, fCodecContext^.Height, - @(fAVFrameRGB.data), @(fAVFrameRGB.linesize)); + @fAVFrameRGB.data, @fAVFrameRGB.linesize); {$ELSE} - // img_convert from lib/ffmpeg/avcodec.pas is actually deprecated. + // img_convert from lib/ffmpeg/avcodec.pas is actually deprecated. // If ./configure does not find SWScale then this gives the error // that the identifier img_convert is not known or similar. // I think this should be removed, but am not sure whether there should @@ -707,7 +808,7 @@ begin PAVPicture(fAVFrame), fCodecContext^.pix_fmt, fCodecContext^.width, fCodecContext^.height); {$ENDIF} - + if (errnum < 0) then begin Log.LogError('Image conversion failed', 'TVideoPlayback_ffmpeg.GetFrame'); @@ -723,10 +824,51 @@ begin // Or should we add padding with avpicture_fill? (check which one is faster) //glPixelStorei(GL_UNPACK_ALIGNMENT, 1); - glBindTexture(GL_TEXTURE_2D, fFrameTex); - glTexSubImage2D(GL_TEXTURE_2D, 0, 0, 0, - fCodecContext^.width, fCodecContext^.height, - PIXEL_FMT_OPENGL, GL_UNSIGNED_BYTE, fAVFrameRGB^.data[0]); + // glTexEnvi with GL_REPLACE might give a small speed improvement + glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE); + + if (not fPboEnabled) then + begin + glBindTexture(GL_TEXTURE_2D, fFrameTex); + glTexSubImage2D(GL_TEXTURE_2D, 0, 0, 0, + fCodecContext^.width, fCodecContext^.height, + PIXEL_FMT_OPENGL, GL_UNSIGNED_BYTE, fAVFrameRGB^.data[0]); + end + else // fPboEnabled + begin + glGetError(); + + glBindBufferARB(GL_PIXEL_UNPACK_BUFFER_ARB, fPboId); + glBufferDataARB(GL_PIXEL_UNPACK_BUFFER_ARB, + fCodecContext^.height * fCodecContext^.width * PIXEL_FMT_SIZE, + nil, + GL_STREAM_DRAW_ARB); + + bufferPtr := glMapBufferARB(GL_PIXEL_UNPACK_BUFFER_ARB, GL_WRITE_ONLY_ARB); + if(bufferPtr <> nil) then + begin + Move(fAVFrameRGB^.data[0]^, bufferPtr^, + fCodecContext^.height * fCodecContext^.width * PIXEL_FMT_SIZE); + + // release pointer to mapping buffer + glUnmapBufferARB(GL_PIXEL_UNPACK_BUFFER_ARB); + end; + + glBindTexture(GL_TEXTURE_2D, fFrameTex); + glTexSubImage2D(GL_TEXTURE_2D, 0, 0, 0, + fCodecContext^.width, fCodecContext^.height, + PIXEL_FMT_OPENGL, GL_UNSIGNED_BYTE, nil); + + glBindBufferARB(GL_PIXEL_UNPACK_BUFFER_ARB, 0); + glBindTexture(GL_TEXTURE_2D, 0); + + glErr := glGetError(); + if (glErr <> GL_NO_ERROR) then + Log.LogError('PBO texture stream error: ' + gluErrorString(glErr), 'TVideo_FFmpeg.GetFrame'); + end; + + // reset to default + glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE); if (not fFrameTexValid) then fFrameTexValid := true; @@ -743,7 +885,7 @@ begin {$ENDIF} end; -procedure TVideoPlayback_FFmpeg.GetVideoRect(var ScreenRect, TexRect: TRectCoords); +procedure TVideo_FFmpeg.GetVideoRect(var ScreenRect, TexRect: TRectCoords); var ScreenAspect: double; // aspect of screen resolution ScaledVideoWidth, ScaledVideoHeight: double; @@ -793,7 +935,7 @@ begin TexRect.Lower := fCodecContext^.height / fTexHeight; end; -procedure TVideoPlayback_FFmpeg.DrawGL(Screen: integer); +procedure TVideo_FFmpeg.DrawGL(Screen: integer); var ScreenRect: TRectCoords; TexRect: TRectCoords; @@ -856,10 +998,10 @@ begin {$IFEND} end; -procedure TVideoPlayback_FFmpeg.ShowDebugInfo(); +procedure TVideo_FFmpeg.ShowDebugInfo(); begin {$IFDEF Info} - if (fTime+fTimeBase < 0) then + if (fFrameTime+fTimeBase < 0) then begin glColor4f(0.7, 1, 0.3, 1); SetFontStyle (1); @@ -893,28 +1035,39 @@ begin {$ENDIF} end; -procedure TVideoPlayback_FFmpeg.Play; +procedure TVideo_FFmpeg.Play; begin end; -procedure TVideoPlayback_FFmpeg.Pause; +procedure TVideo_FFmpeg.Pause; begin fPaused := not fPaused; end; -procedure TVideoPlayback_FFmpeg.Stop; +procedure TVideo_FFmpeg.Stop; +begin +end; + +procedure TVideo_FFmpeg.SetLoop(Enable: boolean); begin + fLoop := Enable; + fLoopTime := 0; +end; + +function TVideo_FFmpeg.GetLoop(): boolean; +begin + Result := fLoop; end; {** * Sets the stream's position. * The stream is set to the first keyframe with timestamp <= Time. - * Note that fTime is set to Time no matter if the actual position seeked to is - * at Time or the time of a preceding keyframe. fTime will be updated to the + * Note that fFrameTime is set to Time no matter if the actual position seeked to is + * at Time or the time of a preceding keyframe. fFrameTime will be updated to the * actual frame time when GetFrame() is called the next time. * @param Time new position in seconds *} -procedure TVideoPlayback_FFmpeg.SetPosition(Time: real); +procedure TVideo_FFmpeg.SetPosition(Time: real); var SeekFlags: integer; begin @@ -936,9 +1089,9 @@ begin // requested time, let the sync in GetFrame() do its job. SeekFlags := AVSEEK_FLAG_BACKWARD; - fTime := Time; + fFrameTime := Time; fEOF := false; - fFrameTexValid := false; + fFrameTexValid := false; if (av_seek_frame(fFormatContext, fStreamIndex, Floor(Time/fTimeBase), SeekFlags) < 0) then begin @@ -949,9 +1102,9 @@ begin avcodec_flush_buffers(fCodecContext); end; -function TVideoPlayback_FFmpeg.GetPosition: real; +function TVideo_FFmpeg.GetPosition: real; begin - Result := fTime; + Result := fFrameTime; end; initialization diff --git a/cmake/src/media/UVisualizer.pas b/cmake/src/media/UVisualizer.pas index 37e0268a..4f553521 100644 --- a/cmake/src/media/UVisualizer.pas +++ b/cmake/src/media/UVisualizer.pas @@ -60,12 +60,17 @@ interface {$I switches.inc} +{.$DEFINE UseTexture} + uses SDL, UGraphicClasses, textgl, math, gl, + {$IFDEF UseTexture} + glu, + {$ENDIF} SysUtils, UIni, projectM, @@ -77,6 +82,7 @@ uses UGraphic, UMain, UConfig, + UPath, ULog; {$IF PROJECTM_VERSION < 1000000} // < 1.0 @@ -90,31 +96,29 @@ const {$IFEND} type + TProjectMState = ( pmPlay, pmStop, pmPause ); + +type TGLMatrix = array[0..3, 0..3] of GLdouble; TGLMatrixStack = array of TGLMatrix; type - TVideoPlayback_ProjectM = class( TInterfacedObject, IVideoPlayback, IVideoVisualization ) + TVideo_ProjectM = class( TInterfacedObject, IVideo ) private - pm: TProjectM; - ProjectMPath : string; - Initialized: boolean; - - VisualizerStarted: boolean; - VisualizerPaused: boolean; + fPm: TProjectM; + fProjectMPath : string; - VisualTex: GLuint; - PCMData: TPCMData; - RndPCMcount: integer; + fState: TProjectMState; - ModelviewMatrixStack: TGLMatrixStack; - ProjectionMatrixStack: TGLMatrixStack; - TextureMatrixStack: TGLMatrixStack; + fVisualTex: GLuint; + fPCMData: TPCMData; + fRndPCMcount: integer; - procedure VisualizerStart; - procedure VisualizerStop; + fModelviewMatrixStack: TGLMatrixStack; + fProjectionMatrixStack: TGLMatrixStack; + fTextureMatrixStack: TGLMatrixStack; - procedure VisualizerTogglePause; + procedure InitProjectM; function GetRandomPCMData(var Data: TPCMData): Cardinal; @@ -125,12 +129,9 @@ type procedure RestoreOpenGLState(); public - function GetName: String; + constructor Create; + destructor Destroy; override; - function Init(): boolean; - function Finalize(): boolean; - - function Open(const aFileName : string): boolean; // true if succeed procedure Close; procedure Play; @@ -140,10 +141,28 @@ type procedure SetPosition(Time: real); function GetPosition: real; + procedure SetLoop(Enable: boolean); + function GetLoop(): boolean; + procedure GetFrame(Time: Extended); procedure DrawGL(Screen: integer); end; + TVideoPlayback_ProjectM = class( TInterfacedObject, IVideoVisualization ) + private + fInitialized: boolean; + + public + function GetName: String; + + function Init(): boolean; + function Finalize(): boolean; + + function Open(const aFileName: IPath): IVideo; + end; + + +{ TVideoPlayback_ProjectM } function TVideoPlayback_ProjectM.GetName: String; begin @@ -153,76 +172,100 @@ end; function TVideoPlayback_ProjectM.Init(): boolean; begin Result := true; - - if (Initialized) then + if (fInitialized) then Exit; - Initialized := true; + fInitialized := true; +end; - RndPCMcount := 0; +function TVideoPlayback_ProjectM.Finalize(): boolean; +begin + Result := true; +end; + +function TVideoPlayback_ProjectM.Open(const aFileName: IPath): IVideo; +begin + Result := TVideo_ProjectM.Create; +end; - ProjectMPath := ProjectM_DataDir + PathDelim; - VisualizerStarted := False; - VisualizerPaused := False; +{ TVideo_ProjectM } + +constructor TVideo_ProjectM.Create; +begin + fRndPCMcount := 0; + + fProjectMPath := ProjectM_DataDir + PathDelim; + + fState := pmStop; {$IFDEF UseTexture} - glGenTextures(1, PglUint(@VisualTex)); - glBindTexture(GL_TEXTURE_2D, VisualTex); + glGenTextures(1, PglUint(@fVisualTex)); + glBindTexture(GL_TEXTURE_2D, fVisualTex); glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); {$ENDIF} + + InitProjectM(); end; -function TVideoPlayback_ProjectM.Finalize(): boolean; +destructor TVideo_ProjectM.Destroy; begin - VisualizerStop(); + Close(); {$IFDEF UseTexture} - glDeleteTextures(1, PglUint(@VisualTex)); + glDeleteTextures(1, PglUint(@fVisualTex)); {$ENDIF} - Result := true; end; -function TVideoPlayback_ProjectM.Open(const aFileName : string): boolean; // true if succeed +procedure TVideo_ProjectM.Close; begin - Result := false; + FreeAndNil(fPm); end; -procedure TVideoPlayback_ProjectM.Close; +procedure TVideo_ProjectM.Play; begin - VisualizerStop(); + if (fState = pmStop) and (assigned(fPm)) then + fPm.RandomPreset(); + fState := pmPlay; end; -procedure TVideoPlayback_ProjectM.Play; +procedure TVideo_ProjectM.Pause; begin - VisualizerStart(); + if (fState = pmPlay) then + fState := pmPause + else if (fState = pmPause) then + fState := pmPlay; end; -procedure TVideoPlayback_ProjectM.Pause; +procedure TVideo_ProjectM.Stop; begin - VisualizerTogglePause(); + fState := pmStop; end; -procedure TVideoPlayback_ProjectM.Stop; +procedure TVideo_ProjectM.SetPosition(Time: real); begin - VisualizerStop(); + if assigned(fPm) then + fPm.RandomPreset(); end; -procedure TVideoPlayback_ProjectM.SetPosition(Time: real); +function TVideo_ProjectM.GetPosition: real; begin - if assigned(pm) then - pm.RandomPreset(); + Result := 0; end; -function TVideoPlayback_ProjectM.GetPosition: real; +procedure TVideo_ProjectM.SetLoop(Enable: boolean); begin - Result := 0; +end; + +function TVideo_ProjectM.GetLoop(): boolean; +begin + Result := true; end; {** * Returns the stack depth of the given OpenGL matrix mode stack. *} -function TVideoPlayback_ProjectM.GetMatrixStackDepth(MatrixMode: GLenum): GLint; +function TVideo_ProjectM.GetMatrixStackDepth(MatrixMode: GLenum): GLint; begin // get number of matrices on stack case (MatrixMode) of @@ -252,7 +295,7 @@ end; * By saving the whole stack we are on the safe side, so a nasty bug in the * visualizer does not corrupt USDX. *} -procedure TVideoPlayback_ProjectM.SaveMatrixStack(MatrixMode: GLenum; +procedure TVideo_ProjectM.SaveMatrixStack(MatrixMode: GLenum; var MatrixStack: TGLMatrixStack); var I: integer; @@ -288,7 +331,7 @@ end; {** * Restores the OpenGL matrix stack stored with SaveMatrixStack. *} -procedure TVideoPlayback_ProjectM.RestoreMatrixStack(MatrixMode: GLenum; +procedure TVideo_ProjectM.RestoreMatrixStack(MatrixMode: GLenum; var MatrixStack: TGLMatrixStack); var I: integer; @@ -324,15 +367,15 @@ end; * - Modelview-matrix is pushed to the Modelview-stack * - the OpenGL error-state (glGetError) is cleared *} -procedure TVideoPlayback_ProjectM.SaveOpenGLState(); +procedure TVideo_ProjectM.SaveOpenGLState(); begin // save all OpenGL state-machine attributes glPushAttrib(GL_ALL_ATTRIB_BITS); glPushClientAttrib(GL_CLIENT_ALL_ATTRIB_BITS); - SaveMatrixStack(GL_PROJECTION, ProjectionMatrixStack); - SaveMatrixStack(GL_MODELVIEW, ModelviewMatrixStack); - SaveMatrixStack(GL_TEXTURE, TextureMatrixStack); + SaveMatrixStack(GL_PROJECTION, fProjectionMatrixStack); + SaveMatrixStack(GL_MODELVIEW, fModelviewMatrixStack); + SaveMatrixStack(GL_TEXTURE, fTextureMatrixStack); glMatrixMode(GL_MODELVIEW); @@ -344,15 +387,15 @@ end; * Restores the OpenGL state saved by SaveOpenGLState() * and resets the error-state. *} -procedure TVideoPlayback_ProjectM.RestoreOpenGLState(); +procedure TVideo_ProjectM.RestoreOpenGLState(); begin // reset OpenGL error-state glGetError(); // restore matrix stacks - RestoreMatrixStack(GL_PROJECTION, ProjectionMatrixStack); - RestoreMatrixStack(GL_MODELVIEW, ModelviewMatrixStack); - RestoreMatrixStack(GL_TEXTURE, TextureMatrixStack); + RestoreMatrixStack(GL_PROJECTION, fProjectionMatrixStack); + RestoreMatrixStack(GL_MODELVIEW, fModelviewMatrixStack); + RestoreMatrixStack(GL_TEXTURE, fTextureMatrixStack); // restore all OpenGL state-machine attributes // (also restores the matrix mode) @@ -360,22 +403,19 @@ begin glPopAttrib(); end; -procedure TVideoPlayback_ProjectM.VisualizerStart; +procedure TVideo_ProjectM.InitProjectM; begin - if VisualizerStarted then - Exit; - // the OpenGL state must be saved before TProjectM.Create is called SaveOpenGLState(); try try {$IF PROJECTM_VERSION >= 1000000} // >= 1.0 - pm := TProjectM.Create(ProjectMPath + 'config.inp'); + fPm := TProjectM.Create(fProjectMPath + 'config.inp'); {$ELSE} - pm := TProjectM.Create( + fPm := TProjectM.Create( meshX, meshY, fps, textureSize, ScreenW, ScreenH, - ProjectMPath + 'presets', ProjectMPath + 'fonts'); + fProjectMPath + 'presets', fProjectMPath + 'fonts'); {$IFEND} except on E: Exception do begin @@ -386,72 +426,51 @@ begin end; // initialize OpenGL - pm.ResetGL(ScreenW, ScreenH); + fPm.ResetGL(ScreenW, ScreenH); // skip projectM default-preset - pm.RandomPreset(); + fPm.RandomPreset(); // projectM >= 1.0 uses the OpenGL FramebufferObject (FBO) extension. // Unfortunately it does NOT reset the framebuffer-context after // TProjectM.Create. Either glBindFramebufferEXT(GL_FRAMEBUFFER_EXT, 0) for // a manual reset or TProjectM.RenderFrame() must be called. // We use the latter so we do not need to load the FBO extension in USDX. - pm.RenderFrame(); - - VisualizerPaused := false; - VisualizerStarted := true; + fPm.RenderFrame(); finally RestoreOpenGLState(); end; end; -procedure TVideoPlayback_ProjectM.VisualizerStop; -begin - if VisualizerStarted then - begin - VisualizerPaused := false; - VisualizerStarted := false; - FreeAndNil(pm); - end; -end; - -procedure TVideoPlayback_ProjectM.VisualizerTogglePause; -begin - VisualizerPaused := not VisualizerPaused; -end; - -procedure TVideoPlayback_ProjectM.GetFrame(Time: Extended); +procedure TVideo_ProjectM.GetFrame(Time: Extended); var nSamples: cardinal; begin - if not VisualizerStarted then - Exit; - - if VisualizerPaused then + if (fState <> pmPlay) then Exit; // get audio data - nSamples := AudioPlayback.GetPCMData(PcmData); + nSamples := AudioPlayback.GetPCMData(fPCMData); // generate some data if non is available if (nSamples = 0) then - nSamples := GetRandomPCMData(PcmData); + nSamples := GetRandomPCMData(fPCMData); // send audio-data to projectM if (nSamples > 0) then - pm.AddPCM16Data(PSmallInt(@PcmData), nSamples); + fPm.AddPCM16Data(PSmallInt(@fPCMData), nSamples); // store OpenGL state (might be messed up otherwise) SaveOpenGLState(); try // setup projectM's OpenGL state - pm.ResetGL(ScreenW, ScreenH); + fPm.ResetGL(ScreenW, ScreenH); // let projectM render a frame - pm.RenderFrame(); + fPm.RenderFrame(); {$IFDEF UseTexture} - glBindTexture(GL_TEXTURE_2D, VisualTex); + glBindTexture(GL_TEXTURE_2D, fVisualTex); glFlush(); - glCopyTexImage2D(GL_TEXTURE_2D, 0, GL_RGB, 0, 0, VisualWidth, VisualHeight, 0); + glCopyTexImage2D(GL_TEXTURE_2D, 0, GL_RGB, 0, 0, fVisualWidth, fVisualHeight, 0); {$ENDIF} finally // restore USDX OpenGL state @@ -466,7 +485,7 @@ end; * Draws the current frame to screen. * TODO: this is not used yet. Data is directly drawn on GetFrame(). *} -procedure TVideoPlayback_ProjectM.DrawGL(Screen: integer); +procedure TVideo_ProjectM.DrawGL(Screen: integer); begin {$IFDEF UseTexture} // have a nice black background to draw on @@ -477,7 +496,7 @@ begin end; // exit if there's nothing to draw - if not VisualizerStarted then + if (fState <> pmPlay) then Exit; // setup display @@ -496,7 +515,7 @@ begin glEnable(GL_BLEND); glEnable(GL_TEXTURE_2D); glTexEnvf(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE); - glBindTexture(GL_TEXTURE_2D, VisualTex); + glBindTexture(GL_TEXTURE_2D, fVisualTex); glColor4f(1, 1, 1, 1); // draw projectM frame @@ -523,12 +542,12 @@ end; * Produces random "sound"-data in case no audio-data is available. * Otherwise the visualization will look rather boring. *} -function TVideoPlayback_ProjectM.GetRandomPCMData(var Data: TPCMData): Cardinal; +function TVideo_ProjectM.GetRandomPCMData(var Data: TPCMData): Cardinal; var i: integer; begin // Produce some fake PCM data - if (RndPCMcount mod 500 = 0) then + if (fRndPCMcount mod 500 = 0) then begin FillChar(Data, SizeOf(TPCMData), 0); end @@ -540,7 +559,7 @@ begin Data[i][1] := Random(High(Word)+1); end; end; - Inc(RndPCMcount); + Inc(fRndPCMcount); Result := 512; end; diff --git a/cmake/src/menu/UDisplay.pas b/cmake/src/menu/UDisplay.pas index f2eb2ced..e3ec272a 100644 --- a/cmake/src/menu/UDisplay.pas +++ b/cmake/src/menu/UDisplay.pas @@ -35,24 +35,32 @@ interface uses UCommon, + Math, SDL, - UMenu, gl, glu, - SysUtils; + SysUtils, + UMenu, + UPath, + UMusic, + UHookableEvent; type TDisplay = class private + ePreDraw: THookableEvent; + eDraw: THookableEvent; + //fade-to-black-hack BlackScreen: boolean; FadeEnabled: boolean; // true if fading is enabled FadeFailed: boolean; // true if fading is possible (enough memory, etc.) - FadeState: integer; // fading state, 0 means that the fade texture must be initialized - LastFadeTime: cardinal; // last fade update time + FadeTime: cardinal; // time when fading starts, 0 means that the fade texture must be initialized + DoneOnShow: boolean; // true if passed onShow after fading - FadeTex: array[1..2] of GLuint; + FadeTex: array[0..1] of GLuint; + TexW, TexH: Cardinal; FPSCounter: cardinal; LastFPS: cardinal; @@ -72,6 +80,9 @@ type Cursor_Fade: boolean; procedure DrawDebugInformation; + + { called by MoveCursor and OnMouseButton to update last move and start fade in } + procedure UpdateCursorFade; public NextScreen: PMenu; CurrentScreen: PMenu; @@ -86,17 +97,29 @@ type constructor Create; destructor Destroy; override; + procedure InitFadeTextures(); + procedure SaveScreenShot; function Draw: boolean; + { calls ParseInput of cur or next Screen if assigned } + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown : boolean): boolean; + { sets SDL_ShowCursor depending on options set in Ini } procedure SetCursor; { called when cursor moves, positioning of software cursor } - procedure MoveCursor(X, Y: double; Pressed: boolean); + procedure MoveCursor(X, Y: double); + + { called when left or right mousebutton is pressed or released } + procedure OnMouseButton(Pressed: boolean); + { fades to specific screen (playing specified sound) } + function FadeTo(Screen: PMenu; const aSound: TAudioPlaybackStream = nil): PMenu; + + { abort fading to the current screen, may be used in OnShow, or during fade process } + procedure AbortScreenChange; - { draws software cursor } procedure DrawCursor; end; @@ -105,6 +128,9 @@ var Display: TDisplay; const + { constants for screen transition + time in milliseconds } + Transition_Fade_Time = 400; { constants for software cursor effects time in milliseconds } Cursor_FadeIn_Time = 500; // seconds the fade in effect lasts @@ -123,14 +149,17 @@ uses UMain, UTexture, UTime, - UPath; + ULanguage, + UPathUtils; constructor TDisplay.Create; -var - i: integer; begin inherited Create; + // create events for plugins + ePreDraw := THookableEvent.Create('Display.PreDraw'); + eDraw := THookableEvent.Create('Display.Draw'); + //popup hack CheckOK := false; NextScreen := nil; @@ -138,18 +167,13 @@ begin BlackScreen := false; // fade mod - FadeState := 0; + FadeTime := 0; FadeEnabled := (Ini.ScreenFade = 1); FadeFailed := false; + DoneOnShow := false; - glGenTextures(2, @FadeTex); - - for i := 1 to 2 do - begin - glBindTexture(GL_TEXTURE_2D, FadeTex[i]); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); - end; + glGenTextures(2, PGLuint(@FadeTex)); + InitFadeTextures(); //Set LastError for OSD to No Error OSD_LastError := 'No Errors'; @@ -166,16 +190,35 @@ end; destructor TDisplay.Destroy; begin - glDeleteTextures(2, @FadeTex); + glDeleteTextures(2, @FadeTex); inherited Destroy; end; +procedure TDisplay.InitFadeTextures(); +var + i: integer; +begin + TexW := Round(Power(2, Ceil(Log2(ScreenW div Screens)))); + TexH := Round(Power(2, Ceil(Log2(ScreenH)))); + + for i := 0 to 1 do + begin + glBindTexture(GL_TEXTURE_2D, FadeTex[i]); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); + glTexImage2D(GL_TEXTURE_2D, 0, 3, TexW, TexH, 0, GL_RGB, GL_UNSIGNED_BYTE, nil); + end; +end; + function TDisplay.Draw: boolean; var S: integer; FadeStateSquare: real; + FadeW, FadeH: real; + FadeCopyW, FadeCopyH: integer; currentTime: cardinal; glError: glEnum; + begin Result := true; @@ -214,20 +257,25 @@ begin if (not assigned(NextScreen)) and (not BlackScreen) then begin + ePreDraw.CallHookChain(false); CurrentScreen.Draw; //popup mod if (ScreenPopupError <> nil) and ScreenPopupError.Visible then ScreenPopupError.Draw + else if (ScreenPopupInfo <> nil) and ScreenPopupInfo.Visible then + ScreenPopupInfo.Draw else if (ScreenPopupCheck <> nil) and ScreenPopupCheck.Visible then ScreenPopupCheck.Draw; // fade mod - FadeState := 0; + FadeTime := 0; if ((Ini.ScreenFade = 1) and (not FadeFailed)) then FadeEnabled := true else if (Ini.ScreenFade = 0) then FadeEnabled := false; + + eDraw.CallHookChain(false); end else begin @@ -240,95 +288,129 @@ begin if (FadeEnabled and not FadeFailed) then begin //Create Fading texture if we're just starting - if FadeState = 0 then + if FadeTime = 0 then begin - // save old viewport and resize to fit texture - glPushAttrib(GL_VIEWPORT_BIT); - glViewPort(0, 0, 512, 512); - // draw screen that will be faded + ePreDraw.CallHookChain(false); CurrentScreen.Draw; + eDraw.CallHookChain(false); // clear OpenGL errors, otherwise fading might be disabled due to some // older errors in previous OpenGL calls. glGetError(); + FadeCopyW := ScreenW div Screens; + FadeCopyH := ScreenH; + + // it is possible that our fade textures are too small after a window + // resize. In that case resize the fade texture to fit the requirements. + if (TexW < FadeCopyW) or (TexH < FadeCopyH) then + InitFadeTextures(); + // copy screen to texture - glBindTexture(GL_TEXTURE_2D, FadeTex[S]); - glCopyTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, 0, 0, 512, 512, 0); + glBindTexture(GL_TEXTURE_2D, FadeTex[S-1]); + glCopyTexSubImage2D(GL_TEXTURE_2D, 0, 0, 0, (S-1) * ScreenW div Screens, 0, + FadeCopyW, FadeCopyH); + glError := glGetError(); if (glError <> GL_NO_ERROR) then begin FadeFailed := true; - Log.LogWarn('Fading disabled: ' + gluErrorString(glError), 'TDisplay.Draw'); + Log.LogError('Fading disabled: ' + gluErrorString(glError), 'TDisplay.Draw'); end; - // restore viewport - glPopAttrib(); - // blackscreen-hack - if not BlackScreen then - NextScreen.onShow; + if not BlackScreen and (S = 1) and not DoneOnShow then + begin + NextScreen.OnShow; + DoneOnShow := true; + end; - // update fade state - LastFadeTime := SDL_GetTicks(); - if (S = 2) or (Screens = 1) then - FadeState := FadeState + 1; + + // set fade time once on second screen (or first if screens = 1) + if (Screens = 1) or (S = 2) then + FadeTime := SDL_GetTicks; end; // end texture creation in first fading step - //do some time-based fading + {//do some time-based fading currentTime := SDL_GetTicks(); if (currentTime > LastFadeTime+30) and (S = 1) then begin - FadeState := FadeState + 4; + FadeState := FadeState + 5; LastFadeTime := currentTime; - end; + end; } // blackscreen-hack if not BlackScreen then - NextScreen.Draw // draw next screen + begin + ePreDraw.CallHookChain(false); + NextScreen.Draw; // draw next screen + eDraw.CallHookChain(false); + end else if ScreenAct = 1 then begin - glClearColor(0, 0, 0 , 0); + glClearColor(0, 0, 0, 1); glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); end; // and draw old screen over it... slowly fading out + if (FadeTime = 0) then + FadeStateSquare := 0 // for first screen if screens = 2 + else + FadeStateSquare := sqr((SDL_GetTicks - FadeTime) / Transition_Fade_Time); - FadeStateSquare := (FadeState*FadeState)/10000; - - glBindTexture(GL_TEXTURE_2D, FadeTex[S]); - glColor4f(1, 1, 1, 1-FadeStateSquare); - - glEnable(GL_TEXTURE_2D); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - glBegin(GL_QUADS); - glTexCoord2f(0+FadeStateSquare, 0+FadeStateSquare); glVertex2f(0, 600); - glTexCoord2f(0+FadeStateSquare, 1-FadeStateSquare); glVertex2f(0, 0); - glTexCoord2f(1-FadeStateSquare, 1-FadeStateSquare); glVertex2f(800, 0); - glTexCoord2f(1-FadeStateSquare, 0+FadeStateSquare); glVertex2f(800, 600); - glEnd; - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); + if (FadeStateSquare < 1) then + begin + FadeW := (ScreenW div Screens)/TexW; + FadeH := ScreenH/TexH; + + glBindTexture(GL_TEXTURE_2D, FadeTex[S-1]); + // TODO: check if glTexEnvi() gives any speed improvement + //glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE); + glColor4f(1, 1, 1, 1-FadeStateSquare); + + glEnable(GL_TEXTURE_2D); + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); + glEnable(GL_BLEND); + glBegin(GL_QUADS); + glTexCoord2f((0+FadeStateSquare/2)*FadeW, (0+FadeStateSquare/2)*FadeH); + glVertex2f(0, RenderH); + + glTexCoord2f((0+FadeStateSquare/2)*FadeW, (1-FadeStateSquare/2)*FadeH); + glVertex2f(0, 0); + + glTexCoord2f((1-FadeStateSquare/2)*FadeW, (1-FadeStateSquare/2)*FadeH); + glVertex2f(RenderW, 0); + + glTexCoord2f((1-FadeStateSquare/2)*FadeW, (0+FadeStateSquare/2)*FadeH); + glVertex2f(RenderW, RenderH); + glEnd; + glDisable(GL_BLEND); + glDisable(GL_TEXTURE_2D); + + // reset to default + //glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE); + end; end -// blackscreen hack + + // blackscreen hack else if not BlackScreen then begin NextScreen.OnShow; end; - if ((FadeState > 40) or (not FadeEnabled) or FadeFailed) and (S = 1) then + if ((FadeTime + Transition_Fade_Time < SDL_GetTicks) or (not FadeEnabled) or FadeFailed) and ((Screens = 1) or (S = 2)) then begin // fade out complete... - FadeState := 0; + FadeTime := 0; + DoneOnShow := false; CurrentScreen.onHide; CurrentScreen.ShowFinish := false; CurrentScreen := NextScreen; NextScreen := nil; if not BlackScreen then begin - CurrentScreen.onShowFinish; + CurrentScreen.OnShowFinish; CurrentScreen.ShowFinish := true; end else @@ -341,11 +423,11 @@ begin // Draw OSD only on first Screen if Debug Mode is enabled if ((Ini.Debug = 1) or (Params.Debug)) and (S = 1) then - DrawDebugInformation; - end; // for + DrawDebugInformation; - if not BlackScreen then - DrawCursor; + if not BlackScreen then + DrawCursor; + end; // for end; { sets SDL_ShowCursor depending on options set in Ini } @@ -392,35 +474,51 @@ begin end; end; -{ called when cursor moves, positioning of software cursor } -procedure TDisplay.MoveCursor(X, Y: double; Pressed: boolean); +{ called by MoveCursor and OnMouseButton to update last move and start fade in } +procedure TDisplay.UpdateCursorFade; var Ticks: cardinal; begin - if (Ini.Mouse = 2) and - ((X <> Cursor_X) or (Y <> Cursor_Y) or (Pressed <> Cursor_Pressed)) then + Ticks := SDL_GetTicks; + + { fade in on movement (or button press) if not first movement } + if (not Cursor_Visible) and (Cursor_LastMove <> 0) then + begin + if Cursor_Fade then // we use a trick here to consider progress of fade out + Cursor_LastMove := Ticks - round(Cursor_FadeIn_Time * (1 - (Ticks - Cursor_LastMove)/Cursor_FadeOut_Time)) + else + Cursor_LastMove := Ticks; + + Cursor_Visible := true; + Cursor_Fade := true; + end + else if not Cursor_Fade then + begin + Cursor_LastMove := Ticks; + end; +end; + +{ called when cursor moves, positioning of software cursor } +procedure TDisplay.MoveCursor(X, Y: double); +begin + if (Ini.Mouse = 2) and + ((X <> Cursor_X) or (Y <> Cursor_Y)) then begin Cursor_X := X; Cursor_Y := Y; - Cursor_Pressed := Pressed; - Ticks := SDL_GetTicks; + UpdateCursorFade; + end; +end; - { fade in on movement (or button press) if not first movement } - if (not Cursor_Visible) and (Cursor_LastMove <> 0) then - begin - if Cursor_Fade then // we use a trick here to consider progress of fade out - Cursor_LastMove := Ticks - round(Cursor_FadeIn_Time * (1 - (Ticks - Cursor_LastMove)/Cursor_FadeOut_Time)) - else - Cursor_LastMove := Ticks; +{ called when left or right mousebutton is pressed or released } +procedure TDisplay.OnMouseButton(Pressed: boolean); +begin + if (Ini.Mouse = 2) then + begin + Cursor_Pressed := Pressed; - Cursor_Visible := true; - Cursor_Fade := true; - end - else if not Cursor_Fade then - begin - Cursor_LastMove := Ticks; - end; + UpdateCursorFade; end; end; @@ -429,8 +527,9 @@ procedure TDisplay.DrawCursor; var Alpha: single; Ticks: cardinal; + DrawX: double; begin - if (Ini.Mouse = 2) then + if (Ini.Mouse = 2) and ((Screens = 1) or ((ScreenAct - 1) = (Round(Cursor_X+16) div RenderW))) then begin // draw software cursor Ticks := SDL_GetTicks; @@ -471,6 +570,9 @@ begin if (Alpha > 0) and (not Cursor_HiddenByScreen) then begin + DrawX := Cursor_X; + if (ScreenAct = 2) then + DrawX := DrawX - RenderW; glColor4f(1, 1, 1, Alpha); glEnable(GL_TEXTURE_2D); glEnable(GL_BLEND); @@ -483,16 +585,16 @@ begin glBegin(GL_QUADS); glTexCoord2f(0, 0); - glVertex2f(Cursor_X, Cursor_Y); + glVertex2f(DrawX, Cursor_Y); glTexCoord2f(0, 1); - glVertex2f(Cursor_X, Cursor_Y + 32); + glVertex2f(DrawX, Cursor_Y + 32); glTexCoord2f(1, 1); - glVertex2f(Cursor_X + 32, Cursor_Y + 32); + glVertex2f(DrawX + 32, Cursor_Y + 32); glTexCoord2f(1, 0); - glVertex2f(Cursor_X + 32, Cursor_Y); + glVertex2f(DrawX + 32, Cursor_Y); glEnd; glDisable(GL_BLEND); @@ -501,52 +603,101 @@ begin end; end; +function TDisplay.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown : boolean): boolean; +begin + if (assigned(NextScreen)) then + Result := NextScreen^.ParseInput(PressedKey, CharCode, PressedDown) + else if (assigned(CurrentScreen)) then + Result := CurrentScreen^.ParseInput(PressedKey, CharCode, PressedDown) + else + Result := True; +end; + +{ abort fading to the next screen, may be used in OnShow, or during fade process } +procedure TDisplay.AbortScreenChange; + var + Temp: PMenu; +begin + // this is some kind of "hack" it is based on the + // code that is used to change the screens in TDisplay.Draw + // we should rewrite this whole behaviour, as it is not well + // structured and not well extendable. Also we should offer + // a possibility to change screens to plugins + // change this code when restructuring is done + if (assigned(NextScreen)) then + begin + // we have to swap the screens + Temp := CurrentScreen; + CurrentScreen := NextScreen; + NextScreen := Temp; + + // and call the OnShow procedure of the previous screen + // because it was already called by default fade procedure + NextScreen.OnShow; + + end; +end; + +{ fades to specific screen (playing specified sound) + returns old screen } +function TDisplay.FadeTo(Screen: PMenu; const aSound: TAudioPlaybackStream = nil): PMenu; +begin + Result := CurrentScreen; + if (Result <> nil) then + begin + if (aSound <> nil) then + Result.FadeTo(Screen, aSound) + else + Result.FadeTo(Screen); + end; +end; + procedure TDisplay.SaveScreenShot; var Num: integer; - FileName: string; + FileName: IPath; + Prefix: UTF8String; ScreenData: PChar; Surface: PSDL_Surface; Success: boolean; Align: integer; RowSize: integer; begin -// Exit if Screenshot-path does not exist or read-only - if (ScreenshotsPath = '') then + // Exit if Screenshot-path does not exist or read-only + if (ScreenshotsPath.IsUnset) then Exit; for Num := 1 to 9999 do begin - FileName := IntToStr(Num); - while Length(FileName) < 4 do - FileName := '0' + FileName; - FileName := ScreenshotsPath + 'screenshot' + FileName + '.png'; - if not FileExists(FileName) then - break + // fill prefix to 4 digits with leading '0', e.g. '0001' + Prefix := Format('screenshot%.4d', [Num]); + FileName := ScreenshotsPath.Append(Prefix + '.png'); + if not FileName.Exists() then + break; end; -// we must take the row-alignment (4byte by default) into account + // we must take the row-alignment (4byte by default) into account glGetIntegerv(GL_PACK_ALIGNMENT, @Align); -// calc aligned row-size + // calc aligned row-size RowSize := ((ScreenW*3 + (Align-1)) div Align) * Align; GetMem(ScreenData, RowSize * ScreenH); glReadPixels(0, 0, ScreenW, ScreenH, GL_RGB, GL_UNSIGNED_BYTE, ScreenData); -// on big endian machines (powerpc) this may need to be changed to -// Needs to be tests. KaMiSchi Sept 2008 -// in this case one may have to add " glext, " to the list of used units -// glReadPixels(0, 0, ScreenW, ScreenH, GL_BGR, GL_UNSIGNED_BYTE, ScreenData); + // on big endian machines (powerpc) this may need to be changed to + // Needs to be tests. KaMiSchi Sept 2008 + // in this case one may have to add " glext, " to the list of used units + // glReadPixels(0, 0, ScreenW, ScreenH, GL_BGR, GL_UNSIGNED_BYTE, ScreenData); Surface := SDL_CreateRGBSurfaceFrom( ScreenData, ScreenW, ScreenH, 24, RowSize, $0000FF, $00FF00, $FF0000, 0); -// Success := WriteJPGImage(FileName, Surface, 95); -// Success := WriteBMPImage(FileName, Surface); + // Success := WriteJPGImage(FileName, Surface, 95); + // Success := WriteBMPImage(FileName, Surface); Success := WritePNGImage(FileName, Surface); if Success then - ScreenPopupError.ShowPopup('Screenshot saved: ' + ExtractFileName(FileName)) + ScreenPopupInfo.ShowPopup(Format(Language.Translate('SCREENSHOT_SAVED'), [FileName.GetName.ToUTF8()])) else - ScreenPopupError.ShowPopup('Screenshot failed'); + ScreenPopupError.ShowPopup(Language.Translate('SCREENSHOT_FAILED')); SDL_FreeSurface(Surface); FreeMem(ScreenData); @@ -559,7 +710,7 @@ procedure TDisplay.DrawDebugInformation; var Ticks: cardinal; begin -// Some White Background for information + // Some White Background for information glEnable(GL_BLEND); glDisable(GL_TEXTURE_2D); glColor4f(1, 1, 1, 0.5); @@ -571,13 +722,13 @@ begin glEnd; glDisable(GL_BLEND); -// set font specs - SetFontStyle(0); + // set font specs + SetFontStyle(ftNormal); SetFontSize(21); SetFontItalic(false); glColor4f(0, 0, 0, 1); -// calculate fps + // calculate fps Ticks := SDL_GetTicks(); if (Ticks >= NextFPSSwap) then begin @@ -588,17 +739,17 @@ begin Inc(FPSCounter); -// draw text + // draw text -// fps + // fps SetFontPos(695, 0); glPrint ('FPS: ' + InttoStr(LastFPS)); -// rspeed + // rspeed SetFontPos(695, 13); glPrint ('RSpeed: ' + InttoStr(Round(1000 * TimeMid))); -// lasterror + // lasterror SetFontPos(695, 26); glColor4f(1, 0, 0, 1); glPrint (OSD_LastError); diff --git a/cmake/src/menu/UMenu.pas b/cmake/src/menu/UMenu.pas index a3f47b3d..b011eddf 100644 --- a/cmake/src/menu/UMenu.pas +++ b/cmake/src/menu/UMenu.pas @@ -38,6 +38,7 @@ uses Math, gl, SDL, + UPath, UMenuBackground, UMenuButton, UMenuButtonCollection, @@ -67,7 +68,7 @@ type ButtonCollection: array of TButtonCollection; public Text: array of TText; - Static: array of TStatic; + Statics: array of TStatic; mX: integer; // mouse X mY: integer; // mouse Y @@ -81,8 +82,6 @@ type //constructor Create(Back: string; W, H: integer); overload; virtual; // W and H are the number of overlaps // interaction - function WideCharUpperCase(wchar: WideChar) : WideString; - function WideStringUpperCase(wstring: WideString) : WideString; procedure AddInteraction(Typ, Num: integer); procedure SetInteraction(Num: integer); virtual; property Interaction: integer read SelInteraction write SetInteraction; @@ -98,62 +97,62 @@ type // static function AddStatic(ThemeStatic: TThemeStatic): integer; overload; - function AddStatic(X, Y, W, H: real; const Name: string): integer; overload; - function AddStatic(X, Y, W, H: real; const Name: string; Typ: TTextureType): integer; overload; - function AddStatic(X, Y, W, H: real; ColR, ColG, ColB: real; const Name: string; Typ: TTextureType): integer; overload; - function AddStatic(X, Y, W, H, Z: real; ColR, ColG, ColB: real; const Name: string; Typ: TTextureType): integer; overload; - function AddStatic(X, Y, W, H: real; ColR, ColG, ColB: real; const Name: string; Typ: TTextureType; Color: integer): integer; overload; - function AddStatic(X, Y, W, H, Z: real; ColR, ColG, ColB: real; const Name: string; Typ: TTextureType; Color: integer): integer; overload; - function AddStatic(X, Y, W, H, Z: real; ColR, ColG, ColB: real; TexX1, TexY1, TexX2, TexY2: real; const Name: string; Typ: TTextureType; Color: integer; Reflection: boolean; ReflectionSpacing: real): integer; overload; + function AddStatic(X, Y, W, H: real; const TexName: IPath): integer; overload; + function AddStatic(X, Y, W, H: real; const TexName: IPath; Typ: TTextureType): integer; overload; + function AddStatic(X, Y, W, H: real; ColR, ColG, ColB: real; const TexName: IPath; Typ: TTextureType): integer; overload; + function AddStatic(X, Y, W, H, Z: real; ColR, ColG, ColB: real; const TexName: IPath; Typ: TTextureType): integer; overload; + function AddStatic(X, Y, W, H: real; ColR, ColG, ColB: real; const TexName: IPath; Typ: TTextureType; Color: integer): integer; overload; + function AddStatic(X, Y, W, H, Z: real; ColR, ColG, ColB: real; const TexName: IPath; Typ: TTextureType; Color: integer): integer; overload; + function AddStatic(X, Y, W, H, Z: real; ColR, ColG, ColB: real; TexX1, TexY1, TexX2, TexY2: real; const TexName: IPath; Typ: TTextureType; Color: integer; Reflection: boolean; ReflectionSpacing: real): integer; overload; // text function AddText(ThemeText: TThemeText): integer; overload; - function AddText(X, Y: real; const Text_: string): integer; overload; - function AddText(X, Y: real; Style: integer; Size, ColR, ColG, ColB: real; const Text: string): integer; overload; - function AddText(X, Y, W: real; Style: integer; Size, ColR, ColG, ColB: real; Align: integer; const Text_: string; Reflection_: boolean; ReflectionSpacing_: real; Z : real): integer; overload; + function AddText(X, Y: real; const Text_: UTF8String): integer; overload; + function AddText(X, Y: real; Style: integer; Size, ColR, ColG, ColB: real; const Text: UTF8String): integer; overload; + function AddText(X, Y, W: real; Style: integer; Size, ColR, ColG, ColB: real; Align: integer; const Text_: UTF8String; Reflection_: boolean; ReflectionSpacing_: real; Z : real): integer; overload; // button procedure SetButtonLength(Length: cardinal); //Function that Set Length of Button Array in one Step instead of register new Memory for every Button function AddButton(ThemeButton: TThemeButton): integer; overload; - function AddButton(X, Y, W, H: real; const Name: string): integer; overload; - function AddButton(X, Y, W, H: real; const Name: string; Typ: TTextureType; Reflection: boolean): integer; overload; - function AddButton(X, Y, W, H, ColR, ColG, ColB, Int, DColR, DColG, DColB, DInt: real; const Name: string; Typ: TTextureType; Reflection: boolean; ReflectionSpacing, DeSelectReflectionSpacing: real): integer; overload; + function AddButton(X, Y, W, H: real; const TexName: IPath): integer; overload; + function AddButton(X, Y, W, H: real; const TexName: IPath; Typ: TTextureType; Reflection: boolean): integer; overload; + function AddButton(X, Y, W, H, ColR, ColG, ColB, Int, DColR, DColG, DColB, DInt: real; const TexName: IPath; Typ: TTextureType; Reflection: boolean; ReflectionSpacing, DeSelectReflectionSpacing: real): integer; overload; procedure ClearButtons; - procedure AddButtonText(AddX, AddY: real; const AddText: string); overload; - procedure AddButtonText(AddX, AddY: real; ColR, ColG, ColB: real; const AddText: string); overload; - procedure AddButtonText(AddX, AddY: real; ColR, ColG, ColB: real; Font: integer; Size: integer; Align: integer; const AddText: string); overload; - procedure AddButtonText(CustomButton: TButton; AddX, AddY: real; ColR, ColG, ColB: real; Font: integer; Size: integer; Align: integer; const AddText: string); overload; + procedure AddButtonText(AddX, AddY: real; const AddText: UTF8String); overload; + procedure AddButtonText(AddX, AddY: real; ColR, ColG, ColB: real; const AddText: UTF8String); overload; + procedure AddButtonText(AddX, AddY: real; ColR, ColG, ColB: real; Font: integer; Size: integer; Align: integer; const AddText: UTF8String); overload; + procedure AddButtonText(CustomButton: TButton; AddX, AddY: real; ColR, ColG, ColB: real; Font: integer; Size: integer; Align: integer; const AddText: UTF8String); overload; // select slide - function AddSelectSlide(ThemeSelectS: TThemeSelectSlide; var Data: integer; Values: array of string): integer; overload; + function AddSelectSlide(ThemeSelectS: TThemeSelectSlide; var Data: integer; const Values: array of UTF8String): integer; overload; function AddSelectSlide(X, Y, W, H, SkipX, SBGW, ColR, ColG, ColB, Int, DColR, DColG, DColB, DInt, TColR, TColG, TColB, TInt, TDColR, TDColG, TDColB, TDInt, SBGColR, SBGColG, SBGColB, SBGInt, SBGDColR, SBGDColG, SBGDColB, SBGDInt, STColR, STColG, STColB, STInt, STDColR, STDColG, STDColB, STDInt: real; - const Name: string; Typ: TTextureType; const SBGName: string; SBGTyp: TTextureType; - const Caption: string; var Data: integer): integer; overload; - procedure AddSelectSlideOption(const AddText: string); overload; - procedure AddSelectSlideOption(SelectNo: cardinal; const AddText: string); overload; - procedure UpdateSelectSlideOptions(ThemeSelectSlide: TThemeSelectSlide; SelectNum: integer; Values: array of string; var Data: integer); + const TexName: IPath; Typ: TTextureType; const SBGName: IPath; SBGTyp: TTextureType; + const Caption: UTF8String; var Data: integer): integer; overload; + procedure AddSelectSlideOption(const AddText: UTF8String); overload; + procedure AddSelectSlideOption(SelectNo: cardinal; const AddText: UTF8String); overload; + procedure UpdateSelectSlideOptions(ThemeSelectSlide: TThemeSelectSlide; SelectNum: integer; const Values: array of UTF8String; var Data: integer); // function AddWidget(X, Y : UInt16; WidgetSrc : PSDL_Surface): Int16; // procedure ClearWidgets(MinNumber : Int16); procedure FadeTo(Screen: PMenu); overload; procedure FadeTo(Screen: PMenu; aSound: TAudioPlaybackStream); overload; //popup hack - procedure CheckFadeTo(Screen: PMenu; msg: string); + procedure CheckFadeTo(Screen: PMenu; Msg: UTF8String); function DrawBG: boolean; virtual; function DrawFG: boolean; virtual; function Draw: boolean; virtual; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown : boolean): boolean; virtual; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown : boolean): boolean; virtual; function ParseMouse(MouseButton: integer; BtnDown: boolean; X, Y: integer): boolean; virtual; - function InRegion(X1, Y1, W, H, X, Y: real): boolean; + function InRegion(X, Y: real; A: TMouseOverRect): boolean; function InteractAt(X, Y: real): integer; function CollectionAt(X, Y: real): integer; - procedure onShow; virtual; - procedure onShowFinish; virtual; - procedure onHide; virtual; + procedure OnShow; virtual; + procedure OnShowFinish; virtual; + procedure OnHide; virtual; procedure SetAnimationProgress(Progress: real); virtual; @@ -169,6 +168,8 @@ type procedure AddBox(X, Y, W, H: real); end; +function RGBFloatToInt(R, G, B: double): cardinal; + const MENU_MDOWN = 8; MENU_MUP = 0; @@ -205,11 +206,22 @@ uses UMenuBackgroundFade; destructor TMenu.Destroy; +var + I: integer; begin - if (Background <> nil) then - begin - Background.Destroy; - end; + for I := 0 to High(Button) do + Button[I].Free; + for I := 0 to High(ButtonCollection) do + ButtonCollection[I].Free; + for I := 0 to High(SelectsS) do + SelectsS[I].Free; + for I := 0 to High(Text) do + Text[I].Free; + for I := 0 to High(Statics) do + Statics[I].Free; + + Background.Free; + //Log.LogError('Unloaded Succesful: ' + ClassName); inherited; end; @@ -220,7 +232,7 @@ begin Fade := 0;//fWhite; - SetLength(Static, 0); + SetLength(Statics, 0); SetLength(Button, 0); //Set ButtonPos to Autoset Length @@ -337,8 +349,8 @@ begin AddBackground(ThemeBasic.Background); //Add Statics and Texts - for I := 0 to High(ThemeBasic.Static) do - AddStatic(ThemeBasic.Static[I]); + for I := 0 to High(ThemeBasic.Statics) do + AddStatic(ThemeBasic.Statics[I]); for I := 0 to High(ThemeBasic.Text) do AddText(ThemeBasic.Text[I]); @@ -378,11 +390,7 @@ procedure TMenu.AddBackground(ThemedSettings: TThemeBackground); end; begin - if (Background <> nil) then - begin - Background.Destroy; - Background := nil; - end; + FreeAndNil(Background); case ThemedSettings.BGType of bgtAuto: begin //Automaticly choose one out of BGT_Texture, BGT_Video or BGT_Color @@ -391,7 +399,7 @@ begin begin //At first some intelligent try to decide which BG to load - FileExt := lowercase(ExtractFileExt(Skin.GetTextureFileName(ThemedSettings.Tex))); + FileExt := LowerCase(Skin.GetTextureFileName(ThemedSettings.Tex).GetExtension.ToUTF8); if IsInArray(FileExt, SUPPORTED_EXTS_BACKGROUNDTEXTURE) then TryBGCreate(TMenuBackgroundTexture) @@ -599,69 +607,69 @@ begin ThemeStatic.Typ, $FFFFFF, ThemeStatic.Reflection, ThemeStatic.Reflectionspacing); end; -function TMenu.AddStatic(X, Y, W, H: real; const Name: string): integer; +function TMenu.AddStatic(X, Y, W, H: real; const TexName: IPath): integer; begin - Result := AddStatic(X, Y, W, H, Name, TEXTURE_TYPE_PLAIN); + Result := AddStatic(X, Y, W, H, TexName, TEXTURE_TYPE_PLAIN); end; function TMenu.AddStatic(X, Y, W, H: real; - ColR, ColG, ColB: real; - const Name: string; + ColR, ColG, ColB: real; + const TexName: IPath; Typ: TTextureType): integer; begin - Result := AddStatic(X, Y, W, H, ColR, ColG, ColB, Name, Typ, $FFFFFF); + Result := AddStatic(X, Y, W, H, ColR, ColG, ColB, TexName, Typ, $FFFFFF); end; function TMenu.AddStatic(X, Y, W, H, Z: real; - ColR, ColG, ColB: real; - const Name: string; + ColR, ColG, ColB: real; + const TexName: IPath; Typ: TTextureType): integer; begin - Result := AddStatic(X, Y, W, H, Z, ColR, ColG, ColB, Name, Typ, $FFFFFF); + Result := AddStatic(X, Y, W, H, Z, ColR, ColG, ColB, TexName, Typ, $FFFFFF); end; function TMenu.AddStatic(X, Y, W, H: real; - const Name: string; + const TexName: IPath; Typ: TTextureType): integer; var StatNum: integer; begin // adds static - StatNum := Length(Static); - SetLength(Static, StatNum + 1); - Static[StatNum] := TStatic.Create(Texture.GetTexture(Name, Typ, $FF00FF)); // new skin + StatNum := Length(Statics); + SetLength(Statics, StatNum + 1); + Statics[StatNum] := TStatic.Create(Texture.GetTexture(TexName, Typ, $FF00FF)); // new skin // configures static - Static[StatNum].Texture.X := X; - Static[StatNum].Texture.Y := Y; - Static[StatNum].Texture.W := W; - Static[StatNum].Texture.H := H; - Static[StatNum].Visible := true; + Statics[StatNum].Texture.X := X; + Statics[StatNum].Texture.Y := Y; + Statics[StatNum].Texture.W := W; + Statics[StatNum].Texture.H := H; + Statics[StatNum].Visible := true; Result := StatNum; end; function TMenu.AddStatic(X, Y, W, H: real; ColR, ColG, ColB: real; - const Name: string; + const TexName: IPath; Typ: TTextureType; Color: integer): integer; begin - Result := AddStatic(X, Y, W, H, 0, ColR, ColG, ColB, Name, Typ, Color); + Result := AddStatic(X, Y, W, H, 0, ColR, ColG, ColB, TexName, Typ, Color); end; function TMenu.AddStatic(X, Y, W, H, Z: real; ColR, ColG, ColB: real; - const Name: string; + const TexName: IPath; Typ: TTextureType; Color: integer): integer; begin - Result := AddStatic(X, Y, W, H, Z, ColR, ColG, ColB, 0, 0, 1, 1, Name, Typ, Color, false, 0); + Result := AddStatic(X, Y, W, H, Z, ColR, ColG, ColB, 0, 0, 1, 1, TexName, Typ, Color, false, 0); end; function TMenu.AddStatic(X, Y, W, H, Z: real; ColR, ColG, ColB: real; TexX1, TexY1, TexX2, TexY2: real; - const Name: string; + const TexName: IPath; Typ: TTextureType; Color: integer; Reflection: boolean; @@ -670,52 +678,52 @@ var StatNum: integer; begin // adds static - StatNum := Length(Static); - SetLength(Static, StatNum + 1); + StatNum := Length(Statics); + SetLength(Statics, StatNum + 1); // colorize hack if (Typ = TEXTURE_TYPE_COLORIZED) then begin // give encoded color to GetTexture() - Static[StatNum] := TStatic.Create(Texture.GetTexture(Name, Typ, RGBFloatToInt(ColR, ColG, ColB))); + Statics[StatNum] := TStatic.Create(Texture.GetTexture(TexName, Typ, RGBFloatToInt(ColR, ColG, ColB))); end else begin - Static[StatNum] := TStatic.Create(Texture.GetTexture(Name, Typ, Color)); // new skin + Statics[StatNum] := TStatic.Create(Texture.GetTexture(TexName, Typ, Color)); // new skin end; // configures static - Static[StatNum].Texture.X := X; - Static[StatNum].Texture.Y := Y; + Statics[StatNum].Texture.X := X; + Statics[StatNum].Texture.Y := Y; //Set height and width via sprite size if omitted if(H = 0) then - Static[StatNum].Texture.H := Static[StatNum].Texture.H + Statics[StatNum].Texture.H := Statics[StatNum].Texture.H else - Static[StatNum].Texture.H := H; + Statics[StatNum].Texture.H := H; if(W = 0) then - Static[StatNum].Texture.W := Static[StatNum].Texture.W + Statics[StatNum].Texture.W := Statics[StatNum].Texture.W else - Static[StatNum].Texture.W := W; + Statics[StatNum].Texture.W := W; - Static[StatNum].Texture.Z := Z; + Statics[StatNum].Texture.Z := Z; if (Typ <> TEXTURE_TYPE_COLORIZED) then begin - Static[StatNum].Texture.ColR := ColR; - Static[StatNum].Texture.ColG := ColG; - Static[StatNum].Texture.ColB := ColB; + Statics[StatNum].Texture.ColR := ColR; + Statics[StatNum].Texture.ColG := ColG; + Statics[StatNum].Texture.ColB := ColB; end; - Static[StatNum].Texture.TexX1 := TexX1; - Static[StatNum].Texture.TexY1 := TexY1; - Static[StatNum].Texture.TexX2 := TexX2; - Static[StatNum].Texture.TexY2 := TexY2; - Static[StatNum].Texture.Alpha := 1; - Static[StatNum].Visible := true; + Statics[StatNum].Texture.TexX1 := TexX1; + Statics[StatNum].Texture.TexY1 := TexY1; + Statics[StatNum].Texture.TexX2 := TexX2; + Statics[StatNum].Texture.TexY2 := TexY2; + Statics[StatNum].Texture.Alpha := 1; + Statics[StatNum].Visible := true; //ReflectionMod - Static[StatNum].Reflection := Reflection; - Static[StatNum].ReflectionSpacing := ReflectionSpacing; + Statics[StatNum].Reflection := Reflection; + Statics[StatNum].ReflectionSpacing := ReflectionSpacing; Result := StatNum; end; @@ -726,7 +734,7 @@ begin ThemeText.ColR, ThemeText.ColG, ThemeText.ColB, ThemeText.Align, ThemeText.Text, ThemeText.Reflection, ThemeText.ReflectionSpacing, ThemeText.Z); end; -function TMenu.AddText(X, Y: real; const Text_: string): integer; +function TMenu.AddText(X, Y: real; const Text_: UTF8String): integer; var TextNum: integer; begin @@ -739,20 +747,20 @@ end; function TMenu.AddText(X, Y: real; Style: integer; - Size, ColR, ColG, ColB: real - ; const Text: string): integer; + Size, ColR, ColG, ColB: real; + const Text: UTF8String): integer; begin Result := AddText(X, Y, 0, Style, Size, ColR, ColG, ColB, 0, Text, false, 0, 0); end; function TMenu.AddText(X, Y, W: real; Style: integer; - Size, ColR, ColG, ColB: real; - Align: integer; - const Text_: string; - Reflection_: boolean; - ReflectionSpacing_: real; - Z : real): integer; + Size, ColR, ColG, ColB: real; + Align: integer; + const Text_: UTF8String; + Reflection_: boolean; + ReflectionSpacing_: real; + Z : real): integer; var TextNum: integer; begin @@ -839,22 +847,20 @@ begin Button[Result].Texture.Alpha := 0; end; end; - Log.BenchmarkEnd(6); - Log.LogBenchmark('====> Screen Options32', 6); end; -function TMenu.AddButton(X, Y, W, H: real; const Name: string): integer; +function TMenu.AddButton(X, Y, W, H: real; const TexName: IPath): integer; begin - Result := AddButton(X, Y, W, H, Name, TEXTURE_TYPE_PLAIN, false); + Result := AddButton(X, Y, W, H, TexName, TEXTURE_TYPE_PLAIN, false); end; -function TMenu.AddButton(X, Y, W, H: real; const Name: string; Typ: TTextureType; Reflection: boolean): integer; +function TMenu.AddButton(X, Y, W, H: real; const TexName: IPath; Typ: TTextureType; Reflection: boolean): integer; begin - Result := AddButton(X, Y, W, H, 1, 1, 1, 1, 1, 1, 1, 0.5, Name, TEXTURE_TYPE_PLAIN, Reflection, 15, 15); + Result := AddButton(X, Y, W, H, 1, 1, 1, 1, 1, 1, 1, 0.5, TexName, TEXTURE_TYPE_PLAIN, Reflection, 15, 15); end; function TMenu.AddButton(X, Y, W, H, ColR, ColG, ColB, Int, DColR, DColG, DColB, DInt: real; - const Name: string; + const TexName: IPath; Typ: TTextureType; Reflection: boolean; ReflectionSpacing, DeSelectReflectionSpacing: real): integer; @@ -876,12 +882,12 @@ begin if (Typ = TEXTURE_TYPE_COLORIZED) then begin // give encoded color to GetTexture() - Button[Result] := TButton.Create(Texture.GetTexture(Name, Typ, RGBFloatToInt(ColR, ColG, ColB)), - Texture.GetTexture(Name, Typ, RGBFloatToInt(DColR, DColG, DColB))); + Button[Result] := TButton.Create(Texture.GetTexture(TexName, Typ, RGBFloatToInt(ColR, ColG, ColB)), + Texture.GetTexture(TexName, Typ, RGBFloatToInt(DColR, DColG, DColB))); end else begin - Button[Result] := TButton.Create(Texture.GetTexture(Name, Typ)); + Button[Result] := TButton.Create(Texture.GetTexture(TexName, Typ)); end; // configures button @@ -935,11 +941,11 @@ var J: integer; begin // We don't forget about newly implemented static for nice skin ... - for J := 0 to Length(Static) - 1 do - Static[J].Draw; + for J := 0 to High(Statics) do + Statics[J].Draw; // ... and slightly implemented menutext unit - for J := 0 to Length(Text) - 1 do + for J := 0 to High(Text) do Text[J].Draw; // Draw all ButtonCollections @@ -947,10 +953,10 @@ begin ButtonCollection[J].Draw; // Second, we draw all of our buttons - for J := 0 to Length(Button) - 1 do + for J := 0 to High(Button) do Button[J].Draw; - for J := 0 to Length(SelectsS) - 1 do + for J := 0 to High(SelectsS) do SelectsS[J].Draw; // Third, we draw all our widgets @@ -1178,21 +1184,41 @@ begin AudioPlayback.PlaySound( aSound ); end; +procedure OnSaveEncodingError(Value: boolean; Data: Pointer); +begin + Display.CheckOK := Value; + if (Value) then + begin + //Hack to Finish Singscreen correct on Exit with Q Shortcut + if (Display.NextScreenWithCheck = nil) then + begin + if (Display.CurrentScreen = @ScreenSing) then + ScreenSing.Finish + {else if (Display.CurrentScreen = @ScreenSingModi) then + ScreenSingModi.Finish;} + end; + end + else + begin + Display.NextScreenWithCheck := nil; + end; +end; + //popup hack -procedure TMenu.CheckFadeTo(Screen: PMenu; msg: string); +procedure TMenu.CheckFadeTo(Screen: PMenu; Msg: UTF8String); begin Display.Fade := 0; Display.NextScreenWithCheck := Screen; Display.CheckOK := false; - ScreenPopupCheck.ShowPopup(msg); + ScreenPopupCheck.ShowPopup(msg, OnSaveEncodingError, nil, false); end; -procedure TMenu.AddButtonText(AddX, AddY: real; const AddText: string); +procedure TMenu.AddButtonText(AddX, AddY: real; const AddText: UTF8String); begin AddButtonText(AddX, AddY, 1, 1, 1, AddText); end; -procedure TMenu.AddButtonText(AddX, AddY: real; ColR, ColG, ColB: real; const AddText: string); +procedure TMenu.AddButtonText(AddX, AddY: real; ColR, ColG, ColB: real; const AddText: UTF8String); var Il: integer; begin @@ -1208,7 +1234,7 @@ begin end; end; -procedure TMenu.AddButtonText(AddX, AddY: real; ColR, ColG, ColB: real; Font: integer; Size: integer; Align: integer; const AddText: string); +procedure TMenu.AddButtonText(AddX, AddY: real; ColR, ColG, ColB: real; Font: integer; Size: integer; Align: integer; const AddText: UTF8String); var Il: integer; begin @@ -1227,7 +1253,7 @@ begin end; end; -procedure TMenu.AddButtonText(CustomButton: TButton; AddX, AddY: real; ColR, ColG, ColB: real; Font: integer; Size: integer; Align: integer; const AddText: string); +procedure TMenu.AddButtonText(CustomButton: TButton; AddX, AddY: real; ColR, ColG, ColB: real; Font: integer; Size: integer; Align: integer; const AddText: UTF8String); var Il: integer; begin @@ -1246,7 +1272,7 @@ begin end; end; -function TMenu.AddSelectSlide(ThemeSelectS: TThemeSelectSlide; var Data: integer; Values: array of string): integer; +function TMenu.AddSelectSlide(ThemeSelectS: TThemeSelectSlide; var Data: integer; const Values: array of UTF8String): integer; var SO: integer; begin @@ -1259,8 +1285,8 @@ begin ThemeSelectS.SBGDColR, ThemeSelectS.SBGDColG, ThemeSelectS.SBGDColB, ThemeSelectS.SBGDInt, ThemeSelectS.STColR, ThemeSelectS.STColG, ThemeSelectS.STColB, ThemeSelectS.STInt, ThemeSelectS.STDColR, ThemeSelectS.STDColG, ThemeSelectS.STDColB, ThemeSelectS.STDInt, - Skin.GetTextureFileName(ThemeSelectS.Tex), TEXTURE_TYPE_COLORIZED, - Skin.GetTextureFileName(ThemeSelectS.TexSBG), TEXTURE_TYPE_COLORIZED, + Skin.GetTextureFileName(ThemeSelectS.Tex), ThemeSelectS.Typ, + Skin.GetTextureFileName(ThemeSelectS.TexSBG), ThemeSelectS.TypSBG, ThemeSelectS.Text, Data); for SO := 0 to High(Values) do AddSelectSlideOption(Values[SO]); @@ -1269,6 +1295,8 @@ begin SelectsS[High(SelectsS)].Texture.Z := ThemeSelectS.Z; SelectsS[High(SelectsS)].TextureSBG.Z := ThemeSelectS.Z; + SelectsS[High(SelectsS)].Tex_SelectS_ArrowL.Z := ThemeSelectS.Z; + SelectsS[High(SelectsS)].Tex_SelectS_ArrowR.Z := ThemeSelectS.Z; SelectsS[High(SelectsS)].showArrows := ThemeSelectS.showArrows; SelectsS[High(SelectsS)].oneItemOnly := ThemeSelectS.oneItemOnly; @@ -1283,8 +1311,8 @@ function TMenu.AddSelectSlide(X, Y, W, H, SkipX, SBGW, ColR, ColG, ColB, Int, DC TColR, TColG, TColB, TInt, TDColR, TDColG, TDColB, TDInt, SBGColR, SBGColG, SBGColB, SBGInt, SBGDColR, SBGDColG, SBGDColB, SBGDInt, STColR, STColG, STColB, STInt, STDColR, STDColG, STDColB, STDInt: real; - const Name: string; Typ: TTextureType; const SBGName: string; SBGTyp: TTextureType; - const Caption: string; var Data: integer): integer; + const TexName: IPath; Typ: TTextureType; const SBGName: IPath; SBGTyp: TTextureType; + const Caption: UTF8String; var Data: integer): integer; var S: integer; I: integer; @@ -1294,37 +1322,67 @@ begin SelectsS[S] := TSelectSlide.Create; if (Typ = TEXTURE_TYPE_COLORIZED) then - SelectsS[S].Texture := Texture.GetTexture(Name, Typ, RGBFloatToInt(ColR, ColG, ColB)) + begin + SelectsS[S].Colorized := true; + SelectsS[S].Texture := Texture.GetTexture(TexName, Typ, RGBFloatToInt(ColR, ColG, ColB)); + SelectsS[S].DeselectTexture := Texture.GetTexture(TexName, Typ, RGBFloatToInt(DColR, DColG, DColB)); + end else - SelectsS[S].Texture := Texture.GetTexture(Name, Typ); + begin + SelectsS[S].Colorized := false; + SelectsS[S].Texture := Texture.GetTexture(TexName, Typ); + + SelectsS[S].ColR := ColR; + SelectsS[S].ColG := ColG; + SelectsS[S].ColB := ColB; + + SelectsS[S].DColR := DColR; + SelectsS[S].DColG := DColG; + SelectsS[S].DColB := DColB; + end; + + SelectsS[S].Int := Int; + SelectsS[S].DInt := DInt; + SelectsS[S].X := X; SelectsS[S].Y := Y; SelectsS[S].W := W; - SelectsS[S].H := H; - - SelectsS[S].ColR := ColR; - SelectsS[S].ColG := ColG; - SelectsS[S].ColB := ColB; - SelectsS[S].Int := Int; - SelectsS[S].DColR := DColR; - SelectsS[S].DColG := DColG; - SelectsS[S].DColB := DColB; - SelectsS[S].DInt := DInt; + SelectsS[S].H := H; if (SBGTyp = TEXTURE_TYPE_COLORIZED) then - SelectsS[S].TextureSBG := Texture.GetTexture(SBGName, SBGTyp, RGBFloatToInt(SBGColR, SBGColG, SBGColB)) + begin + SelectsS[S].ColorizedSBG := true; + SelectsS[S].TextureSBG := Texture.GetTexture(SBGName, SBGTyp, RGBFloatToInt(SBGColR, SBGColG, SBGColB)); + SelectsS[S].DeselectTextureSBG := Texture.GetTexture(SBGName, SBGTyp, RGBFloatToInt(SBGDColR, SBGDColG, SBGDColB)); + end else + begin + SelectsS[S].ColorizedSBG := false; SelectsS[S].TextureSBG := Texture.GetTexture(SBGName, SBGTyp); + SelectsS[S].SBGColR := SBGColR; + SelectsS[S].SBGColG := SBGColG; + SelectsS[S].SBGColB := SBGColB; + + SelectsS[S].SBGDColR := SBGDColR; + SelectsS[S].SBGDColG := SBGDColG; + SelectsS[S].SBGDColB := SBGDColB; + end; + + + SelectsS[S].SBGInt := SBGInt; + SelectsS[S].SBGDInt := SBGDInt; + SelectsS[High(SelectsS)].Tex_SelectS_ArrowL := Tex_SelectS_ArrowL; SelectsS[High(SelectsS)].Tex_SelectS_ArrowL.X := X + W + SkipX; - SelectsS[High(SelectsS)].Tex_SelectS_ArrowL.Y := Y; + SelectsS[High(SelectsS)].Tex_SelectS_ArrowL.Y := Y + (H - Tex_SelectS_ArrowL.H) / 2; SelectsS[High(SelectsS)].Tex_SelectS_ArrowL.W := Tex_SelectS_ArrowL.W; SelectsS[High(SelectsS)].Tex_SelectS_ArrowL.H := Tex_SelectS_ArrowL.H; + SelectsS[High(SelectsS)].Tex_SelectS_ArrowR := Tex_SelectS_ArrowR; SelectsS[High(SelectsS)].Tex_SelectS_ArrowR.X := X + W + SkipX + SBGW - Tex_SelectS_ArrowR.W; - SelectsS[High(SelectsS)].Tex_SelectS_ArrowR.Y := Y; + SelectsS[High(SelectsS)].Tex_SelectS_ArrowR.Y := Y + (H - Tex_SelectS_ArrowR.H) / 2; SelectsS[High(SelectsS)].Tex_SelectS_ArrowR.W := Tex_SelectS_ArrowR.W; SelectsS[High(SelectsS)].Tex_SelectS_ArrowR.H := Tex_SelectS_ArrowR.H; @@ -1332,14 +1390,6 @@ begin SelectsS[S].TextureSBG.Y := Y; SelectsS[S].SBGW := SBGW; SelectsS[S].TextureSBG.H := H; - SelectsS[S].SBGColR := SBGColR; - SelectsS[S].SBGColG := SBGColG; - SelectsS[S].SBGColB := SBGColB; - SelectsS[S].SBGInt := SBGInt; - SelectsS[S].SBGDColR := SBGDColR; - SelectsS[S].SBGDColG := SBGDColG; - SelectsS[S].SBGDColB := SBGDColB; - SelectsS[S].SBGDInt := SBGDInt; SelectsS[S].Text.X := X + 20; SelectsS[S].Text.Y := Y + (SelectsS[S].TextureSBG.H / 2) - 15; @@ -1414,12 +1464,12 @@ begin Result := S; end; -procedure TMenu.AddSelectSlideOption(const AddText: string); +procedure TMenu.AddSelectSlideOption(const AddText: UTF8String); begin AddSelectSlideOption(High(SelectsS), AddText); end; -procedure TMenu.AddSelectSlideOption(SelectNo: cardinal; const AddText: string); +procedure TMenu.AddSelectSlideOption(SelectNo: cardinal; const AddText: UTF8String); var SO: integer; begin @@ -1435,7 +1485,8 @@ begin } end; -procedure TMenu.UpdateSelectSlideOptions(ThemeSelectSlide: TThemeSelectSlide; SelectNum: integer; Values: array of string; var Data: integer); +procedure TMenu.UpdateSelectSlideOptions(ThemeSelectSlide: TThemeSelectSlide; + SelectNum: integer; const Values: array of UTF8String; var Data: integer); var SO: integer; begin @@ -1560,7 +1611,7 @@ begin AddStatic(X+2, Y+2, W-4, H-4, 1, 1, 1, Skin.GetTextureFileName('MainBar'), TEXTURE_TYPE_COLORIZED); end; -procedure TMenu.onShow; +procedure TMenu.OnShow; begin // FIXME: this needs some work. First, there should be a variable like // VideoBackground so we can check whether a video-background is enabled or not. @@ -1589,57 +1640,18 @@ begin Background.OnShow; end; -procedure TMenu.onShowFinish; +procedure TMenu.OnShowFinish; begin // nothing end; -(* - * Wrapper for WideUpperCase. Needed because some plattforms have problems with - * unicode support. - *) -function TMenu.WideCharUpperCase(wchar: WideChar) : WideString; -begin - // On Linux and MacOSX the cwstring unit is necessary for Unicode function-calls. - // Otherwise you will get an EIntOverflow exception (thrown by unimplementedwidestring()). - // The Unicode manager cwstring does not work with MacOSX at the moment because - // of missing references to iconv. So we have to use Ansi... for the moment. - - // cwstring crashes in FPC 2.2.2 so do not use the cwstring stuff - {.$IFNDEF DARWIN} - {$IFDEF NOIGNORE} - // The FPC implementation of WideUpperCase returns nil if wchar is #0 (e.g. if an arrow key is pressed) - if (wchar <> #0) then - Result := WideUpperCase(wchar) - else - Result := #0; - {$ELSE} - Result := AnsiUpperCase(wchar) - {$ENDIF} -end; - -(* - * Wrapper for WideUpperCase. Needed because some plattforms have problems with - * unicode support. - *) -function TMenu.WideStringUpperCase(wstring: WideString) : WideString; -begin - // cwstring crashes in FPC 2.2.2 so do not use the cwstring stuff - {.$IFNDEF DARWIN} - {$IFDEF NOIGNORE} - Result := WideUpperCase(wstring) - {$ELSE} - Result := AnsiUpperCase(wstring); - {$ENDIF} -end; - -procedure TMenu.onHide; +procedure TMenu.OnHide; begin // nothing Background.OnFinish; end; -function TMenu.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TMenu.ParseInput(PressedKey: Cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin // nothing Result := true; @@ -1648,6 +1660,7 @@ end; function TMenu.ParseMouse(MouseButton: integer; BtnDown: boolean; X, Y: integer): boolean; var nBut: integer; + Action: TMouseClickAction; begin //default mouse parsing: clicking generates return keypress, // mousewheel selects in select slide @@ -1657,55 +1670,80 @@ begin if RightMbESC and (MouseButton = SDL_BUTTON_RIGHT) and BtnDown then begin //if RightMbESC is set, send ESC keypress - Result:=ParseInput(SDLK_ESCAPE, #0, true); + Result:=ParseInput(SDLK_ESCAPE, 0, true); end; - nBut := InteractAt(X, Y); - if nBut >= 0 then + // transfer mousecords to the 800x600 raster we use to draw + X := Round((X / (ScreenW / Screens)) * RenderW); + if (X > RenderW) then + X := X - RenderW; + Y := Round((Y / ScreenH) * RenderH); + + // allways go to next screen if we don't have any interactions + if Length(Interactions) = 0 then begin - //select on mouse-over - if nBut <> Interaction then - SetInteraction(nBut); - if (MouseButton = SDL_BUTTON_LEFT) and BtnDown then - begin - //click button - Result:=ParseInput(SDLK_RETURN, #0, true); - end; - if (Interactions[nBut].Typ = iSelectS) then - begin - //forward/backward in select slide with mousewheel - if (MouseButton = SDL_BUTTON_WHEELDOWN) and BtnDown then - begin - ParseInput(SDLK_RIGHT, #0, true); - end; - if (MouseButton = SDL_BUTTON_WHEELUP) and BtnDown then - begin - ParseInput(SDLK_LEFT, #0, true); - end; - end; + if (BtnDown) and (MouseButton = SDL_BUTTON_LEFT) then + Result := ParseInput(SDLK_RETURN, 0, true); end else begin - nBut := CollectionAt(X, Y); + nBut := InteractAt(X, Y); if nBut >= 0 then begin - // if over button collection, select first child but don't allow click - nBut := ButtonCollection[nBut].FirstChild - 1; + //select on mouse-over if nBut <> Interaction then SetInteraction(nBut); + + Action := maNone; + + if (BtnDown) then + begin + if (MouseButton = SDL_BUTTON_LEFT) then + begin + //click button or SelectS + if (Interactions[nBut].Typ = iSelectS) then + Action := SelectsS[Interactions[nBut].Num].OnClick(X, Y) + else + Action := maReturn; + end + else if (MouseButton = SDL_BUTTON_WHEELDOWN) then + begin //forward on select slide with mousewheel + if (Interactions[nBut].Typ = iSelectS) then + Action := maRight; + end + else if (MouseButton = SDL_BUTTON_WHEELUP) then + begin //backward on select slide with mousewheel + if (Interactions[nBut].Typ = iSelectS) then + Action := maLeft; + end; + end; + + // do the action we have to do ;) + case Action of + maReturn: Result := ParseInput(SDLK_RETURN, 0, true); + maLeft: Result := ParseInput(SDLK_LEFT, 0, true); + maRight: Result := ParseInput(SDLK_RIGHT, 0, true); + end; + end + else + begin + nBut := CollectionAt(X, Y); + if (nBut >= 0) and (not ButtonCollection[nBut].Selected) then + begin + // if over button collection, that is not already selected + // -> select first child but don't allow click + nBut := ButtonCollection[nBut].FirstChild - 1; + if nBut <> Interaction then + SetInteraction(nBut); + end; end; end; end; -function TMenu.InRegion(X1, Y1, W, H, X, Y: real): boolean; +function TMenu.InRegion(X, Y: real; A: TMouseOverRect): boolean; begin - Result := false; - X1 := X1 * Screen.w / 800; - W := W * Screen.w / 800; - Y1 := Y1 * Screen.h / 600; - H := H * Screen.h / 600; - if (X >= X1) and (X <= X1 + W) and (Y >= Y1) and (Y <= Y1 + H) then - Result := true; + // check whether A contains X and Y + Result := (X >= A.X) and (X <= A.X + A.W) and (Y >= A.Y) and (Y <= A.Y + A.H); end; //takes x,y coordinates and returns the interaction number @@ -1718,20 +1756,22 @@ begin for i := Low(Interactions) to High(Interactions) do begin case Interactions[i].Typ of - iButton: if InRegion(Button[Interactions[i].Num].X, Button[Interactions[i].Num].Y, Button[Interactions[i].Num].W, Button[Interactions[i].Num].H, X, Y) and + iButton: + if InRegion(X, Y, Button[Interactions[i].Num].GetMouseOverArea) and Button[Interactions[i].Num].Visible then - begin + begin Result:=i; exit; end; - iBCollectionChild: if InRegion(Button[Interactions[i].Num].X, Button[Interactions[i].Num].Y, Button[Interactions[i].Num].W, Button[Interactions[i].Num].H, X, Y) then + iBCollectionChild: + if InRegion(X, Y, Button[Interactions[i].Num].GetMouseOverArea) then begin Result:=i; exit; end; - iSelectS: if InRegion(SelectSs[Interactions[i].Num].X, SelectSs[Interactions[i].Num].Y, SelectSs[Interactions[i].Num].W, SelectSs[Interactions[i].Num].H, X, Y) or - InRegion(SelectSs[Interactions[i].Num].TextureSBG.X, SelectSs[Interactions[i].Num].TextureSBG.Y, SelectSs[Interactions[i].Num].TextureSBG.W, SelectSs[Interactions[i].Num].TextureSBG.H, X, Y) then - begin + iSelectS: + if InRegion(X, Y, SelectSs[Interactions[i].Num].GetMouseOverArea) then + begin Result:=i; exit; end; @@ -1747,7 +1787,7 @@ begin Result := -1; for i:= Low(ButtonCollection) to High(ButtonCollection) do begin - if InRegion(ButtonCollection[i].X, ButtonCollection[i].Y, ButtonCollection[i].W, ButtonCollection[i].H, X, Y) and + if InRegion(X, Y, ButtonCollection[i].GetMouseOverArea) and ButtonCollection[i].Visible then begin Result:=i; diff --git a/cmake/src/menu/UMenuBackground.pas b/cmake/src/menu/UMenuBackground.pas index c85f0806..0e2e63a6 100644 --- a/cmake/src/menu/UMenuBackground.pas +++ b/cmake/src/menu/UMenuBackground.pas @@ -1,83 +1,83 @@ -{* UltraStar Deluxe - Karaoke Game
- *
- * UltraStar Deluxe is the legal property of its developers, whose names
- * are too numerous to list here. Please refer to the COPYRIGHT
- * file distributed with this source distribution.
- *
- * This program is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- * Boston, MA 02110-1301, USA.
- *
- * $URL$
- * $Id$
- *}
-
-unit UMenuBackground;
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
-{$ENDIF}
-
-{$I switches.inc}
-
-uses
- SysUtils,
- UThemes;
-
-//TMenuBackground - abstraction class for MenuBackgrounds
-//this is a class, not an interface because of the constructors
-//and destructors
-//--------
-
-type
- EMenuBackgroundError = class(Exception);
- TMenuBackground = class
- constructor Create(const ThemedSettings: TThemeBackground); virtual;
- procedure OnShow; virtual;
- procedure Draw; virtual;
- procedure OnFinish; virtual;
- destructor Destroy; override;
- end;
- cMenuBackground = class of TMenuBackground;
-
-implementation
-
-constructor TMenuBackground.Create(const ThemedSettings: TThemeBackground);
-begin
- inherited Create;
-end;
-
-destructor TMenuBackground.Destroy;
-begin
- inherited;
-end;
-
-procedure TMenuBackground.OnShow;
-begin
-
-end;
-
-procedure TMenuBackground.OnFinish;
-begin
-
-end;
-
-procedure TMenuBackground.Draw;
-begin
-
-end;
-
-end.
+{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +unit UMenuBackground; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + SysUtils, + UThemes; + +//TMenuBackground - abstraction class for MenuBackgrounds +//this is a class, not an interface because of the constructors +//and destructors +//-------- + +type + EMenuBackgroundError = class(Exception); + TMenuBackground = class + constructor Create(const ThemedSettings: TThemeBackground); virtual; + procedure OnShow; virtual; + procedure Draw; virtual; + procedure OnFinish; virtual; + destructor Destroy; override; + end; + cMenuBackground = class of TMenuBackground; + +implementation + +constructor TMenuBackground.Create(const ThemedSettings: TThemeBackground); +begin + inherited Create; +end; + +destructor TMenuBackground.Destroy; +begin + inherited; +end; + +procedure TMenuBackground.OnShow; +begin + +end; + +procedure TMenuBackground.OnFinish; +begin + +end; + +procedure TMenuBackground.Draw; +begin + +end; + +end. diff --git a/cmake/src/menu/UMenuBackgroundColor.pas b/cmake/src/menu/UMenuBackgroundColor.pas index a5c2a70a..45b58c1e 100644 --- a/cmake/src/menu/UMenuBackgroundColor.pas +++ b/cmake/src/menu/UMenuBackgroundColor.pas @@ -1,73 +1,73 @@ -{* UltraStar Deluxe - Karaoke Game
- *
- * UltraStar Deluxe is the legal property of its developers, whose names
- * are too numerous to list here. Please refer to the COPYRIGHT
- * file distributed with this source distribution.
- *
- * This program is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- * Boston, MA 02110-1301, USA.
- *
- * $URL$
- * $Id$
- *}
-
-unit UMenuBackgroundColor;
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
-{$ENDIF}
-
-{$I switches.inc}
-
-uses
- UThemes,
- UMenuBackground;
-
-//TMenuBackgroundColor - Background Color
-//--------
-
-type
- TMenuBackgroundColor = class (TMenuBackground)
- private
- Color: TRGB;
- public
- constructor Create(const ThemedSettings: TThemeBackground); override;
- procedure Draw; override;
- end;
-
-implementation
-uses
- gl,
- glext,
- UGraphic;
-
-constructor TMenuBackgroundColor.Create(const ThemedSettings: TThemeBackground);
-begin
- inherited;
- Color := ThemedSettings.Color;
-end;
-
-procedure TMenuBackgroundColor.Draw;
-begin
- if (ScreenAct = 1) then
- begin //just clear once, even when using two screens
- glClearColor(Color.R, Color.G, Color.B, 0);
- glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
- end;
-end;
-
+{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +unit UMenuBackgroundColor; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + UThemes, + UMenuBackground; + +//TMenuBackgroundColor - Background Color +//-------- + +type + TMenuBackgroundColor = class (TMenuBackground) + private + Color: TRGB; + public + constructor Create(const ThemedSettings: TThemeBackground); override; + procedure Draw; override; + end; + +implementation +uses + gl, + glext, + UGraphic; + +constructor TMenuBackgroundColor.Create(const ThemedSettings: TThemeBackground); +begin + inherited; + Color := ThemedSettings.Color; +end; + +procedure TMenuBackgroundColor.Draw; +begin + if (ScreenAct = 1) then + begin //just clear once, even when using two screens + glClearColor(Color.R, Color.G, Color.B, 0); + glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); + end; +end; + end.
\ No newline at end of file diff --git a/cmake/src/menu/UMenuBackgroundFade.pas b/cmake/src/menu/UMenuBackgroundFade.pas index b61a4542..6d877baa 100644 --- a/cmake/src/menu/UMenuBackgroundFade.pas +++ b/cmake/src/menu/UMenuBackgroundFade.pas @@ -1,176 +1,176 @@ -{* UltraStar Deluxe - Karaoke Game
- *
- * UltraStar Deluxe is the legal property of its developers, whose names
- * are too numerous to list here. Please refer to the COPYRIGHT
- * file distributed with this source distribution.
- *
- * This program is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- * Boston, MA 02110-1301, USA.
- *
- * $URL$
- * $Id$
- *}
-
-unit UMenuBackgroundFade;
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
-{$ENDIF}
-
-{$I switches.inc}
-
-uses
- UThemes,
- UTexture,
- UMenuBackground;
-
-//TMenuBackgroundFade - Background Fade In for Overlay screens
-//--------
-
-type
- TMenuBackgroundFade = class (TMenuBackground)
- private
- Tex: TTexture;
- Color: TRGB;
- Alpha: real;
-
- useTexture: boolean;
-
- FadeTime: cardinal;
- public
- constructor Create(const ThemedSettings: TThemeBackground); override;
- procedure OnShow; override;
- procedure Draw; override;
- destructor Destroy; override;
- end;
-
-const
- FADEINTIME = 1500; //Time the bg fades in
-
-implementation
-uses
- sdl,
- gl,
- glext,
- USkins,
- UCommon,
- UGraphic;
-
-constructor TMenuBackgroundFade.Create(const ThemedSettings: TThemeBackground);
-var
- texFilename: string;
-begin
- inherited;
- FadeTime := 0;
-
- Color := ThemedSettings.Color;
- Alpha := ThemedSettings.Alpha;
- if (Length(ThemedSettings.Tex) > 0) then
- begin
- texFilename := Skin.GetTextureFileName(ThemedSettings.Tex);
- texFilename := AdaptFilePaths(texFilename);
- Tex := Texture.GetTexture(texFilename, TEXTURE_TYPE_PLAIN);
-
- UseTexture := (Tex.TexNum <> 0);
- end
- else
- UseTexture := false;
-
- if (not UseTexture) then
- FreeandNil(Tex);
-end;
-
-destructor TMenuBackgroundFade.Destroy;
-begin
- //Why isn't there any Tex.free method?
- {if UseTexture then
- FreeandNil(Tex); }
- inherited;
-end;
-
-procedure TMenuBackgroundFade.OnShow;
-begin
- FadeTime := SDL_GetTicks;
-end;
-
-procedure TMenuBackgroundFade.Draw;
-var
- Progress: real;
-begin
- if FadeTime = 0 then
- Progress := Alpha
- else
- Progress := Alpha * (SDL_GetTicks - FadeTime) / FADEINTIME;
-
- if Progress > Alpha then
- begin
- FadeTime := 0;
- Progress := Alpha;
- end;
-
- if (UseTexture) then
- begin //Draw Texture to Screen
- if (ScreenAct = 1) then //Clear just once when in dual screen mode
- glClear(GL_DEPTH_BUFFER_BIT);
-
- glEnable(GL_TEXTURE_2D);
- glEnable(GL_BLEND);
- glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
-
- glColorRGB(Color, Progress);
- glBindTexture(GL_TEXTURE_2D, Tex.TexNum);
-
- glBegin(GL_QUADS);
- glTexCoord2f(Tex.TexX1*Tex.TexW, Tex.TexY1*Tex.TexH);
- glVertex2f(0, 0);
-
- glTexCoord2f(Tex.TexX1*Tex.TexW, Tex.TexY2*Tex.TexH);
- glVertex2f(0, 600);
-
- glTexCoord2f(Tex.TexX2*Tex.TexW, Tex.TexY2*Tex.TexH);
- glVertex2f(800, 600);
-
- glTexCoord2f(Tex.TexX2*Tex.TexW, Tex.TexY1*Tex.TexH);
- glVertex2f(800, 0);
- glEnd;
-
- glDisable(GL_BLEND);
- glDisable(GL_TEXTURE_2D);
- end
- else
- begin //Clear Screen w/ progress Alpha + Color
- if (ScreenAct = 1) then //Clear just once when in dual screen mode
- glClear(GL_DEPTH_BUFFER_BIT);
-
- glDisable(GL_TEXTURE_2D);
- glEnable(GL_BLEND);
- glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
-
- glColorRGB(Color, Progress);
-
- glBegin(GL_QUADS);
- glVertex2f(0, 0);
- glVertex2f(0, 600);
- glVertex2f(800, 600);
- glVertex2f(800, 0);
- glEnd;
-
- glDisable(GL_BLEND);
- end;
-end;
-
-end.
+{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +unit UMenuBackgroundFade; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + UThemes, + UTexture, + UMenuBackground, + UPath; + +//TMenuBackgroundFade - Background Fade In for Overlay screens +//-------- + +type + TMenuBackgroundFade = class (TMenuBackground) + private + Tex: TTexture; + Color: TRGB; + Alpha: real; + + useTexture: boolean; + + FadeTime: cardinal; + public + constructor Create(const ThemedSettings: TThemeBackground); override; + procedure OnShow; override; + procedure Draw; override; + destructor Destroy; override; + end; + +const + FADEINTIME = 1500; //Time the bg fades in + +implementation +uses + sdl, + gl, + glext, + USkins, + UCommon, + UGraphic; + +constructor TMenuBackgroundFade.Create(const ThemedSettings: TThemeBackground); +var + texFilename: IPath; +begin + inherited; + FadeTime := 0; + + Color := ThemedSettings.Color; + Alpha := ThemedSettings.Alpha; + if (Length(ThemedSettings.Tex) > 0) then + begin + texFilename := Skin.GetTextureFileName(ThemedSettings.Tex); + Tex := Texture.GetTexture(texFilename, TEXTURE_TYPE_PLAIN); + + UseTexture := (Tex.TexNum <> 0); + end + else + UseTexture := false; + + if (not UseTexture) then + FreeandNil(Tex); +end; + +destructor TMenuBackgroundFade.Destroy; +begin + //Why isn't there any Tex.free method? + {if UseTexture then + FreeandNil(Tex); } + inherited; +end; + +procedure TMenuBackgroundFade.OnShow; +begin + FadeTime := SDL_GetTicks; +end; + +procedure TMenuBackgroundFade.Draw; +var + Progress: real; +begin + if FadeTime = 0 then + Progress := Alpha + else + Progress := Alpha * (SDL_GetTicks - FadeTime) / FADEINTIME; + + if Progress > Alpha then + begin + FadeTime := 0; + Progress := Alpha; + end; + + if (UseTexture) then + begin //Draw Texture to Screen + if (ScreenAct = 1) then //Clear just once when in dual screen mode + glClear(GL_DEPTH_BUFFER_BIT); + + glEnable(GL_TEXTURE_2D); + glEnable(GL_BLEND); + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); + + glColorRGB(Color, Progress); + glBindTexture(GL_TEXTURE_2D, Tex.TexNum); + + glBegin(GL_QUADS); + glTexCoord2f(Tex.TexX1*Tex.TexW, Tex.TexY1*Tex.TexH); + glVertex2f(0, 0); + + glTexCoord2f(Tex.TexX1*Tex.TexW, Tex.TexY2*Tex.TexH); + glVertex2f(0, 600); + + glTexCoord2f(Tex.TexX2*Tex.TexW, Tex.TexY2*Tex.TexH); + glVertex2f(800, 600); + + glTexCoord2f(Tex.TexX2*Tex.TexW, Tex.TexY1*Tex.TexH); + glVertex2f(800, 0); + glEnd; + + glDisable(GL_BLEND); + glDisable(GL_TEXTURE_2D); + end + else + begin //Clear Screen w/ progress Alpha + Color + if (ScreenAct = 1) then //Clear just once when in dual screen mode + glClear(GL_DEPTH_BUFFER_BIT); + + glDisable(GL_TEXTURE_2D); + glEnable(GL_BLEND); + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); + + glColorRGB(Color, Progress); + + glBegin(GL_QUADS); + glVertex2f(0, 0); + glVertex2f(0, 600); + glVertex2f(800, 600); + glVertex2f(800, 0); + glEnd; + + glDisable(GL_BLEND); + end; +end; + +end. diff --git a/cmake/src/menu/UMenuBackgroundNone.pas b/cmake/src/menu/UMenuBackgroundNone.pas index 1fccc007..c64f3023 100644 --- a/cmake/src/menu/UMenuBackgroundNone.pas +++ b/cmake/src/menu/UMenuBackgroundNone.pas @@ -1,70 +1,70 @@ -{* UltraStar Deluxe - Karaoke Game
- *
- * UltraStar Deluxe is the legal property of its developers, whose names
- * are too numerous to list here. Please refer to the COPYRIGHT
- * file distributed with this source distribution.
- *
- * This program is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- * Boston, MA 02110-1301, USA.
- *
- * $URL$
- * $Id$
- *}
-
-unit UMenuBackgroundNone;
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
-{$ENDIF}
-
-{$I switches.inc}
-
-uses
- UThemes,
- UMenuBackground;
-
-//TMenuBackgroundNone - Just no Background (e.g. for Overlays)
-//--------
-
-type
- TMenuBackgroundNone = class (TMenuBackground)
- private
-
- public
- constructor Create(const ThemedSettings: TThemeBackground); override;
- procedure Draw; override;
- end;
-
-implementation
-uses
- gl,
- glext,
- UGraphic;
-
-constructor TMenuBackgroundNone.Create(const ThemedSettings: TThemeBackground);
-begin
- inherited;
-end;
-
-procedure TMenuBackgroundNone.Draw;
-begin
- //Do just nothing in here!
- If (ScreenAct = 1) then //Clear just once when in dual screen mode
- glClear(GL_DEPTH_BUFFER_BIT);
-end;
-
+{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +unit UMenuBackgroundNone; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + UThemes, + UMenuBackground; + +//TMenuBackgroundNone - Just no Background (e.g. for Overlays) +//-------- + +type + TMenuBackgroundNone = class (TMenuBackground) + private + + public + constructor Create(const ThemedSettings: TThemeBackground); override; + procedure Draw; override; + end; + +implementation +uses + gl, + glext, + UGraphic; + +constructor TMenuBackgroundNone.Create(const ThemedSettings: TThemeBackground); +begin + inherited; +end; + +procedure TMenuBackgroundNone.Draw; +begin + //Do just nothing in here! + If (ScreenAct = 1) then //Clear just once when in dual screen mode + glClear(GL_DEPTH_BUFFER_BIT); +end; + end.
\ No newline at end of file diff --git a/cmake/src/menu/UMenuBackgroundTexture.pas b/cmake/src/menu/UMenuBackgroundTexture.pas index a1b9e88a..f71637ff 100644 --- a/cmake/src/menu/UMenuBackgroundTexture.pas +++ b/cmake/src/menu/UMenuBackgroundTexture.pas @@ -1,125 +1,126 @@ -{* UltraStar Deluxe - Karaoke Game
- *
- * UltraStar Deluxe is the legal property of its developers, whose names
- * are too numerous to list here. Please refer to the COPYRIGHT
- * file distributed with this source distribution.
- *
- * This program is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- * Boston, MA 02110-1301, USA.
- *
- * $URL$
- * $Id$
- *}
-
-unit UMenuBackgroundTexture;
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
-{$ENDIF}
-
-{$I switches.inc}
-
-uses
- UThemes,
- UTexture,
- UMenuBackground;
-
-//TMenuBackgroundColor - Background Color
-//--------
-
-type
- TMenuBackgroundTexture = class (TMenuBackground)
- private
- Tex: TTexture;
- Color: TRGB;
- public
- constructor Create(const ThemedSettings: TThemeBackground); override;
- procedure Draw; override;
- destructor Destroy; override;
- end;
-
-const
- SUPPORTED_EXTS_BACKGROUNDTEXTURE: array[0..13] of string = ('.png', '.bmp', '.jpg', '.jpeg', '.gif', '.pnm', '.ppm', '.pgm', '.pbm', '.xpm', '.lbm', '.pcx', '.tga', '.tiff');
-
-implementation
-uses
- USkins,
- UCommon,
- SysUtils,
- gl,
- glext,
- UGraphic;
-
-constructor TMenuBackgroundTexture.Create(const ThemedSettings: TThemeBackground);
-var texFilename: string;
-begin
- inherited;
-
- if (Length(ThemedSettings.Tex) = 0) then
- raise EMenuBackgroundError.Create('TMenuBackgroundTexture: No texture filename present');
-
- Color := ThemedSettings.Color;
-
- texFilename := Skin.GetTextureFileName(ThemedSettings.Tex);
- texFilename := AdaptFilePaths(texFilename);
- Tex := Texture.GetTexture(texFilename, TEXTURE_TYPE_PLAIN);
-
- if (Tex.TexNum = 0) then
- begin
- freeandnil(Tex);
- raise EMenuBackgroundError.Create('TMenuBackgroundTexture: Can''t load texture');
- end;
-end;
-
-destructor TMenuBackgroundTexture.Destroy;
-begin
- //freeandnil(Tex); <- this causes an Access Violation o0
- inherited;
-end;
-
-procedure TMenuBackgroundTexture.Draw;
-begin
- If (ScreenAct = 1) then //Clear just once when in dual screen mode
- glClear(GL_DEPTH_BUFFER_BIT);
-
- glColorRGB(Color);
-
- glEnable(GL_TEXTURE_2D);
- glEnable(GL_BLEND);
- glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
-
- glBindTexture(GL_TEXTURE_2D, Tex.TexNum);
-
- glBegin(GL_QUADS);
- glTexCoord2f(Tex.TexX1*Tex.TexW, Tex.TexY1*Tex.TexH);
- glVertex2f(0, 0);
-
- glTexCoord2f(Tex.TexX1*Tex.TexW, Tex.TexY2*Tex.TexH);
- glVertex2f(0, 600);
-
- glTexCoord2f(Tex.TexX2*Tex.TexW, Tex.TexY2*Tex.TexH);
- glVertex2f(800, 600);
-
- glTexCoord2f(Tex.TexX2*Tex.TexW, Tex.TexY1*Tex.TexH);
- glVertex2f(800, 0);
- glEnd;
-
- glDisable(GL_BLEND);
- glDisable(GL_TEXTURE_2D);
-end;
-
-end.
+{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +unit UMenuBackgroundTexture; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + UThemes, + UTexture, + UMenuBackground, + UPath; + +//TMenuBackgroundColor - Background Color +//-------- + +type + TMenuBackgroundTexture = class (TMenuBackground) + private + Tex: TTexture; + Color: TRGB; + public + constructor Create(const ThemedSettings: TThemeBackground); override; + procedure Draw; override; + destructor Destroy; override; + end; + +const + SUPPORTED_EXTS_BACKGROUNDTEXTURE: array[0..13] of string = ('.png', '.bmp', '.jpg', '.jpeg', '.gif', '.pnm', '.ppm', '.pgm', '.pbm', '.xpm', '.lbm', '.pcx', '.tga', '.tiff'); + +implementation +uses + USkins, + UCommon, + SysUtils, + gl, + glext, + UGraphic; + +constructor TMenuBackgroundTexture.Create(const ThemedSettings: TThemeBackground); +var + texFilename: IPath; +begin + inherited; + + if (Length(ThemedSettings.Tex) = 0) then + raise EMenuBackgroundError.Create('TMenuBackgroundTexture: No texture filename present'); + + Color := ThemedSettings.Color; + + texFilename := Skin.GetTextureFileName(ThemedSettings.Tex); + Tex := Texture.GetTexture(texFilename, TEXTURE_TYPE_PLAIN); + + if (Tex.TexNum = 0) then + begin + freeandnil(Tex); + raise EMenuBackgroundError.Create('TMenuBackgroundTexture: Can''t load texture'); + end; +end; + +destructor TMenuBackgroundTexture.Destroy; +begin + //freeandnil(Tex); <- this causes an Access Violation o0 + inherited; +end; + +procedure TMenuBackgroundTexture.Draw; +begin + If (ScreenAct = 1) then //Clear just once when in dual screen mode + glClear(GL_DEPTH_BUFFER_BIT); + + glColorRGB(Color); + + glEnable(GL_TEXTURE_2D); + glEnable(GL_BLEND); + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); + + glBindTexture(GL_TEXTURE_2D, Tex.TexNum); + + glBegin(GL_QUADS); + glTexCoord2f(Tex.TexX1*Tex.TexW, Tex.TexY1*Tex.TexH); + glVertex2f(0, 0); + + glTexCoord2f(Tex.TexX1*Tex.TexW, Tex.TexY2*Tex.TexH); + glVertex2f(0, 600); + + glTexCoord2f(Tex.TexX2*Tex.TexW, Tex.TexY2*Tex.TexH); + glVertex2f(800, 600); + + glTexCoord2f(Tex.TexX2*Tex.TexW, Tex.TexY1*Tex.TexH); + glVertex2f(800, 0); + glEnd; + + glDisable(GL_BLEND); + glDisable(GL_TEXTURE_2D); +end; + +end. diff --git a/cmake/src/menu/UMenuBackgroundVideo.pas b/cmake/src/menu/UMenuBackgroundVideo.pas index d1ce0f09..bfaee702 100644 --- a/cmake/src/menu/UMenuBackgroundVideo.pas +++ b/cmake/src/menu/UMenuBackgroundVideo.pas @@ -1,204 +1,211 @@ -{* UltraStar Deluxe - Karaoke Game
- *
- * UltraStar Deluxe is the legal property of its developers, whose names
- * are too numerous to list here. Please refer to the COPYRIGHT
- * file distributed with this source distribution.
- *
- * This program is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- * Boston, MA 02110-1301, USA.
- *
- * $URL$
- * $Id$
- *}
-
-unit UMenuBackgroundVideo;
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
-{$ENDIF}
-
-{$I switches.inc}
-
-uses
- UThemes,
- UMenuBackground,
- UVideo;
-
-//TMenuBackgroundColor - Background Color
-//--------
-
-type
- //DefaultBGVideoPlayback = TVideoPlayback_FFmpeg;
-
-{type
- TBGVideoPool = class;
-
- PBGVideoPoolItem = ^TBGVideoPoolItem;
- TBGVideoPoolItem = record
- Parent: TBGVideoPool;
- VideoPlayback = IVideoPlayback;
- ReferenceCounter: cardinal; //Number of Creations
- end;
-
- TBGVideo = class
- private
- myItem: PBGVideoPoolItem;
- public
- constructor Create(Item: PBGVideoPoolItem); override;
-
- function GetVideoPlayback: IVideoPlayback;
- procedure Draw;
-
- destructor Destroy;
- end;
-
- TBGVideoPool = class
- private
- Items: PBGVideoPoolItem;
- public
- constructor Create;
-
- function GetBGVideo(filename: string): TBGVideo;
- procedure RemoveItem(
- procedure FreeAllItems;
-
- destructor Destroy;
- end;
-
-type }
- TMenuBackgroundVideo = class (TMenuBackground)
- private
- fFilename: string;
- public
- constructor Create(const ThemedSettings: TThemeBackground); override;
- procedure OnShow; override;
- procedure Draw; override;
- procedure OnFinish; override;
- destructor Destroy; override;
- end;
-
-{var
- BGVideoPool: TBGVideoPool; }
-const
- SUPPORTED_EXTS_BACKGROUNDVIDEO: array[0..6] of string = ('.avi', '.mov', '.divx', '.mpg', '.mp4', '.mpeg', '.m2v');
-
-implementation
-
-uses
- gl,
- glext,
- UMusic,
- SysUtils,
- UTime,
- USkins,
- UCommon,
- UGraphic;
-
-constructor TMenuBackgroundVideo.Create(const ThemedSettings: TThemeBackground);
-begin
- inherited;
- if (Length(ThemedSettings.Tex) = 0) then
- raise EMenuBackgroundError.Create('TMenuBackgroundVideo: No video filename present');
-
- fFileName := Skin.GetTextureFileName(ThemedSettings.Tex);
- fFileName := AdaptFilePaths( fFileName );
-
- if fileexists(fFilename) AND VideoPlayback.Open( fFileName ) then
- begin
- VideoBGTimer.SetTime(0);
- VideoPlayback.Play;
- end
- else
- raise EMenuBackgroundError.Create('TMenuBackgroundVideo: Can''t load background video: ' + fFilename);
-end;
-
-destructor TMenuBackgroundVideo.Destroy;
-begin
-
-end;
-
-procedure TMenuBackgroundVideo.OnShow;
-begin
- if VideoPlayback.Open( fFileName ) then
- begin
- VideoBGTimer.SetTime(0);
- VideoPlayback.Play;
- end;
-end;
-
-procedure TMenuBackgroundVideo.OnFinish;
-begin
-
-end;
-
-procedure TMenuBackgroundVideo.Draw;
-begin
- If (ScreenAct = 1) then //Clear just once when in dual screen mode
- glClear(GL_DEPTH_BUFFER_BIT);
-
- VideoPlayback.GetFrame(VideoBGTimer.GetTime());
- // FIXME: why do we draw on screen 2? Seems to be wrong.
- VideoPlayback.DrawGL(2);
-end;
-
-// Implementation of TBGVideo
-//--------
-{constructor TBGVideo.Create(Item: PBGVideoPoolItem);
-begin
- myItem := PBGVideoPoolItem;
- Inc(myItem.ReferenceCounter);
-end;
-
-destructor TBGVideo.Destroy;
-begin
- Dec(myItem.ReferenceCounter);
-end;
-
-function TBGVideo.GetVideoPlayback: IVideoPlayback;
-begin
-
-end;
-
-procedure TBGVideo.Draw;
-begin
-
-end;
-
-// Implementation of TBGVideoPool
-//--------
-
-constructor TBGVideoPool.Create;
-begin
-
-end;
-
-destructor TBGVideoPool.Destroy;
-begin
-
-end;
-
-function TBGVideoPool.GetBGVideo(filename: string): TBGVideo;
-begin
-
-end;
-
-procedure TBGVideoPool.FreeAllItems;
-begin
-
-end; }
-
-end.
+{* UltraStar Deluxe - Karaoke Game + * + * UltraStar Deluxe is the legal property of its developers, whose names + * are too numerous to list here. Please refer to the COPYRIGHT + * file distributed with this source distribution. + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * $URL$ + * $Id$ + *} + +unit UMenuBackgroundVideo; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + UThemes, + UMenuBackground, + UMusic, + UVideo, + UPath; + +//TMenuBackgroundColor - Background Color +//-------- + +type + //DefaultBGVideoPlayback = TVideoPlayback_FFmpeg; + +{type + TBGVideoPool = class; + + PBGVideoPoolItem = ^TBGVideoPoolItem; + TBGVideoPoolItem = record + Parent: TBGVideoPool; + VideoPlayback = IVideoPlayback; + ReferenceCounter: cardinal; //Number of Creations + end; + + TBGVideo = class + private + myItem: PBGVideoPoolItem; + public + constructor Create(Item: PBGVideoPoolItem); override; + + function GetVideoPlayback: IVideoPlayback; + procedure Draw; + + destructor Destroy; + end; + + TBGVideoPool = class + private + Items: PBGVideoPoolItem; + public + constructor Create; + + function GetBGVideo(filename: IPath): TBGVideo; + procedure RemoveItem( + procedure FreeAllItems; + + destructor Destroy; + end; + +type } + TMenuBackgroundVideo = class (TMenuBackground) + private + fFilename: IPath; + fBgVideo: IVideo; + public + constructor Create(const ThemedSettings: TThemeBackground); override; + procedure OnShow; override; + procedure Draw; override; + procedure OnFinish; override; + destructor Destroy; override; + end; + +{var + BGVideoPool: TBGVideoPool; } +const + SUPPORTED_EXTS_BACKGROUNDVIDEO: array[0..6] of string = ('.avi', '.mov', '.divx', '.mpg', '.mp4', '.mpeg', '.m2v'); + +implementation + +uses + gl, + glext, + SysUtils, + UTime, + USkins, + UCommon, + UGraphic; + +constructor TMenuBackgroundVideo.Create(const ThemedSettings: TThemeBackground); +begin + inherited; + if (Length(ThemedSettings.Tex) = 0) then + raise EMenuBackgroundError.Create('TMenuBackgroundVideo: No video filename present'); + + fFileName := Skin.GetTextureFileName(ThemedSettings.Tex); + if (not fFilename.IsFile) then + raise EMenuBackgroundError.Create('TMenuBackgroundVideo: Can''t load background video: ' + fFilename.ToNative); +end; + +destructor TMenuBackgroundVideo.Destroy; +begin +end; + +procedure TMenuBackgroundVideo.OnShow; +begin + fBgVideo := VideoPlayback.Open(fFileName); + if (fBgVideo <> nil) then + begin + VideoBGTimer.SetTime(0); + VideoBGTimer.Start(); + fBgVideo.Loop := true; + fBgVideo.Play; + end; +end; + +procedure TMenuBackgroundVideo.OnFinish; +begin + // unload video + fBgVideo := nil; +end; + +procedure TMenuBackgroundVideo.Draw; +begin + // clear just once when in dual screen mode + if (ScreenAct = 1) then + begin + glClear(GL_DEPTH_BUFFER_BIT); + // video failure -> draw blank background + if (fBgVideo = nil) then + glClear(GL_COLOR_BUFFER_BIT); + end; + + if (fBgVideo <> nil) then + begin + fBgVideo.GetFrame(VideoBGTimer.GetTime()); + // FIXME: why do we draw on screen 2? Seems to be wrong. + fBgVideo.DrawGL(2); + end; +end; + +// Implementation of TBGVideo +//-------- +{constructor TBGVideo.Create(Item: PBGVideoPoolItem); +begin + myItem := PBGVideoPoolItem; + Inc(myItem.ReferenceCounter); +end; + +destructor TBGVideo.Destroy; +begin + Dec(myItem.ReferenceCounter); +end; + +function TBGVideo.GetVideoPlayback: IVideoPlayback; +begin + +end; + +procedure TBGVideo.Draw; +begin + +end; + +// Implementation of TBGVideoPool +//-------- + +constructor TBGVideoPool.Create; +begin + +end; + +destructor TBGVideoPool.Destroy; +begin + +end; + +function TBGVideoPool.GetBGVideo(filename: IPath): TBGVideo; +begin + +end; + +procedure TBGVideoPool.FreeAllItems; +begin + +end; } + +end. diff --git a/cmake/src/menu/UMenuButton.pas b/cmake/src/menu/UMenuButton.pas index 923f0b14..868a86f3 100644 --- a/cmake/src/menu/UMenuButton.pas +++ b/cmake/src/menu/UMenuButton.pas @@ -38,7 +38,8 @@ uses UTexture, gl, UMenuText, - SDL; + SDL, + UMenuInteract; type CButton = class of TButton; @@ -116,6 +117,8 @@ type constructor Create(Textura: TTexture); overload; constructor Create(Textura, DSTexture: TTexture); overload; destructor Destroy; override; + + function GetMouseOverArea: TMouseOverRect; end; implementation @@ -529,6 +532,49 @@ begin end; end; +function TButton.GetMouseOverArea: TMouseOverRect; +begin + if (FadeTex.TexNum = 0) then + begin + Result.X := Texture.X; + Result.Y := Texture.Y; + Result.W := Texture.W; + Result.H := Texture.H; + end + else + begin + case FadeTexPos of + 0: begin // fade tex on top + Result.X := Texture.X; + Result.Y := FadeTex.Y; + Result.W := Texture.W; + Result.H := FadeTex.H + Texture.H; + end; + + 1: begin // fade tex on left side + Result.X := FadeTex.X; + Result.Y := Texture.Y; + Result.W := FadeTex.W + Texture.W; + Result.H := Texture.H; + end; + + 2: begin // fade tex on bottom + Result.X := Texture.X; + Result.Y := Texture.Y; + Result.W := Texture.W; + Result.H := FadeTex.H + Texture.H; + end; + + 3: begin // fade tex on right side + Result.X := Texture.X; + Result.Y := Texture.Y; + Result.W := FadeTex.W + Texture.W; + Result.H := Texture.H; + end; + end; + end; +end; + destructor TButton.Destroy; begin diff --git a/cmake/src/menu/UMenuInteract.pas b/cmake/src/menu/UMenuInteract.pas index beb6bcef..7cb92025 100644 --- a/cmake/src/menu/UMenuInteract.pas +++ b/cmake/src/menu/UMenuInteract.pas @@ -39,6 +39,15 @@ type Num: integer; // number of this item in proper list like buttons, selects end; + { to handle the area where the mouse is over a control } + TMouseOverRect = record + X, Y: Real; + W, H: Real; + end; + + { to handle the on click action } + TMouseClickAction = (maNone, maReturn, maLeft, maRight); + implementation end. diff --git a/cmake/src/menu/UMenuSelectSlide.pas b/cmake/src/menu/UMenuSelectSlide.pas index f9f6bbae..09ce3b9f 100644 --- a/cmake/src/menu/UMenuSelectSlide.pas +++ b/cmake/src/menu/UMenuSelectSlide.pas @@ -37,22 +37,29 @@ uses gl, TextGL, UMenuText, - UTexture; + UTexture, + UMenuInteract; type PSelectSlide = ^TSelectSlide; TSelectSlide = class private SelectBool: boolean; + + function AdjustOptionTextToFit(OptText: UTF8String): UTF8String; public // objects Text: TText; // Main text describing option TextOpt: array of TText; // 3 texts in the position of possible options - TextOptT: array of string; // array of names for possible options + TextOptT: array of UTF8String; // array of names for possible options Texture: TTexture; // Select Texture TextureSBG: TTexture; // Background Selections Texture -// TextureS: array of TTexture; // Selections Texture (not used) + + Colorized: boolean; + DeSelectTexture: TTexture; // texture for colorized hack + ColorizedSBG: boolean; + DeSelectTextureSBG: TTexture; // texture for colorized hack Select BG Tex_SelectS_ArrowL: TTexture; // Texture for left arrow Tex_SelectS_ArrowR: TTexture; // Texture for right arrow @@ -135,8 +142,17 @@ type //Automatically Generate Lines (Texts) procedure genLines; + + function GetMouseOverArea: TMouseOverRect; + function OnClick(X, Y: Real): TMouseClickAction; end; +const + ArrowAlphaOptionsLeft = 1; + ArrowAlphaNoOptionsLeft = 0; + MinItemSpacing = 5; + MinSideSpacing = 24; + implementation uses @@ -153,6 +169,26 @@ begin SetLength(TextOpt, 1); TextOpt[0] := TText.Create; Visible := true; + + Colorized := false; + ColorizedSBG := false; + ColR := 1; + ColG := 1; + ColB := 1; + Int := 1; + DColR := 1; + DColG := 1; + DColB := 1; + DInt := 1; + + SBGColR := 1; + SBGColG := 1; + SBGColB := 1; + SBGInt := 1; + SBGDColR := 1; + SBGDColG := 1; + SBGDColB := 1; + SBGDInt := 1; end; procedure TSelectSlide.SetSelect(Value: boolean); @@ -180,20 +216,30 @@ begin end else begin - Texture.ColR := DColR; - Texture.ColG := DColG; - Texture.ColB := DColB; - Texture.Int := DInt; + if Colorized then + DeSelectTexture.Int := DInt + else + begin + Texture.ColR := DColR; + Texture.ColG := DColG; + Texture.ColB := DColB; + Texture.Int := DInt; + end; Text.ColR := TDColR; Text.ColG := TDColG; Text.ColB := TDColB; Text.Int := TDInt; - TextureSBG.ColR := SBGDColR; - TextureSBG.ColG := SBGDColG; - TextureSBG.ColB := SBGDColB; - TextureSBG.Int := SBGDInt; + if (ColorizedSBG) then + DeselectTextureSBG.Int := SBGDInt + else + begin + TextureSBG.ColR := SBGDColR; + TextureSBG.ColG := SBGDColG; + TextureSBG.ColB := SBGDColB; + TextureSBG.Int := SBGDInt; + end; end; end; @@ -236,12 +282,15 @@ begin begin Value := 0; - Tex_SelectS_ArrowL.alpha := 0; - Tex_SelectS_ArrowR.alpha := 1; + Tex_SelectS_ArrowL.alpha := ArrowAlphaNoOptionsLeft; + if (Length(TextOptT) > 1) then + Tex_SelectS_ArrowR.alpha := ArrowAlphaOptionsLeft + else + Tex_SelectS_ArrowR.alpha := ArrowAlphaNoOptionsLeft; for SO := Low(TextOpt) to High(TextOpt) do begin - TextOpt[SO].Text := TextOptT[SO]; + TextOpt[SO].Text := AdjustOptionTextToFit(TextOptT[SO]); end; DoSelection(0); @@ -252,12 +301,12 @@ begin begin Value := High(TextOptT); - Tex_SelectS_ArrowL.alpha := 1; - Tex_SelectS_ArrowR.alpha := 0; + Tex_SelectS_ArrowL.alpha := ArrowAlphaOptionsLeft; + Tex_SelectS_ArrowR.alpha := ArrowAlphaNoOptionsLeft; for SO := High(TextOpt) downto Low(TextOpt) do begin - TextOpt[SO].Text := TextOptT[High(TextOptT) - (Lines - SO - 1)]; + TextOpt[SO].Text := AdjustOptionTextToFit(TextOptT[High(TextOptT) - (Lines - SO - 1)]); end; DoSelection(Lines - 1); end @@ -265,8 +314,8 @@ begin //in between first and last else begin - Tex_SelectS_ArrowL.alpha := 1; - Tex_SelectS_ArrowR.alpha := 1; + Tex_SelectS_ArrowL.alpha := ArrowAlphaOptionsLeft; + Tex_SelectS_ArrowR.alpha := ArrowAlphaOptionsLeft; HalfL := Ceil((Lines - 1) / 2); HalfR := Lines - 1 - HalfL; @@ -277,7 +326,7 @@ begin //Change texts for SO := Low(TextOpt) to High(TextOpt) do begin - TextOpt[SO].Text := TextOptT[SO]; + TextOpt[SO].Text := AdjustOptionTextToFit(TextOptT[SO]); end; DoSelection(Value); @@ -291,10 +340,10 @@ begin //Change texts for SO := High(TextOpt) downto Low(TextOpt) do begin - TextOpt[SO].Text := TextOptT[High(TextOptT) - (Lines - SO - 1)]; + TextOpt[SO].Text := AdjustOptionTextToFit(TextOptT[High(TextOptT) - (Lines - SO - 1)]); end; - DoSelection (HalfL); + DoSelection (HalfL); end else @@ -302,7 +351,7 @@ begin //Change Texts for SO := Low(TextOpt) to High(TextOpt) do begin - TextOpt[SO].Text := TextOptT[Value - HalfL + SO]; + TextOpt[SO].Text := AdjustOptionTextToFit(TextOptT[Value - HalfL + SO]); end; DoSelection(HalfL); @@ -311,14 +360,71 @@ begin end; end; +{ cuts the text if it is too long to fit on the selectbg } +function TSelectSlide.AdjustOptionTextToFit(OptText: UTF8String): UTF8String; + var + MaxLen: real; + Len: integer; +begin + Result := OptText; + + if (TextureSBG.W > 0) then + begin + MaxLen := TextureSBG.W - MinSideSpacing * 2; + + SetFontStyle(ftNormal); + SetFontSize(Text.Size); + + // we will remove min. 2 letters by default and replace them w/ points + // if the whole text don't fit + Len := Length(OptText) - 1; + + while (glTextWidth(Result) > MaxLen) and (Len > 0) do + begin + { ensure that we only cut at full letters } + { this code may be a problem if there is a text that + consists of many multi byte characters and only few + one byte characters } + repeat + Dec(Len); + until (byte(OptText[Len]) and 128) = 0; + + Result := copy(OptText, 1, Len) + '..'; + end; + end; +end; + procedure TSelectSlide.Draw; var SO: integer; begin if Visible then begin - DrawTexture(Texture); - DrawTexture(TextureSBG); + if SelectBool or not Colorized then + begin + DrawTexture(Texture); + end + else + begin + DeselectTexture.X := Texture.X; + DeselectTexture.Y := Texture.Y; + DeselectTexture.W := Texture.W; + DeselectTexture.H := Texture.H; + DrawTexture(DeselectTexture); + end; + + if SelectBool or not ColorizedSBG then + begin + DrawTexture(TextureSBG); + end + else + begin + DeselectTextureSBG.X := TextureSBG.X; + DeselectTextureSBG.Y := TextureSBG.Y; + DeselectTextureSBG.W := TextureSBG.W; + DeselectTextureSBG.H := TextureSBG.H; + DrawTexture(DeselectTextureSBG); + end; if showArrows then begin @@ -338,7 +444,7 @@ var maxlength: real; I: integer; begin - SetFontStyle(0{Text.Style}); + SetFontStyle(ftNormal{Text.Style}); SetFontSize(Text.Size); maxlength := 0; @@ -352,7 +458,7 @@ begin if (oneItemOnly = false) then begin //show all items - Lines := floor((TextureSBG.W-40) / (maxlength+7)); + Lines := floor((TextureSBG.W - MinSideSpacing * 2) / (maxlength + MinItemSpacing)); if (Lines > Length(TextOptT)) then Lines := Length(TextOptT); @@ -369,40 +475,67 @@ begin for I := Low(TextOpt) to High(TextOpt) do TextOpt[I].Free; - setLength (TextOpt, Lines); + SetLength (TextOpt, Lines); for I := Low(TextOpt) to High(TextOpt) do begin TextOpt[I] := TText.Create; TextOpt[I].Size := Text.Size; - //TextOpt[I].Align := 1; - TextOpt[I].Align := 0; TextOpt[I].Visible := true; + TextOpt[I].Style := 0; TextOpt[I].ColR := STDColR; TextOpt[I].ColG := STDColG; TextOpt[I].ColB := STDColB; TextOpt[I].Int := STDInt; - //Generate Positions - //TextOpt[I].X := TextureSBG.X + 20 + (TextureSBG.W / Lines) * (I + 0.5); - if (I <> High(TextOpt)) or (High(TextOpt) = 0) or (Length(TextOptT) = Lines) then - TextOpt[I].X := TextureSBG.X + 20 + (TextureSBG.W / Lines) * I - else - TextOpt[I].X := TextureSBG.X + TextureSBG.W - maxlength; - + // generate positions TextOpt[I].Y := TextureSBG.Y + (TextureSBG.H - Text.Size) / 2; - //Better Look with 2 Options - if (Lines = 2) and (Length(TextOptT) = 2) then + // better look with 2 options and a single option + if (Lines = 2) then + begin TextOpt[I].X := TextureSBG.X + 20 + (TextureSBG.W -40 - glTextWidth(TextOptT[1])) * I; - - if (Lines = 1) then + TextOpt[I].Align := 0; + end + else if (Lines = 1) then begin - TextOpt[I].Align := 1; //center text TextOpt[I].X := TextureSBG.X + (TextureSBG.W / 2); + TextOpt[I].Align := 1; //center text + end + else + begin + TextOpt[I].X := TextureSBG.X + TextureSBG.W / 2 + (TextureSBG.W - MinSideSpacing*2) * (I / Lines - 0.5); + TextOpt[I].Align := 0; end; end; end; +function TSelectSlide.GetMouseOverArea: TMouseOverRect; +begin + Result.X := Texture.X; + Result.Y := Texture.Y; + Result.W := (TextureSBG.X + TextureSBG.W) - Result.X; + Result.H := Max(Texture.H, TextureSBG.H); +end; + +function TSelectSlide.OnClick(X, Y: Real): TMouseClickAction; + var + AreaW: Real; +begin + // default: press return on click + Result := maReturn; + + // use left sides to inc or dec selection by click + AreaW := TextureSbg.W / 20; + + if (Y >= TextureSBG.Y) and (Y <= TextureSBG.Y + TextureSBG.H) then + begin + if (X >= TextureSBG.X) and (X <= TextureSBG.X + AreaW) then + Result := maLeft // hit left area + else if (X >= TextureSBG.X + TextureSBG.W - AreaW) and (X <= TextureSBG.X + TextureSBG.W) then + Result := maRight; // hit right area + end; +end; + end. diff --git a/cmake/src/menu/UMenuText.pas b/cmake/src/menu/UMenuText.pas index b5507327..ab180b77 100644 --- a/cmake/src/menu/UMenuText.pas +++ b/cmake/src/menu/UMenuText.pas @@ -45,8 +45,8 @@ type TText = class private SelectBool: boolean; - TextString: string; - TextTiles: array of string; + TextString: UTF8String; + TextTiles: array of UTF8String; STicks: cardinal; SelectBlink: boolean; @@ -75,22 +75,23 @@ type procedure SetSelect(Value: boolean); property Selected: boolean read SelectBool write SetSelect; - procedure SetText(Value: string); - property Text: string read TextString write SetText; + procedure SetText(Value: UTF8String); + property Text: UTF8String read TextString write SetText; - procedure DeleteLastL; // procedure to delete last letter + procedure DeleteLastLetter; //< Deletes the rightmost letter procedure Draw; constructor Create; overload; - constructor Create(X, Y: real; Text: string); overload; - constructor Create(ParX, ParY, ParW: real; ParStyle: integer; ParSize, ParColR, ParColG, ParColB: real; ParAlign: integer; ParText: string; ParReflection: boolean; ParReflectionSpacing: real; ParZ: real); overload; + constructor Create(X, Y: real; const Text: UTF8String); overload; + constructor Create(ParX, ParY, ParW: real; ParStyle: integer; ParSize, ParColR, ParColG, ParColB: real; ParAlign: integer; const ParText: UTF8String; ParReflection: boolean; ParReflectionSpacing: real; ParZ: real); overload; end; implementation uses - StrUtils, - UGraphic; + UGraphic, + UUnicodeUtils, + StrUtils; procedure TText.SetSelect(Value: boolean); begin @@ -101,7 +102,7 @@ begin STicks := SDL_GetTicks() div 550; end; -procedure TText.SetText(Value: string); +procedure TText.SetText(Value: UTF8String); var NextPos: cardinal; // next pos of a space etc. LastPos: cardinal; // last pos " @@ -244,23 +245,15 @@ begin AddBreak(LastBreak, Length(Value)+1); end; -procedure TText.DeleteLastL; -var - S: string; - L: integer; +procedure TText.DeleteLastLetter; begin - S := TextString; - L := Length(S); - if (L > 0) then - SetLength(S, L-1); - - SetText(S); + SetText(UTF8Copy(TextString, 1, LengthUTF8(TextString)-1)); end; procedure TText.Draw; var X2, Y2: real; - Text2: string; + Text2: UTF8String; I: integer; Ticks: cardinal; begin @@ -304,7 +297,7 @@ begin SetFontPos(X2, Y); glPrint(Text2); - SetFontStyle(0); // reset to default + SetFontStyle(ftNormal); // reset to default end else begin} @@ -333,12 +326,12 @@ begin {if Size >= 10 then Y2 := Y2 + Size * 0.93 else} - if (Style = 1) then + if (Style = ftBold) then Y2 := Y2 + Size * 0.93 else Y2 := Y2 + Size * 0.72; end; - SetFontStyle(0); // reset to default + SetFontStyle(ftNormal); // reset to default //end; end; @@ -349,19 +342,19 @@ begin Create(0, 0, ''); end; -constructor TText.Create(X, Y: real; Text: string); +constructor TText.Create(X, Y: real; const Text: UTF8String); begin - Create(X, Y, 0, 0, 30, 0, 0, 0, 0, Text, false, 0, 0); + Create(X, Y, 0, ftNormal, 30, 0, 0, 0, 0, Text, false, 0, 0); end; constructor TText.Create(ParX, ParY, ParW: real; ParStyle: integer; - ParSize, ParColR, ParColG, ParColB: real; - ParAlign: integer; - ParText: string; - ParReflection: boolean; - ParReflectionSpacing: real; - ParZ: real); + ParSize, ParColR, ParColG, ParColB: real; + ParAlign: integer; + const ParText: UTF8String; + ParReflection: boolean; + ParReflectionSpacing: real; + ParZ: real); begin inherited Create; Alpha := 1; diff --git a/cmake/src/screens/UScreenCredits.pas b/cmake/src/screens/UScreenCredits.pas index def6b7de..b1333b4a 100644 --- a/cmake/src/screens/UScreenCredits.pas +++ b/cmake/src/screens/UScreenCredits.pas @@ -35,15 +35,16 @@ interface uses SysUtils, - UMenu, SDL, SDL_Image, + gl, + UMenu, UDisplay, UTexture, - gl, UMusic, UFiles, UThemes, + UPath, UGraphicClasses; type @@ -98,10 +99,10 @@ type Fadeout: boolean; constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; function Draw: boolean; override; - procedure onShow; override; - procedure onHide; override; + procedure OnShow; override; + procedure OnHide; override; procedure DrawCredits; procedure Draw_FunkyText; end; @@ -138,17 +139,17 @@ const OUTRO_EXD_FILE = 'outro-exit-dark.png'; Timings: array[0..21] of cardinal=( - 20, // 0 Delay vor Start + 20, // 0 Delay before Start - 149, // 1 Ende erster Intro Zoom - 155, // 2 Start 2. Action im Intro - 170, // 3 Ende Separation im Intro - 271, // 4 Anfang Zoomout im Intro + 149, // 1 End first Intro Zoom + 155, // 2 Start 2. Action in Intro + 170, // 3 End Separation in Intro + 271, // 4 beginning Zoomout in Intro 0, // 5 unused - 261, // 6 Start fade-to-white im Intro + 261, // 6 Start fade-to-white in Intro 271, // 7 Start Main Part - 280, // 8 Start On-Beat-Sternchen Main Part + 280, // 8 Start On-Beat-Star Main Part 396, // 9 Start BlindGuard 666, // 10 Start blindy @@ -162,7 +163,7 @@ const 2826, // 18 Ende Whiteshark 3096, // 19 Start FadeOut Mainscreen 3366, // 20 Ende Credits Tune - 60); // 21 start flare im intro + 60); // 21 start flare in intro implementation @@ -176,9 +177,9 @@ uses Textgl, ULanguage, UCommon, - UPath; + UPathUtils; -function TScreenCredits.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenCredits.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then @@ -204,38 +205,38 @@ end; constructor TScreenCredits.Create; var - CreditsPath: string; + CreditsPath: IPath; begin inherited Create; - CreditsPath := ResourcesPath + 'credits/'; - - credits_bg_tex := Texture.LoadTexture(CreditsPath + CRDTS_BG_FILE, TEXTURE_TYPE_PLAIN, 0); - credits_bg_ovl := Texture.LoadTexture(CreditsPath + CRDTS_OVL_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - - credits_blindguard := Texture.LoadTexture(CreditsPath + CRDTS_blindguard_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - credits_blindy := Texture.LoadTexture(CreditsPath + CRDTS_blindy_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - credits_canni := Texture.LoadTexture(CreditsPath + CRDTS_canni_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - credits_commandio := Texture.LoadTexture(CreditsPath + CRDTS_commandio_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - credits_lazyjoker := Texture.LoadTexture(CreditsPath + CRDTS_lazyjoker_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - credits_mog := Texture.LoadTexture(CreditsPath + CRDTS_mog_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - credits_mota := Texture.LoadTexture(CreditsPath + CRDTS_mota_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - credits_skillmaster := Texture.LoadTexture(CreditsPath + CRDTS_skillmaster_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - credits_whiteshark := Texture.LoadTexture(CreditsPath + CRDTS_whiteshark_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - - intro_layer01 := Texture.LoadTexture(CreditsPath + INTRO_L01_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer02 := Texture.LoadTexture(CreditsPath + INTRO_L02_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer03 := Texture.LoadTexture(CreditsPath + INTRO_L03_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer04 := Texture.LoadTexture(CreditsPath + INTRO_L04_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer05 := Texture.LoadTexture(CreditsPath + INTRO_L05_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer06 := Texture.LoadTexture(CreditsPath + INTRO_L06_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer07 := Texture.LoadTexture(CreditsPath + INTRO_L07_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer08 := Texture.LoadTexture(CreditsPath + INTRO_L08_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer09 := Texture.LoadTexture(CreditsPath + INTRO_L09_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - - outro_bg := Texture.LoadTexture(CreditsPath + OUTRO_BG_FILE, TEXTURE_TYPE_PLAIN, 0); - outro_esc := Texture.LoadTexture(CreditsPath + OUTRO_ESC_FILE, TEXTURE_TYPE_TRANSPARENT, 0); - outro_exd := Texture.LoadTexture(CreditsPath + OUTRO_EXD_FILE, TEXTURE_TYPE_TRANSPARENT, 0); + CreditsPath := ResourcesPath.Append('credits', pdAppend); + + credits_bg_tex := Texture.LoadTexture(CreditsPath.Append(CRDTS_BG_FILE), TEXTURE_TYPE_PLAIN, 0); + credits_bg_ovl := Texture.LoadTexture(CreditsPath.Append(CRDTS_OVL_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + + credits_blindguard := Texture.LoadTexture(CreditsPath.Append(CRDTS_blindguard_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + credits_blindy := Texture.LoadTexture(CreditsPath.Append(CRDTS_blindy_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + credits_canni := Texture.LoadTexture(CreditsPath.Append(CRDTS_canni_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + credits_commandio := Texture.LoadTexture(CreditsPath.Append(CRDTS_commandio_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + credits_lazyjoker := Texture.LoadTexture(CreditsPath.Append(CRDTS_lazyjoker_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + credits_mog := Texture.LoadTexture(CreditsPath.Append(CRDTS_mog_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + credits_mota := Texture.LoadTexture(CreditsPath.Append(CRDTS_mota_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + credits_skillmaster := Texture.LoadTexture(CreditsPath.Append(CRDTS_skillmaster_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + credits_whiteshark := Texture.LoadTexture(CreditsPath.Append(CRDTS_whiteshark_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + + intro_layer01 := Texture.LoadTexture(CreditsPath.Append(INTRO_L01_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + intro_layer02 := Texture.LoadTexture(CreditsPath.Append(INTRO_L02_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + intro_layer03 := Texture.LoadTexture(CreditsPath.Append(INTRO_L03_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + intro_layer04 := Texture.LoadTexture(CreditsPath.Append(INTRO_L04_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + intro_layer05 := Texture.LoadTexture(CreditsPath.Append(INTRO_L05_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + intro_layer06 := Texture.LoadTexture(CreditsPath.Append(INTRO_L06_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + intro_layer07 := Texture.LoadTexture(CreditsPath.Append(INTRO_L07_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + intro_layer08 := Texture.LoadTexture(CreditsPath.Append(INTRO_L08_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + intro_layer09 := Texture.LoadTexture(CreditsPath.Append(INTRO_L09_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + + outro_bg := Texture.LoadTexture(CreditsPath.Append(OUTRO_BG_FILE), TEXTURE_TYPE_PLAIN, 0); + outro_esc := Texture.LoadTexture(CreditsPath.Append(OUTRO_ESC_FILE), TEXTURE_TYPE_TRANSPARENT, 0); + outro_exd := Texture.LoadTexture(CreditsPath.Append(OUTRO_EXD_FILE), TEXTURE_TYPE_TRANSPARENT, 0); CRDTS_Stage:=InitialDelay; end; @@ -246,7 +247,7 @@ begin Draw := true; end; -procedure TScreenCredits.onShow; +procedure TScreenCredits.OnShow; begin inherited; @@ -255,13 +256,13 @@ begin deluxe_slidein := 0; Credits_Alpha := 0; // Music.SetLoop(true); loop loops not, shit - AudioPlayback.Open(soundpath + 'wome-credits-tune.mp3'); // thank you wetue + AudioPlayback.Open(soundpath.Append('wome-credits-tune.mp3')); // thank you wetue // Music.Play; CTime := 0; // setlength(CTime_hold,0); end; -procedure TScreenCredits.onHide; +procedure TScreenCredits.OnHide; begin AudioPlayback.Stop; end; @@ -1386,7 +1387,7 @@ begin begin CTime_hold := 0; AudioPlayback.Stop; - AudioPlayback.Open(soundpath + 'credits-outro-tune.mp3'); + AudioPlayback.Open(SoundPath.Append('credits-outro-tune.mp3')); AudioPlayback.SetVolume(0.2); AudioPlayback.SetLoop(true); AudioPlayback.Play; diff --git a/cmake/src/screens/UScreenEdit.pas b/cmake/src/screens/UScreenEdit.pas index 5112e17a..12e2948c 100644 --- a/cmake/src/screens/UScreenEdit.pas +++ b/cmake/src/screens/UScreenEdit.pas @@ -45,8 +45,7 @@ type TextDescriptionLong: integer; constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; - PressedDown: boolean): boolean; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; procedure InteractNext; override; procedure InteractPrev; override; procedure InteractInc; override; @@ -60,10 +59,10 @@ uses UGraphic, UMusic, USkins, + UUnicodeUtils, SysUtils; -function TScreenEdit.ParseInput(PressedKey: cardinal; CharCode: WideChar; - PressedDown: boolean): boolean; +function TScreenEdit.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; var SDL_ModState: word; begin @@ -75,8 +74,8 @@ begin if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -158,8 +157,8 @@ end; procedure TScreenEdit.SetAnimationProgress(Progress: real); begin - Static[0].Texture.ScaleW := Progress; - Static[0].Texture.ScaleH := Progress; + Statics[0].Texture.ScaleW := Progress; + Statics[0].Texture.ScaleH := Progress; end; end. diff --git a/cmake/src/screens/UScreenEditConvert.pas b/cmake/src/screens/UScreenEditConvert.pas index e4a691cf..8b13d410 100644 --- a/cmake/src/screens/UScreenEditConvert.pas +++ b/cmake/src/screens/UScreenEditConvert.pas @@ -25,6 +25,29 @@ unit UScreenEditConvert; +{* + * See + * MIDI Recommended Practice (RP-017): SMF Lyric Meta Event Definition + * http://www.midi.org/techspecs/rp17.php + * MIDI Recommended Practice (RP-026): SMF Language and Display Extensions + * http://www.midi.org/techspecs/rp26.php + * MIDI File Format + * http://www.sonicspot.com/guide/midifiles.html + * KMIDI File Format + * http://gnese.free.fr/Projects/KaraokeTime/Fichiers/karfaq.html + * http://journals.rpungin.fotki.com/karaoke/category/midi + * + * There are two widely spread karaoke formats: + * - KMIDI (.kar), an inofficial midi extension by Tune 1000 + * - Standard Midi files with lyric meta-tags (SMF with lyrics, .mid). + * + * KMIDI uses two tracks, the first just contains a header (mostly track 2) and + * the second the lyrics (track 3). It uses text meta tags for the lyrics. + * SMF uses just one track (normally track 1) and uses lyric meta tags for storage. + * + * Most files are in the KMIDI format. Some Midi files contain both lyric types. + *} + interface {$IFDEF FPC} @@ -45,10 +68,11 @@ uses USongs, USong, UMusic, - UThemes; + UThemes, + UPath; type - TNote = record + TMidiNote = record Event: integer; EventType: integer; Channel: integer; @@ -56,70 +80,65 @@ type Len: real; Data1: integer; Data2: integer; - Str: string; + Str: UTF8String; // normally ASCII end; + TLyricType = (ltKMIDI, ltSMFLyric); + TTrack = record - Note: array of TNote; - Name: string; - Hear: boolean; - Status: set of (notes, lyrics); + Note: array of TMidiNote; + Name: UTF8String; // normally ASCII + Status: set of (tsNotes, tsLyrics); //< track contains notes, lyrics or both + LyricType: set of TLyricType; + NoteType: (ntNone, ntAvail); end; - TNuta = record + TNote = record Start: integer; Len: integer; Tone: integer; - Lyric: string; + Lyric: UTF8String; NewSentence: boolean; end; TArrayTrack = array of TTrack; TScreenEditConvert = class(TMenu) - public - ATrack: TArrayTrack; // actual track -// Track: TArrayTrack; - Channel: TArrayTrack; + private + Tracks: TArrayTrack; // current track ColR: array[0..100] of real; ColG: array[0..100] of real; ColB: array[0..100] of real; Len: real; - Sel: integer; - Selected: boolean; -// FileName: string; + SelTrack: integer; // index of selected track + fFileName: IPath; {$IFDEF UseMIDIPort} MidiFile: TMidiFile; - MidiTrack: TMidiTrack; - MidiEvent: pMidiEvent; MidiOut: TMidiOutput; {$ENDIF} - - Song: TSong; - Lines: TLines; + BPM: real; Ticks: real; - Note: array of TNuta; + Note: array of TNote; - procedure AddLyric(Start: integer; Text: string); - procedure Extract; + procedure AddLyric(Start: integer; LyricType: TLyricType; Text: UTF8String); + procedure Extract(out Song: TSong; out Lines: TLines); {$IFDEF UseMIDIPort} procedure MidiFile1MidiEvent(event: PMidiEvent); {$ENDIF} - - function SelectedNumber: integer; + + function CountSelectedTracks: integer; + + public constructor Create; override; - procedure onShow; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; + procedure OnShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; function Draw: boolean; override; - procedure onHide; override; + procedure OnHide; override; end; -var - ConversionFileName: string; - implementation uses @@ -131,17 +150,42 @@ uses UGraphic, UIni, UMain, - UPath, - USkins; - -function TScreenEditConvert.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; + UPathUtils, + USkins, + ULanguage, + UTextEncoding, + UUnicodeUtils; + +const + // MIDI/KAR lyrics are specified to be ASCII only. + // Assume backward compatible CP1252 encoding. + DEFAULT_ENCODING = encCP1252; + +const + MIDI_EVENTTYPE_NOTEOFF = $8; + MIDI_EVENTTYPE_NOTEON = $9; + MIDI_EVENTTYPE_META_SYSEX = $F; + + MIDI_EVENT_META = $FF; + MIDI_META_TEXT = $1; + MIDI_META_LYRICS = $5; + +function TScreenEditConvert.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; +{$IFDEF UseMIDIPort} +var + SResult: TSaveSongResult; + Playing: boolean; + MidiTrack: TMidiTrack; + Song: TSong; + Lines: TLines; +{$ENDIF} begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -153,9 +197,10 @@ begin SDLK_ESCAPE, SDLK_BACKSPACE : begin - {$IFDEF UseMIDIPort} - MidiFile.StopPlaying; - {$ENDIF} + {$IFDEF UseMIDIPort} + if (MidiFile <> nil) then + MidiFile.StopPlaying; + {$ENDIF} AudioPlayback.PlaySound(SoundLib.Back); FadeTo(@ScreenEdit); end; @@ -165,70 +210,97 @@ begin if Interaction = 0 then begin AudioPlayback.PlaySound(SoundLib.Start); + ScreenOpen.Filename := GamePath.Append('file.mid'); ScreenOpen.BackScreen := @ScreenEditConvert; FadeTo(@ScreenOpen); - end; - - if Interaction = 1 then + end + else if Interaction = 1 then begin - Selected := false; - {$IFDEF UseMIDIPort} - MidiFile.OnMidiEvent := MidiFile1MidiEvent; -// MidiFile.GoToTime(MidiFile.GetTrackLength div 2); - MidiFile.StartPlaying; + {$IFDEF UseMIDIPort} + if (MidiFile <> nil) then + begin + MidiFile.OnMidiEvent := MidiFile1MidiEvent; + //MidiFile.GoToTime(MidiFile.GetTrackLength div 2); + MidiFile.StartPlaying; + end; {$ENDIF} - end; - - if Interaction = 2 then + end + else if Interaction = 2 then begin - Selected := true; {$IFDEF UseMIDIPort} - MidiFile.OnMidiEvent := nil; - {$ENDIF} - {for T := 0 to High(ATrack) do + if (MidiFile <> nil) then begin - if ATrack[T].Hear then - begin - MidiTrack := MidiFile.GetTrack(T); - MidiTrack.OnMidiEvent := MidiFile1MidiEvent; - end; + MidiFile.OnMidiEvent := nil; + MidiFile.StartPlaying; end; - MidiFile.StartPlaying;//} - end; - - if Interaction = 3 then + {$ENDIF} + end + else if Interaction = 3 then begin - if SelectedNumber > 0 then + {$IFDEF UseMIDIPort} + if CountSelectedTracks > 0 then + begin + Extract(Song, Lines); + SResult := SaveSong(Song, Lines, fFileName.SetExtension('.txt'), + false); + FreeAndNil(Song); + if (SResult = ssrOK) then + ScreenPopupInfo.ShowPopup(Language.Translate('INFO_FILE_SAVED')) + else + ScreenPopupError.ShowPopup(Language.Translate('ERROR_SAVE_FILE_FAILED')); + end + else begin - Extract; - SaveSong(Song, Lines, ChangeFileExt(ConversionFileName, '.txt'), false); + ScreenPopupError.ShowPopup(Language.Translate('EDITOR_ERROR_NO_TRACK_SELECTED')); end; + {$ENDIF} end; end; SDLK_SPACE: begin -// ATrack[Sel].Hear := not ATrack[Sel].Hear; - if Notes in ATrack[Sel].Status then + {$IFDEF UseMIDIPort} + if (MidiFile <> nil) then begin - ATrack[Sel].Status := ATrack[Sel].Status - [Notes]; - if Lyrics in ATrack[Sel].Status then - ATrack[Sel].Status := ATrack[Sel].Status - [Lyrics] - else - ATrack[Sel].Status := ATrack[Sel].Status + [Lyrics]; - end - else - ATrack[Sel].Status := ATrack[Sel].Status + [Notes]; + if (Tracks[SelTrack].NoteType = ntAvail) and + (Tracks[SelTrack].LyricType <> []) then + begin + if (Tracks[SelTrack].Status = []) then + Tracks[SelTrack].Status := [tsNotes] + else if (Tracks[SelTrack].Status = [tsNotes]) then + Tracks[SelTrack].Status := [tsLyrics] + else if (Tracks[SelTrack].Status = [tsLyrics]) then + Tracks[SelTrack].Status := [tsNotes, tsLyrics] + else if (Tracks[SelTrack].Status = [tsNotes, tsLyrics]) then + Tracks[SelTrack].Status := []; + end + else if (Tracks[SelTrack].NoteType = ntAvail) then + begin + if (Tracks[SelTrack].Status = []) then + Tracks[SelTrack].Status := [tsNotes] + else + Tracks[SelTrack].Status := []; + end + else if (Tracks[SelTrack].LyricType <> []) then + begin + if (Tracks[SelTrack].Status = []) then + Tracks[SelTrack].Status := [tsLyrics] + else + Tracks[SelTrack].Status := []; + end; -{ if Selected then - begin - MidiTrack := MidiFile.GetTrack(Sel); - if Track[Sel].Hear then + Playing := (MidiFile.GetCurrentTime > 0); + MidiFile.StopPlaying(); + MidiTrack := MidiFile.GetTrack(SelTrack); + if tsNotes in Tracks[SelTrack].Status then MidiTrack.OnMidiEvent := MidiFile1MidiEvent else MidiTrack.OnMidiEvent := nil; - end;} + if (Playing) then + MidiFile.ContinuePlaying(); + end; + {$ENDIF} end; SDLK_RIGHT: @@ -243,102 +315,161 @@ begin SDLK_DOWN: begin - Inc(Sel); - if Sel > High(ATrack) then - Sel := 0; + Inc(SelTrack); + if SelTrack > High(Tracks) then + SelTrack := 0; end; SDLK_UP: begin - Dec(Sel); - if Sel < 0 then - Sel := High(ATrack); + Dec(SelTrack); + if SelTrack < 0 then + SelTrack := High(Tracks); end; end; end; end; -procedure TScreenEditConvert.AddLyric(Start: integer; Text: string); +procedure TScreenEditConvert.AddLyric(Start: integer; LyricType: TLyricType; Text: UTF8String); var N: integer; begin - for N := 0 to High(Note) do + // find corresponding note + N := 0; + while (N <= High(Note)) do begin if Note[N].Start = Start then - begin - // check for new sentece - if Copy(Text, 1, 1) = '\' then - Delete(Text, 1, 1); - if Copy(Text, 1, 1) = '/' then - begin - Delete(Text, 1, 1); - Note[N].NewSentence := true; - end; + Break; + Inc(N); + end; - // overwrite lyric od append - if Note[N].Lyric = '-' then - Note[N].Lyric := Text - else - Note[N].Lyric := Note[N].Lyric + Text; + // check if note was found + if (N > High(Note)) then + Exit; + + // set text + if (LyricType = ltKMIDI) then + begin + // end of paragraph + if Copy(Text, 1, 1) = '\' then + begin + Delete(Text, 1, 1); + end + // end of line + else if Copy(Text, 1, 1) = '/' then + begin + Delete(Text, 1, 1); + Note[N].NewSentence := true; + end; + end + else // SMFLyric + begin + // Line Feed -> end of paragraph + if Copy(Text, 1, 1) = #$0A then + begin + Delete(Text, 1, 1); + end + // Carriage Return -> end of line + else if Copy(Text, 1, 1) = #$0D then + begin + Delete(Text, 1, 1); + Note[N].NewSentence := true; end; end; + + // overwrite lyric or append + if Note[N].Lyric = '-' then + Note[N].Lyric := Text + else + Note[N].Lyric := Note[N].Lyric + Text; end; -procedure TScreenEditConvert.Extract; +procedure TScreenEditConvert.Extract(out Song: TSong; out Lines: TLines); + var T: integer; C: integer; N: integer; Nu: integer; - NoteTemp: TNuta; + NoteTemp: TNote; Move: integer; Max, Min: integer; + LyricType: TLyricType; + Text: UTF8String; begin // song info - Song.Title := ''; - Song.Artist := ''; - Song.Mp3 := ''; + Song := TSong.Create(); + Song.Clear(); Song.Resolution := 4; SetLength(Song.BPM, 1); Song.BPM[0].BPM := BPM*4; - SetLength(Note, 0); // extract notes - for T := 0 to High(ATrack) do + for T := 0 to High(Tracks) do begin -// if ATrack[T].Hear then -// begin - if Notes in ATrack[T].Status then + if tsNotes in Tracks[T].Status then begin - for N := 0 to High(ATrack[T].Note) do + for N := 0 to High(Tracks[T].Note) do begin - if (ATrack[T].Note[N].EventType = 9) and (ATrack[T].Note[N].Data2 > 0) then + if (Tracks[T].Note[N].EventType = MIDI_EVENTTYPE_NOTEON) and + (Tracks[T].Note[N].Data2 > 0) then begin Nu := Length(Note); SetLength(Note, Nu + 1); - Note[Nu].Start := Round(ATrack[T].Note[N].Start / Ticks); - Note[Nu].Len := Round(ATrack[T].Note[N].Len / Ticks); - Note[Nu].Tone := ATrack[T].Note[N].Data1 - 12*5; + Note[Nu].Start := Round(Tracks[T].Note[N].Start / Ticks); + Note[Nu].Len := Round(Tracks[T].Note[N].Len / Ticks); + Note[Nu].Tone := Tracks[T].Note[N].Data1 - 12*5; Note[Nu].Lyric := '-'; end; end; end; end; - // extract lyrics - for T := 0 to High(ATrack) do + // extract lyrics (and artist + title info) + for T := 0 to High(Tracks) do begin -// if ATrack[T].Hear then -// begin - if Lyrics in ATrack[T].Status then + if not (tsLyrics in Tracks[T].Status) then + Continue; + + for N := 0 to High(Tracks[T].Note) do begin - for N := 0 to High(ATrack[T].Note) do + if (Tracks[T].Note[N].Event = MIDI_EVENT_META) then begin - if (ATrack[T].Note[N].EventType = 15) then + // determine and validate lyric meta tag + if (ltKMIDI in Tracks[T].LyricType) and + (Tracks[T].Note[N].Data1 = MIDI_META_TEXT) then begin -// Log.LogStatus('<' + Track[T].Note[N].Str + '>', 'MIDI'); - AddLyric(Round(ATrack[T].Note[N].Start / Ticks), ATrack[T].Note[N].Str); + Text := Tracks[T].Note[N].Str; + + // check for meta info + if (Length(Text) > 2) and (Text[1] = '@') then + begin + case Text[2] of + 'L': Song.Language := Copy(Text, 3, Length(Text)); // language + 'T': begin // title info + if (Song.Artist = '') then + Song.Artist := Copy(Text, 3, Length(Text)) + else if (Song.Title = '') then + Song.Title := Copy(Text, 3, Length(Text)); + end; + end; + Continue; + end; + + LyricType := ltKMIDI; + end + else if (ltSMFLyric in Tracks[T].LyricType) and + (Tracks[T].Note[N].Data1 = MIDI_META_LYRICS) then + begin + LyricType := ltSMFLyric; + end + else + begin + // unknown meta event + Continue; end; + + AddLyric(Round(Tracks[T].Note[N].Start / Ticks), LyricType, Tracks[T].Note[N].Str); end; end; end; @@ -360,8 +491,12 @@ begin // copy notes SetLength(Lines.Line, 1); - Lines.Number := 1; - Lines.High := 0; + Lines.Number := 1; + Lines.High := 0; + Lines.Current := 0; + Lines.Resolution := 0; + Lines.NotesGAP := 0; + Lines.ScoreValue := 0; C := 0; N := 0; @@ -403,35 +538,37 @@ begin // create space for new note SetLength(Lines.Line[C].Note, Length(Lines.Line[C].Note)+1); + Inc(Lines.Line[C].HighNote); // initialize note Lines.Line[C].Note[N].Start := Note[Nu].Start; Lines.Line[C].Note[N].Length := Note[Nu].Len; Lines.Line[C].Note[N].Tone := Note[Nu].Tone; - Lines.Line[C].Note[N].Text := Note[Nu].Lyric; - //All Notes are Freestyle when Converted Fix: + Lines.Line[C].Note[N].Text := DecodeStringUTF8(Note[Nu].Lyric, DEFAULT_ENCODING); Lines.Line[C].Note[N].NoteType := ntNormal; Inc(N); end; end; -function TScreenEditConvert.SelectedNumber: integer; +function TScreenEditConvert.CountSelectedTracks: integer; var T: integer; // track begin Result := 0; - for T := 0 to High(ATrack) do -// if ATrack[T].Hear then -// Inc(Result); - if Notes in ATrack[T].Status then + for T := 0 to High(Tracks) do + if tsNotes in Tracks[T].Status then Inc(Result); end; {$IFDEF UseMIDIPort} procedure TScreenEditConvert.MidiFile1MidiEvent(event: PMidiEvent); begin -// Log.LogStatus(IntToStr(event.event), 'MIDI'); - MidiOut.PutShort(event.event, event.data1, event.data2); + //Log.LogStatus(IntToStr(event.event), 'MIDI'); + try + MidiOut.PutShort(event.event, event.data1, event.data2); + except + MidiFile.StopPlaying(); + end; end; {$ENDIF} @@ -442,7 +579,7 @@ begin inherited Create; AddButton(40, 20, 100, 40, Skin.GetTextureFileName('ButtonF')); AddButtonText(15, 5, 0, 0, 0, 'Open'); -// Button[High(Button)].Text[0].Size := 11; + //Button[High(Button)].Text[0].Size := 11; AddButton(160, 20, 100, 40, Skin.GetTextureFileName('ButtonF')); AddButtonText(25, 5, 0, 0, 0, 'Play'); @@ -453,19 +590,7 @@ begin AddButton(500, 20, 100, 40, Skin.GetTextureFileName('ButtonF')); AddButtonText(20, 5, 0, 0, 0, 'Save'); -{ MidiOut := TMidiOutput.Create(nil); -// MidiOut.Close; -// MidiOut.DeviceID := 0; - if Ini.Debug = 1 then - MidiOut.ProductName := 'Microsoft GS Wavetable SW Synth'; // for my kxproject without midi table - Log.LogStatus(MidiOut.ProductName, 'MIDI'); - MidiOut.Open; -// MidiOut.SetVolume(100, 100); // temporary} - - ConversionFileName := GamePath + 'file.mid'; - {$IFDEF UseMIDIPort} - MidiFile := TMidiFile.Create(nil); - {$ENDIF} + fFileName := PATH_NONE; for P := 0 to 100 do begin @@ -476,96 +601,124 @@ begin end; -procedure TScreenEditConvert.onShow; +procedure TScreenEditConvert.OnShow; +{$IFDEF UseMIDIPort} var T: integer; // track N: integer; // note - C: integer; // channel - CN: integer; // channel note + MidiTrack: TMidiTrack; + MidiEvent: PMidiEvent; + FileOpened: boolean; + KMIDITrackIndex, SMFTrackIndex: integer; +{$ENDIF} begin inherited; + Interaction := 0; + {$IFDEF UseMIDIPort} MidiOut := TMidiOutput.Create(nil); - if Ini.Debug = 1 then - MidiOut.ProductName := 'Microsoft GS Wavetable SW Synth'; // for my kxproject without midi table - Log.LogStatus(MidiOut.ProductName, 'MIDI'); + Log.LogInfo(MidiOut.ProductName, 'MIDI'); MidiOut.Open; + MidiFile := nil; + SetLength(Tracks, 0); + + // Filename is only <> PATH_NONE if we called the OpenScreen before + fFilename := ScreenOpen.Filename; + if (fFilename = PATH_NONE) then + Exit; + ScreenOpen.Filename := PATH_NONE; - if FileExists(ConversionFileName) then + FileOpened := false; + if fFileName.Exists then begin - MidiFile.Filename := ConversionFileName; - MidiFile.ReadFile; + MidiFile := TMidiFile.Create(nil); + MidiFile.Filename := fFileName; + try + MidiFile.ReadFile; + FileOpened := true; + except + MidiFile.Free; + end; + end; - Len := 0; - Sel := 0; - BPM := MidiFile.Bpm; - Ticks := MidiFile.TicksPerQuarter / 4; + if (not FileOpened) then + begin + ScreenPopupError.ShowPopup(Language.Translate('ERROR_FILE_NOT_FOUND')); + Exit; + end; -{ for T := 0 to MidiFile.NumberOfTracks-1 do - begin - SetLength(Track, Length(Track)+1); - MidiTrack := MidiFile.GetTrack(T); - MidiTrack.OnMidiEvent := MidiFile1MidiEvent; - Track[T].Name := MidiTrack.getName; + Len := 0; + SelTrack := 0; + BPM := MidiFile.Bpm; + Ticks := MidiFile.TicksPerQuarter / 4; - for N := 0 to MidiTrack.getEventCount-1 do - begin - SetLength(Track[T].Note, Length(Track[T].Note)+1); - MidiEvent := MidiTrack.GetEvent(N); - Track[T].Note[N].Start := MidiEvent.time; - Track[T].Note[N].Len := MidiEvent.len; - Track[T].Note[N].Event := MidiEvent.event; - Track[T].Note[N].EventType := MidiEvent.event div 16; - Track[T].Note[N].Channel := MidiEvent.event and 15; - Track[T].Note[N].Data1 := MidiEvent.data1; - Track[T].Note[N].Data2 := MidiEvent.data2; - Track[T].Note[N].Str := MidiEvent.str; - - if Track[T].Note[N].Start + Track[T].Note[N].Len > Len then - Len := Track[T].Note[N].Start + Track[T].Note[N].Len; - end; - end;} + KMIDITrackIndex := -1; + SMFTrackIndex := -1; - SetLength(Channel, 16); - for T := 0 to 15 do - begin - Channel[T].Name := IntToStr(T+1); - SetLength(Channel[T].Note, 0); - Channel[T].Status := []; - end; + SetLength(Tracks, MidiFile.NumberOfTracks); + for T := 0 to MidiFile.NumberOfTracks-1 do + Tracks[T].LyricType := []; - for T := 0 to MidiFile.NumberOfTracks-1 do + for T := 0 to MidiFile.NumberOfTracks-1 do + begin + MidiTrack := MidiFile.GetTrack(T); + MidiTrack.OnMidiEvent := nil; + Tracks[T].Name := DecodeStringUTF8(MidiTrack.getName, DEFAULT_ENCODING); + Tracks[T].NoteType := ntNone; + Tracks[T].Status := []; + + SetLength(Tracks[T].Note, MidiTrack.getEventCount()); + for N := 0 to MidiTrack.getEventCount-1 do begin - MidiTrack := MidiFile.GetTrack(T); - MidiTrack.OnMidiEvent := MidiFile1MidiEvent; - - for N := 0 to MidiTrack.getEventCount-1 do + MidiEvent := MidiTrack.GetEvent(N); + + Tracks[T].Note[N].Start := MidiEvent.time; + Tracks[T].Note[N].Len := MidiEvent.len; + Tracks[T].Note[N].Event := MidiEvent.event; + Tracks[T].Note[N].EventType := MidiEvent.event shr 4; + Tracks[T].Note[N].Channel := MidiEvent.event and $0F; + Tracks[T].Note[N].Data1 := MidiEvent.data1; + Tracks[T].Note[N].Data2 := MidiEvent.data2; + Tracks[T].Note[N].Str := DecodeStringUTF8(MidiEvent.str, DEFAULT_ENCODING); + + if (Tracks[T].Note[N].Event = MIDI_EVENT_META) then + begin + case (Tracks[T].Note[N].Data1) of + MIDI_META_TEXT: begin + // KMIDI lyrics (uses MIDI_META_TEXT events) + if (StrLComp(PAnsiChar(Tracks[T].Note[N].Str), '@KMIDI KARAOKE FILE', 19) = 0) and + (High(Tracks) >= T+1) then + begin + // The '@KMIDI ...' mark is in the first track (mostly named 'Soft Karaoke') + // but the lyrics are in the second track (named 'Words') + Tracks[T+1].LyricType := Tracks[T+1].LyricType + [ltKMIDI]; + KMIDITrackIndex := T+1; + end; + end; + MIDI_META_LYRICS: begin + // lyrics in Standard Midi File format found (uses MIDI_META_LYRICS events) + Tracks[T].LyricType := Tracks[T].LyricType + [ltSMFLyric]; + SMFTrackIndex := T; + end; + end; + end + else if (Tracks[T].Note[N].EventType = MIDI_EVENTTYPE_NOTEON) then begin - MidiEvent := MidiTrack.GetEvent(N); - C := MidiEvent.event and 15; - - CN := Length(Channel[C].Note); - SetLength(Channel[C].Note, CN+1); - - Channel[C].Note[CN].Start := MidiEvent.time; - Channel[C].Note[CN].Len := MidiEvent.len; - Channel[C].Note[CN].Event := MidiEvent.event; - Channel[C].Note[CN].EventType := MidiEvent.event div 16; - Channel[C].Note[CN].Channel := MidiEvent.event and 15; - Channel[C].Note[CN].Data1 := MidiEvent.data1; - Channel[C].Note[CN].Data2 := MidiEvent.data2; - Channel[C].Note[CN].Str := MidiEvent.str; - - if Channel[C].Note[CN].Start + Channel[C].Note[CN].Len > Len then - Len := Channel[C].Note[CN].Start + Channel[C].Note[CN].Len; + // notes available + Tracks[T].NoteType := ntAvail; end; - end; - ATrack := Channel; + if Tracks[T].Note[N].Start + Tracks[T].Note[N].Len > Len then + Len := Tracks[T].Note[N].Start + Tracks[T].Note[N].Len; + end; end; - Interaction := 0; + // set default lyric track. Prefer KMIDI. + if (KMIDITrackIndex > -1) then + Tracks[KMIDITrackIndex].Status := Tracks[KMIDITrackIndex].Status + [tsLyrics] + else if (SMFTrackIndex > -1) then + Tracks[SMFTrackIndex].Status := Tracks[SMFTrackIndex].Status + [tsLyrics]; {$ENDIF} end; @@ -584,35 +737,37 @@ begin Y := 100; - Height := min(480, 40 * Length(ATrack)); + Height := min(480, 40 * Length(Tracks)); Bottom := Y + Height; - if Length(ATrack) = 0 then // prevent crash with uncomplete code. - begin - Log.LogDebug ('UScreenEditConvert -> TScreenEditConvert.Draw:', 'Length(ATrack) = 0'); - YSkip := 40; - end - else - YSkip := Height / Length(ATrack); + YSkip := Height / Length(Tracks); - // select - DrawQuad(10, Y + Sel*YSkip, 780, YSkip, 0.8, 0.8, 0.8); + // highlight selected track + DrawQuad(10, Y+SelTrack*YSkip, 780, YSkip, 0.8, 0.8, 0.8); - // selected - now me use Status System - for Count := 0 to High(ATrack) do - if ATrack[Count].Hear then + // track-selection info + for Count := 0 to High(Tracks) do + if Tracks[Count].Status <> [] then DrawQuad(10, Y + Count*YSkip, 50, YSkip, 0.8, 0.3, 0.3); glColor3f(0, 0, 0); - for Count := 0 to High(ATrack) do + for Count := 0 to High(Tracks) do begin - if Notes in ATrack[Count].Status then + if Tracks[Count].NoteType = ntAvail then begin + if tsNotes in Tracks[Count].Status then + glColor3f(0, 0, 0) + else + glColor3f(0.7, 0.7, 0.7); SetFontPos(25, Y + Count*YSkip + 10); SetFontSize(15); glPrint('N'); end; - if Lyrics in ATrack[Count].Status then + if Tracks[Count].LyricType <> [] then begin + if tsLyrics in Tracks[Count].Status then + glColor3f(0, 0, 0) + else + glColor3f(0.7, 0.7, 0.7); SetFontPos(40, Y + Count*YSkip + 10); SetFontSize(15); glPrint('L'); @@ -623,51 +778,48 @@ begin DrawLine( 60, Y, 60, Bottom, 0, 0, 0); DrawLine(790, Y, 790, Bottom, 0, 0, 0); - for Count := 0 to Length(ATrack) do + for Count := 0 to Length(Tracks) do DrawLine(10, Y + Count*YSkip, 790, Y + Count*YSkip, 0, 0, 0); - for Count := 0 to High(ATrack) do + for Count := 0 to High(Tracks) do begin - SetFontPos(11, Y + 10 + Count*YSkip); + SetFontPos(65, Y + Count*YSkip); SetFontSize(15); - glPrint(ATrack[Count].Name); + glPrint(Tracks[Count].Name); end; - for Count := 0 to High(ATrack) do - for Count2 := 0 to High(ATrack[Count].Note) do + for Count := 0 to High(Tracks) do + begin + for Count2 := 0 to High(Tracks[Count].Note) do begin - if ATrack[Count].Note[Count2].EventType = 9 then - DrawQuad(60 + ATrack[Count].Note[Count2].Start/Len*725, - Y + (Count+1)*YSkip - ATrack[Count].Note[Count2].Data1*35/127, - 3, - 3, - ColR[Count], - ColG[Count], - ColB[Count]); - if ATrack[Count].Note[Count2].EventType = 15 then - DrawLine(60 + ATrack[Count].Note[Count2].Start/Len*725, - Y + 0.75*YSkip + Count*YSkip, - 60 + ATrack[Count].Note[Count2].Start/Len*725, - Y + YSkip + Count*YSkip, - ColR[Count], - ColG[Count], - ColB[Count]); + if Tracks[Count].Note[Count2].EventType = MIDI_EVENTTYPE_NOTEON then + DrawQuad(60 + Tracks[Count].Note[Count2].Start/Len * 725, + Y + (Count+1)*YSkip - Tracks[Count].Note[Count2].Data1*35/127, + 3, 3, + ColR[Count], ColG[Count], ColB[Count]); + if Tracks[Count].Note[Count2].EventType = 15 then + DrawLine(60 + Tracks[Count].Note[Count2].Start/Len * 725, Y + 0.75 * YSkip + Count*YSkip, + 60 + Tracks[Count].Note[Count2].Start/Len * 725, Y + YSkip + Count*YSkip, + ColR[Count], ColG[Count], ColB[Count]); end; + end; // playing line {$IFDEF UseMIDIPort} - X := 60 + MidiFile.GetCurrentTime/MidiFile.GetTrackLength*730; + if (MidiFile <> nil) then + X := 60 + MidiFile.GetCurrentTime/MidiFile.GetTrackLength*730; {$ENDIF} DrawLine(X, Y, X, Bottom, 0.3, 0.3, 0.3); Result := true; end; -procedure TScreenEditConvert.onHide; +procedure TScreenEditConvert.OnHide; begin {$IFDEF UseMIDIPort} + FreeAndNil(MidiFile); MidiOut.Close; - MidiOut.Free; + FreeAndNil(MidiOut); {$ENDIF} end; diff --git a/cmake/src/screens/UScreenEditHeader.pas b/cmake/src/screens/UScreenEditHeader.pas index ad0fc40a..1d697bc9 100644 --- a/cmake/src/screens/UScreenEditHeader.pas +++ b/cmake/src/screens/UScreenEditHeader.pas @@ -38,6 +38,7 @@ uses SDL, USongs, USong, + UPath, UThemes; type @@ -72,8 +73,8 @@ type procedure SetRoundButtons; constructor Create; override; - procedure onShow; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; + procedure OnShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; { function Draw: boolean; override; procedure Finish;} end; @@ -86,17 +87,18 @@ uses SysUtils, UFiles, USkins, - UTexture; + UTexture, + UUnicodeUtils; -function TScreenEditHeader.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenEditHeader.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; var T: integer; begin Result := true; if (PressedDown) then // Key Down begin // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -105,10 +107,10 @@ begin // check special keys case PressedKey of - SDLK_ESCAPE : + SDLK_ESCAPE: begin -// Music.PlayBack; -// FadeTo(@MainScreen); + //Music.PlayBack; + //FadeTo(@MainScreen); Result := false; end; @@ -116,7 +118,7 @@ begin begin if Interaction = 1 then begin -// Save; + //Save; end; end; @@ -159,19 +161,19 @@ begin T := Interaction - 2 + TextTitle; if (Interaction >= 2) and (Interaction <= 13) and (Length(Text[T].Text) >= 1) then begin - Text[T].DeleteLastL; + Text[T].DeleteLastLetter; SetRoundButtons; end; end; end; case CharCode of - #32..#255: + 32..255: begin if (Interaction >= 2) and (Interaction <= 13) then begin Text[Interaction - 2 + TextTitle].Text := - Text[Interaction - 2 + TextTitle].Text + CharCode; + Text[Interaction - 2 + TextTitle].Text + UCS4ToUTF8String(CharCode); SetRoundButtons; end; end; @@ -223,18 +225,18 @@ begin TextGAP := AddText(340, 110 + 13*30, 0, 30, 0, 0, 0, ''); TextBPM := AddText(340, 110 + 14*30, 0, 30, 0, 0, 0, ''); - StaticTitle := AddStatic(130, 115 + 0*30, 20, 20, 1, 1, 1, 'RoundButton', TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticArtist := AddStatic(130, 115 + 1*30, 20, 20, 1, 1, 1, 'RoundButton', TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticMp3 := AddStatic(130, 115 + 2*30, 20, 20, 1, 1, 1, 'RoundButton', TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticBackground := AddStatic(130, 115 + 4*30, 20, 20, 1, 1, 1, 'RoundButton', TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticVideo := AddStatic(130, 115 + 5*30, 20, 20, 1, 1, 1, 'RoundButton', TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticVideoGAP := AddStatic(130, 115 + 6*30, 20, 20, 1, 1, 1, 'RoundButton', TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticRelative := AddStatic(130, 115 + 8*30, 20, 20, 1, 1, 1, 'RoundButton', TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticResolution := AddStatic(130, 115 + 9*30, 20, 20, 1, 1, 1, 'RoundButton', TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticNotesGAP := AddStatic(130, 115 + 10*30, 20, 20, 1, 1, 1, 'RoundButton', TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticStart := AddStatic(130, 115 + 12*30, 20, 20, 1, 1, 1, 'RoundButton', TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticGAP := AddStatic(130, 115 + 13*30, 20, 20, 1, 1, 1, 'RoundButton', TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticBPM := AddStatic(130, 115 + 14*30, 20, 20, 1, 1, 1, 'RoundButton', TEXTURE_TYPE_TRANSPARENT, $FF00FF); + StaticTitle := AddStatic(130, 115 + 0*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); + StaticArtist := AddStatic(130, 115 + 1*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); + StaticMp3 := AddStatic(130, 115 + 2*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); + StaticBackground := AddStatic(130, 115 + 4*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); + StaticVideo := AddStatic(130, 115 + 5*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); + StaticVideoGAP := AddStatic(130, 115 + 6*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); + StaticRelative := AddStatic(130, 115 + 8*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); + StaticResolution := AddStatic(130, 115 + 9*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); + StaticNotesGAP := AddStatic(130, 115 + 10*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); + StaticStart := AddStatic(130, 115 + 12*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); + StaticGAP := AddStatic(130, 115 + 13*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); + StaticBPM := AddStatic(130, 115 + 14*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); AddInteraction(iText, TextTitle); AddInteraction(iText, TextArtist); @@ -250,7 +252,7 @@ begin AddInteraction(iText, TextBPM); end; -procedure TScreenEditHeader.onShow; +procedure TScreenEditHeader.OnShow; begin inherited; @@ -347,90 +349,90 @@ end;*) procedure TScreenEditHeader.SetRoundButtons; begin if Length(Text[TextTitle].Text) > 0 then - Static[StaticTitle].Visible := true + Statics[StaticTitle].Visible := true else - Static[StaticTitle].Visible := false; + Statics[StaticTitle].Visible := false; if Length(Text[TextArtist].Text) > 0 then - Static[StaticArtist].Visible := true + Statics[StaticArtist].Visible := true else - Static[StaticArtist].Visible := false; + Statics[StaticArtist].Visible := false; if Length(Text[TextMp3].Text) > 0 then - Static[StaticMp3].Visible := true + Statics[StaticMp3].Visible := true else - Static[StaticMp3].Visible := false; + Statics[StaticMp3].Visible := false; if Length(Text[TextBackground].Text) > 0 then - Static[StaticBackground].Visible := true + Statics[StaticBackground].Visible := true else - Static[StaticBackground].Visible := false; + Statics[StaticBackground].Visible := false; if Length(Text[TextVideo].Text) > 0 then - Static[StaticVideo].Visible := true + Statics[StaticVideo].Visible := true else - Static[StaticVideo].Visible := false; + Statics[StaticVideo].Visible := false; try StrToFloat(Text[TextVideoGAP].Text); if StrToFloat(Text[TextVideoGAP].Text)<> 0 then - Static[StaticVideoGAP].Visible := true + Statics[StaticVideoGAP].Visible := true else - Static[StaticVideoGAP].Visible := false; + Statics[StaticVideoGAP].Visible := false; except - Static[StaticVideoGAP].Visible := false; + Statics[StaticVideoGAP].Visible := false; end; if LowerCase(Text[TextRelative].Text) = 'yes' then - Static[StaticRelative].Visible := true + Statics[StaticRelative].Visible := true else - Static[StaticRelative].Visible := false; + Statics[StaticRelative].Visible := false; try StrToInt(Text[TextResolution].Text); if (StrToInt(Text[TextResolution].Text) <> 0) and (StrToInt(Text[TextResolution].Text) >= 1) then - Static[StaticResolution].Visible := true + Statics[StaticResolution].Visible := true else - Static[StaticResolution].Visible := false; + Statics[StaticResolution].Visible := false; except - Static[StaticResolution].Visible := false; + Statics[StaticResolution].Visible := false; end; try StrToInt(Text[TextNotesGAP].Text); - Static[StaticNotesGAP].Visible := true; + Statics[StaticNotesGAP].Visible := true; except - Static[StaticNotesGAP].Visible := false; + Statics[StaticNotesGAP].Visible := false; end; // start try StrToFloat(Text[TextStart].Text); if (StrToFloat(Text[TextStart].Text) > 0) then - Static[StaticStart].Visible := true + Statics[StaticStart].Visible := true else - Static[StaticStart].Visible := false; + Statics[StaticStart].Visible := false; except - Static[StaticStart].Visible := false; + Statics[StaticStart].Visible := false; end; // GAP try StrToFloat(Text[TextGAP].Text); - Static[StaticGAP].Visible := true; + Statics[StaticGAP].Visible := true; except - Static[StaticGAP].Visible := false; + Statics[StaticGAP].Visible := false; end; // BPM try StrToFloat(Text[TextBPM].Text); if (StrToFloat(Text[TextBPM].Text) > 0) then - Static[StaticBPM].Visible := true + Statics[StaticBPM].Visible := true else - Static[StaticBPM].Visible := false; + Statics[StaticBPM].Visible := false; except - Static[StaticBPM].Visible := false; + Statics[StaticBPM].Visible := false; end; end; diff --git a/cmake/src/screens/UScreenEditSub.pas b/cmake/src/screens/UScreenEditSub.pas index 3e1f3c1c..7956b127 100644 --- a/cmake/src/screens/UScreenEditSub.pas +++ b/cmake/src/screens/UScreenEditSub.pas @@ -56,6 +56,7 @@ uses type TScreenEditSub = class(TMenu) private + AktBeat: integer; //Variable is True if no Song is loaded Error: boolean; @@ -90,6 +91,7 @@ type MidiLastNote: integer; TextEditMode: boolean; + editText: UTF8String; //backup of current text in text-edit-mode Lyric: TEditorLyrics; @@ -110,17 +112,19 @@ type procedure PasteText; procedure CopySentence(Src, Dst: integer); procedure CopySentences(Src, Dst, Num: integer); + procedure DrawStatics; + procedure DrawInfoBar(x, y, w, h: integer); //Note Name Mod function GetNoteName(Note: integer): string; public Tex_Background: TTexture; FadeOut: boolean; constructor Create; override; - procedure onShow; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - function ParseInputEditText(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; + procedure OnShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + function ParseInputEditText(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; function Draw: boolean; override; - procedure onHide; override; + procedure OnHide; override; end; implementation @@ -130,14 +134,44 @@ uses UDraw, UNote, USkins, - ULanguage; + ULanguage, + UTextEncoding, + UUnicodeUtils, + UPath; + + +procedure OnSaveEncodingError(Value: boolean; Data: Pointer); +var + SResult: TSaveSongResult; + FilePath: IPath; + Success: boolean; +begin + Success := false; + if (Value) then + begin + CurrentSong.Encoding := encUTF8; + FilePath := CurrentSong.Path.Append(CurrentSong.FileName); + // create backup file + FilePath.CopyFile(Path(FilePath.ToUTF8 + '.ansi.bak'), false); + // store in UTF-8 encoding + SResult := SaveSong(CurrentSong, Lines[0], FilePath, + boolean(Data)); + Success := (SResult = ssrOK); + end; + + if (Success) then + ScreenPopupInfo.ShowPopup(Language.Translate('INFO_FILE_SAVED')) + else + ScreenPopupError.ShowPopup(Language.Translate('ERROR_SAVE_FILE_FAILED')); +end; // Method for input parsing. If false is returned, GetNextWindow // should be checked to know the next window to load; -function TScreenEditSub.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenEditSub.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; var SDL_ModState: word; R: real; + SResult: TSaveSongResult; begin Result := true; @@ -152,40 +186,68 @@ begin + KMOD_LCTRL + KMOD_RCTRL + KMOD_LALT + KMOD_RALT {+ KMOD_CAPS}); if (PressedDown) then // Key Down - begin // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + begin + // check normal keys + case PressedKey of + SDLK_Q: begin Result := false; Exit; end; - 'S': + SDLK_S: begin // Save Song - if SDL_ModState = KMOD_LSHIFT then - SaveSong(CurrentSong, Lines[0], CurrentSong.Path + CurrentSong.FileName, true) + SResult := SaveSong(CurrentSong, Lines[0], CurrentSong.Path.Append(CurrentSong.FileName), + (SDL_ModState = KMOD_LSHIFT)); + if (SResult = ssrOK) then + begin + //ScreenPopupInfo.ShowPopup(Language.Translate('INFO_FILE_SAVED')); + Text[TextDebug].Text := Language.Translate('INFO_FILE_SAVED'); + end + else if (SResult = ssrEncodingError) then + begin + ScreenPopupCheck.ShowPopup(Language.Translate('ENCODING_ERROR_ASK_FOR_UTF8'), OnSaveEncodingError, + Pointer(SDL_ModState = KMOD_LSHIFT), true); + end else - SaveSong(CurrentSong, Lines[0], CurrentSong.Path + CurrentSong.FileName, false); + begin + ScreenPopupError.ShowPopup(Language.Translate('ERROR_SAVE_FILE_FAILED')); + end; + Exit; + end; - {if SDL_ModState = KMOD_LSHIFT or KMOD_LCTRL + KMOD_LALT then - // Save Song - SaveSongDebug(CurrentSong, Lines[0], 'C:\song.asm', false);} + SDLK_R: //reload + begin + AudioPlayback.Stop; + {$IFDEF UseMIDIPort} + MidiOut.Close; + MidiOut.Free; + {$ENDIF} + Lyric.Free; - Exit; + onShow; + Text[TextDebug].Text := 'song reloaded'; //TODO: Language.Translate('SONG_RELOADED'); end; - 'D': + + SDLK_D: begin // Divide lengths by 2 - DivideBPM; - Exit; + if (SDL_ModState = KMOD_LSHIFT) then + begin + DivideBPM; + Exit; + end; end; - 'M': + SDLK_M: begin // Multiply lengths by 2 - MultiplyBPM; - Exit; + if (SDL_ModState = KMOD_LSHIFT) then + begin + MultiplyBPM; + Exit; + end; end; - 'C': + SDLK_C: begin // Capitalize letter at the beginning of line if SDL_ModState = 0 then @@ -201,7 +263,7 @@ begin Exit; end; - 'V': + SDLK_V: begin // Paste text if SDL_ModState = KMOD_LCTRL then @@ -217,13 +279,13 @@ begin CopySentence(CopySrc, Lines[0].Current); end; end; - 'T': + SDLK_T: begin // Fixes timings between sentences FixTimings; Exit; end; - 'P': + SDLK_P: begin if SDL_ModState = 0 then begin @@ -269,8 +331,8 @@ begin Exit; end; - // Golden Note Patch - 'G': + // Golden Note + SDLK_G: begin if (Lines[0].Line[Lines[0].Current].Note[CurrentNote].NoteType = ntGolden) then Lines[0].Line[Lines[0].Current].Note[CurrentNote].NoteType := ntNormal @@ -280,8 +342,8 @@ begin Exit; end; - // Freestyle Note Patch - 'F': + // Freestyle Note + SDLK_F: begin if (Lines[0].Line[Lines[0].Current].Note[CurrentNote].NoteType = ntFreestyle) then Lines[0].Line[Lines[0].Current].Note[CurrentNote].NoteType := ntNormal @@ -424,22 +486,40 @@ begin SDLK_F4: begin // Enter Text Edit Mode + editText := Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text; TextEditMode := true; end; SDLK_SPACE: begin - // Play Sentence - PlaySentenceMidi := false; // stop midi - PlaySentence := true; - Click := false; - AudioPlayback.Stop; - AudioPlayback.Position := GetTimeFromBeat(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Start); - PlayStopTime := (GetTimeFromBeat( - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Start + - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Length)); - AudioPlayback.Play; - LastClick := -100; + if (SDL_ModState = 0) or (SDL_ModState = KMOD_LSHIFT or KMOD_LCTRL) then + begin + // Play Sentence + PlaySentenceMidi := false; // stop midi + PlaySentence := true; + Click := false; + AudioPlayback.Stop; + AudioPlayback.Position := GetTimeFromBeat(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Start); + PlayStopTime := (GetTimeFromBeat( + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Start + + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Length)); + AudioPlayback.Play; + LastClick := -100; + end; + + if (SDL_ModState = KMOD_LSHIFT) or (SDL_ModState = KMOD_LSHIFT or KMOD_LCTRL) then + begin + // Play Midi + PlaySentenceMidi := true; + + MidiTime := USTime.GetTime; + MidiStart := GetTimeFromBeat(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Start); + MidiStop := GetTimeFromBeat( + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Start + + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Length); + + LastClick := -100; + end; end; SDLK_RETURN: @@ -466,11 +546,11 @@ begin // right if SDL_ModState = 0 then begin - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 0; + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; Inc(CurrentNote); if CurrentNote > Lines[0].Line[Lines[0].Current].HighNote then CurrentNote := 0; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; Lyric.Selected := CurrentNote; end; @@ -521,11 +601,11 @@ begin // left if SDL_ModState = 0 then begin - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 0; + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; Dec(CurrentNote); if CurrentNote = -1 then CurrentNote := Lines[0].Line[Lines[0].Current].HighNote; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; Lyric.Selected := CurrentNote; end; @@ -580,17 +660,18 @@ begin // skip to next sentence if SDL_ModState = 0 then - begin {$IFDEF UseMIDIPort} + begin + {$IFDEF UseMIDIPort} MidiOut.PutShort($81, Lines[0].Line[Lines[0].Current].Note[MidiLastNote].Tone + 60, 127); PlaySentenceMidi := false; - {$endif} + {$ENDIF} - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 0; + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; Inc(Lines[0].Current); CurrentNote := 0; if Lines[0].Current > Lines[0].High then Lines[0].Current := 0; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; Lyric.AddLine(Lines[0].Current); Lyric.Selected := 0; @@ -617,12 +698,12 @@ begin PlaySentenceMidi := false; {$endif} - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 0; + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; Dec(Lines[0].Current); CurrentNote := 0; if Lines[0].Current = -1 then Lines[0].Current := Lines[0].High; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; Lyric.AddLine(Lines[0].Current); Lyric.Selected := 0; @@ -642,7 +723,7 @@ begin end; // if end; -function TScreenEditSub.ParseInputEditText(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenEditSub.ParseInputEditText(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; var SDL_ModState: word; begin @@ -653,39 +734,51 @@ begin + KMOD_LCTRL + KMOD_RCTRL + KMOD_LALT + KMOD_RALT {+ KMOD_CAPS}); if (PressedDown) then - begin // Key Down - case PressedKey of + begin + // check normal keys + if (IsPrintableChar(CharCode)) then + begin + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text := + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text + UCS4ToUTF8String(CharCode); + + Lyric.AddLine(Lines[0].Current); + Lyric.Selected := CurrentNote; + Exit; + end; + // check special keys + case PressedKey of SDLK_ESCAPE: begin - FadeTo(@ScreenSong); + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text := editText; + Lyric.AddLine(Lines[0].Current); + Lyric.Selected := CurrentNote; + TextEditMode := false; end; SDLK_F4, SDLK_RETURN: begin // Exit Text Edit Mode TextEditMode := false; end; - SDLK_0..SDLK_9, SDLK_A..SDLK_Z, SDLK_SPACE, SDLK_MINUS, SDLK_EXCLAIM, SDLK_COMMA, SDLK_SLASH, SDLK_ASTERISK, SDLK_QUESTION, SDLK_QUOTE, SDLK_QUOTEDBL: - begin - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text := - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text + CharCode; - end; SDLK_BACKSPACE: begin - Delete(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text, - Length(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text), 1); + UTF8Delete(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text, + LengthUTF8(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text), 1); + Lyric.AddLine(Lines[0].Current); + Lyric.Selected := CurrentNote; end; SDLK_RIGHT: begin // right if SDL_ModState = 0 then begin - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 0; + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; Inc(CurrentNote); if CurrentNote > Lines[0].Line[Lines[0].Current].HighNote then CurrentNote := 0; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; Lyric.Selected := CurrentNote; + editText := Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text; end; end; SDLK_LEFT: @@ -693,12 +786,13 @@ begin // left if SDL_ModState = 0 then begin - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 0; + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; Dec(CurrentNote); if CurrentNote = -1 then CurrentNote := Lines[0].Line[Lines[0].Current].HighNote; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; Lyric.Selected := CurrentNote; + editText := Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text; end; end; end; @@ -719,15 +813,17 @@ procedure TScreenEditSub.DivideBPM; var C: integer; N: integer; -begin + +begin CurrentSong.BPM[0].BPM := CurrentSong.BPM[0].BPM / 2; + for C := 0 to Lines[0].High do begin Lines[0].Line[C].Start := Lines[0].Line[C].Start div 2; Lines[0].Line[C].End_ := Lines[0].Line[C].End_ div 2; for N := 0 to Lines[0].Line[C].HighNote do begin - Lines[0].Line[C].Note[N].Start := Lines[0].Line[C].Note[N].Start div 2; + Lines[0].Line[C].Note[N].Start := Lines[0].Line[C].Note[N].Start div 2; Lines[0].Line[C].Note[N].Length := Round(Lines[0].Line[C].Note[N].Length / 2); end; // N end; // C @@ -758,9 +854,11 @@ var S: string; begin // temporary -{ for C := 0 to Lines[0].High do + { + for C := 0 to Lines[0].High do for N := 0 to Lines[0].Line[C].HighNut do - Lines[0].Line[C].Note[N].Text := AnsiLowerCase(Lines[0].Line[C].Note[N].Text);} + Lines[0].Line[C].Note[N].Text := UTF8LowerCase(Lines[0].Line[C].Note[N].Text); + } for C := 0 to Lines[0].High do begin @@ -890,7 +988,7 @@ begin begin Inc(HighNote); SetLength(Note, HighNote + 1); - Note[HighNote] := Note[N]; + Note[HighNote] := Lines[0].Line[CStart].Note[N]; End_ := Note[HighNote].Start + Note[HighNote].Length; if Note[HighNote].Tone < BaseNote then @@ -916,7 +1014,7 @@ begin Lines[0].Current := Lines[0].Current + 1; CurrentNote := 0; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; Lyric.AddLine(Lines[0].Current); end; @@ -979,7 +1077,7 @@ begin Inc(Note[CurrentNote+1].Start); Dec(Note[CurrentNote+1].Length); Note[CurrentNote+1].Text := '- '; - Note[CurrentNote+1].Color := 0; + Note[CurrentNote+1].Color := 1; end; end; @@ -1009,7 +1107,7 @@ begin if CurrentNote > Lines[0].Line[C].HighNote then Dec(CurrentNote); - Lines[0].Line[C].Note[CurrentNote].Color := 1; + Lines[0].Line[C].Note[CurrentNote].Color := 2; end //Last Note of current Sentence Deleted - > Delete Sentence else @@ -1029,7 +1127,7 @@ begin else Lines[0].Current := 0; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; + Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; end; end; end; @@ -1085,14 +1183,16 @@ var N: integer; NHigh: integer; begin -{ C := Lines[0].Current; + { + C := Lines[0].Current; for N := Lines[0].Line[C].HighNut downto 1 do begin Lines[0].Line[C].Note[N].Text := Lines[0].Line[C].Note[N-1].Text; end; // for - Lines[0].Line[C].Note[0].Text := '- ';} + Lines[0].Line[C].Note[0].Text := '- '; + } C := Lines[0].Current; NHigh := Lines[0].Line[C].HighNote; @@ -1181,73 +1281,288 @@ begin CopySentence(Src + C, Dst + C); end; +procedure TScreenEditSub.DrawStatics; +var + x, y, w, h: Integer; +begin + //Theme: + //bg + glDisable(GL_BLEND); + + x := 0; + y := 0; + w := 800; + h := 600; + glColor4f(0.3, 0.5, 0.6, 1); + glbegin(gl_quads); + glVertex2f(x, y); + glVertex2f(x, y+h); + glVertex2f(x+w, y+h); + glVertex2f(x+w, y); + glEnd; + + // Line + glColor4f(0.9, 0.9, 0.9, 1); + x := 20; + y := 5; + w := 200; + h := 40; + glbegin(gl_quads); + glVertex2f(x, y); + glVertex2f(x, y+h); + glVertex2f(x+w, y+h); + glVertex2f(x+w, y); + glEnd; + + // Note + x := 260; + y := 5; + w := 200; + h := 40; + glbegin(gl_quads); + glVertex2f(x, y); + glVertex2f(x, y+h); + glVertex2f(x+w, y+h); + glVertex2f(x+w, y); + glEnd; + + // some borders + x := 20; + y := 55; + w := 760; + h := 236; + glColor4f(0.9, 0.9, 0.9, 1); + glbegin(gl_quads); + glVertex2f(x, y); + glVertex2f(x, y+h); + glVertex2f(x+w, y+h); + glVertex2f(x+w, y); + glEnd; + + glColor4f(0, 0, 0, 1); + glLineWidth(2); + glBegin(GL_LINE_LOOP); + glVertex2f(x-1, y-1); + glVertex2f(x+w+1, y-1); + glVertex2f(x+w+1, y+h+1); + glVertex2f(x-1, y+h+1); + glEnd; + + x := 20; + y := 305; + w := 760; + h := 135; + glColor4f(0.9, 0.9, 0.9, 1); + glbegin(gl_quads); + glVertex2f(x, y); + glVertex2f(x, y+h); + glVertex2f(x+w, y+h); + glVertex2f(x+w, y); + glEnd; + + glColor4f(0, 0, 0, 1); + glLineWidth(2); + glBegin(GL_LINE_LOOP); + glVertex2f(x-1, y-1); + glVertex2f(x+w+1, y-1); + glVertex2f(x+w+1, y+h+1); + glVertex2f(x-1, y+h+1); + glEnd; + + x := 20; + y := 500; + w := 760; + h := 40; + glColor4f(0.9, 0.9, 0.9, 1); + glbegin(gl_quads); + glVertex2f(x, y); + glVertex2f(x, y+h); + glVertex2f(x+w, y+h); + glVertex2f(x+w, y); + glEnd; + + glColor4f(0, 0, 0, 1); + glLineWidth(2); + glBegin(GL_LINE_LOOP); + glVertex2f(x-1, y-1); + glVertex2f(x+w+1, y-1); + glVertex2f(x+w+1, y+h+1); + glVertex2f(x-1, y+h+1); + glEnd; + + glLineWidth(1); +end; + +procedure TScreenEditSub.DrawInfoBar(x, y, w, h: integer); +var + start, end_: integer; + ww: integer; + + pos: real; + br: real; + + line, note: integer; + numLines, numNotes: integer; + +begin + numLines := Length(Lines[0].Line); + + if(numLines=0) then + Exit; + + start := Lines[0].Line[0].Start; + end_ := Lines[0].Line[numLines-1].End_; + ww := end_ - start; + + glColor4f(0, 0, 0, 1); + glDisable(GL_BLEND); + glLineWidth(2); + glBegin(GL_LINE_LOOP); + glVertex2f(x-1, y-1); + glVertex2f(x+w+1, y-1); + glVertex2f(x+w+1, y+h+1); + glVertex2f(x-1, y+h+1); + glEnd; + + glColor4f(0.9, 0.9, 0.9, 1); + glbegin(gl_quads); + glVertex2f(x, y); + glVertex2f(x, y+h); + glVertex2f(x+w, y+h); + glVertex2f(x+w, y); + glEnd; + + + for line := 0 to numLines - 1 do + begin + if (line = Lines[0].Current) and not (PlaySentence or PlaySentenceMidi) then + glColor4f(0.4, 0.4, 0, 1) + else + glColor4f(1, 0.6, 0, 1); + + + start := Lines[0].Line[line].Note[0].Start; + end_ := Lines[0].Line[line].Note[Lines[0].Line[line].HighNote].Start+ + Lines[0].Line[line].Note[Lines[0].Line[line].HighNote].Length; + + pos := start/ww*w; + br := (end_-start)/ww*w; + + glbegin(gl_quads); + glVertex2f(x+pos, y); + glVertex2f(x+pos, y+h); + glVertex2f(x+pos+br, y+h); + glVertex2f(x+pos+br, y); + glEnd; + { + numNotes := Length(Lines[0].Line[line].Nuta); + + for note := 0 to numNotes - 1 do + begin + + end; } + end; + + if(PlaySentence or PlaySentenceMidi) then + begin + glColor4f(0, 0, 0, 0.5); + pos := 0; + br := AktBeat/ww*w; + if (br>w) then + br := w; + end else + begin + glColor4f(1, 0, 0, 1); + pos := Lines[0].Line[Lines[0].Current].Note[CurrentNote].Start/ww*w; + br := Lines[0].Line[Lines[0].Current].Note[CurrentNote].Length/ww*w; + if (br<1) then + br := 1; + end; + + glEnable(GL_BLEND); + glbegin(gl_quads); + glVertex2f(x+pos, y); + glVertex2f(x+pos, y+h); + glVertex2f(x+pos+br, y+h); + glVertex2f(x+pos+br, y); + glEnd; + glDisable(GL_BLEND); + + glLineWidth(1); +end; + constructor TScreenEditSub.Create; begin inherited Create; SetLength(Player, 1); // line - AddStatic(20, 10, 80, 30, 0, 0, 0, Skin.GetTextureFileName('ButtonF'), TEXTURE_TYPE_COLORIZED); - AddText(40, 17, 1, 18, 1, 1, 1, 'Line'); - TextSentence := AddText(120, 14, 1, 24, 0, 0, 0, '0 / 0'); + AddText(40, 11, 1, 30, 0, 0, 0, 'Line:'); + TextSentence := AddText(110, 11, 1, 30, 0, 0, 0, '0 / 0'); + // Note - AddStatic(220, 10, 80, 30, 0, 0, 0, Skin.GetTextureFileName('ButtonF'), TEXTURE_TYPE_COLORIZED); - AddText(242, 17, 1, 18, 1, 1, 1, 'Note'); - TextNote := AddText(320, 14, 1, 24, 0, 0, 0, '0 / 0'); + AddText(282, 11, 1, 30, 0, 0, 0, 'Note:'); + TextNote := AddText(360, 11, 1, 30, 0, 0, 0, '0 / 0'); // file info - AddStatic(150, 50, 500, 150, 0, 0, 0, Skin.GetTextureFileName('MainBar'), TEXTURE_TYPE_COLORIZED); - AddStatic(151, 52, 498, 146, 1, 1, 1, Skin.GetTextureFileName('MainBar'), TEXTURE_TYPE_COLORIZED); - AddText(180, 65, 0, 24, 0, 0, 0, 'Title:'); - AddText(180, 90, 0, 24, 0, 0, 0, 'Artist:'); - AddText(180, 115, 0, 24, 0, 0, 0, 'Mp3:'); - AddText(180, 140, 0, 24, 0, 0, 0, 'BPM:'); - AddText(180, 165, 0, 24, 0, 0, 0, 'GAP:'); - - TextTitle := AddText(250, 65, 0, 24, 0, 0, 0, 'a'); - TextArtist := AddText(250, 90, 0, 24, 0, 0, 0, 'b'); - TextMp3 := AddText(250, 115, 0, 24, 0, 0, 0, 'c'); - TextBPM := AddText(250, 140, 0, 24, 0, 0, 0, 'd'); - TextGAP := AddText(250, 165, 0, 24, 0, 0, 0, 'e'); - -{ AddInteraction(2, TextTitle); - AddInteraction(2, TextArtist); - AddInteraction(2, TextMp3); - AddInteraction(2, TextBPM); - AddInteraction(2, TextGAP);} + AddText(30, 65, 0, 24, 0, 0, 0, 'Title:'); + AddText(30, 90, 0, 24, 0, 0, 0, 'Artist:'); + AddText(30, 115, 0, 24, 0, 0, 0, 'Mp3:'); + AddText(30, 140, 0, 24, 0, 0, 0, 'BPM:'); + AddText(30, 165, 0, 24, 0, 0, 0, 'GAP:'); + + TextTitle := AddText(180, 65, 0, 24, 0, 0, 0, 'a'); + TextArtist := AddText(180, 90, 0, 24, 0, 0, 0, 'b'); + TextMp3 := AddText(180, 115, 0, 24, 0, 0, 0, 'c'); + TextBPM := AddText(180, 140, 0, 24, 0, 0, 0, 'd'); + TextGAP := AddText(180, 165, 0, 24, 0, 0, 0, 'e'); // note info - AddText(20, 190, 0, 24, 0, 0, 0, 'Start:'); - AddText(20, 215, 0, 24, 0, 0, 0, 'Duration:'); - AddText(20, 240, 0, 24, 0, 0, 0, 'Tone:'); - AddText(20, 265, 0, 24, 0, 0, 0, 'Text:'); + AddText(30, 190, 0, 24, 0, 0, 0, 'Start:'); + AddText(30, 215, 0, 24, 0, 0, 0, 'Duration:'); + AddText(30, 240, 0, 24, 0, 0, 0, 'Tone:'); + AddText(30, 265, 0, 24, 0, 0, 0, 'Text:'); //AddText(500, 265, 0, 8, 0, 0, 0, 'VideoGap:'); + + TextNStart := AddText(180, 190, 0, 24, 0, 0, 0, 'a'); + TextNLength := AddText(180, 215, 0, 24, 0, 0, 0, 'b'); + TextNTon := AddText(180, 240, 0, 24, 0, 0, 0, 'c'); + TextNText := AddText(180, 265, 0, 24, 0, 0, 0, 'd'); - TextNStart := AddText(120, 190, 0, 24, 0, 0, 0, 'a'); - TextNLength := AddText(120, 215, 0, 24, 0, 0, 0, 'b'); - TextNTon := AddText(120, 240, 0, 24, 0, 0, 0, 'c'); - TextNText := AddText(120, 265, 0, 24, 0, 0, 0, 'd'); + //TextVideoGap := AddText(600, 265, 0, 24, 0, 0, 0, 'e'); // debug - TextDebug := AddText(30, 550, 0, 8, 0, 0, 0, ''); + TextDebug := AddText(30, 550, 0, 27, 0, 0, 0, ''); end; -procedure TScreenEditSub.onShow; +procedure TScreenEditSub.OnShow; +var + FileExt: IPath; begin inherited; - Log.LogStatus('Initializing', 'TEditScreen.onShow'); + AudioPlayback.Stop; + PlaySentence := false; + PlaySentenceMidi := false; + + Log.LogStatus('Initializing', 'TEditScreen.OnShow'); Lyric := TEditorLyrics.Create; ResetSingTemp; try - //Check if File is XML - if copy(CurrentSong.FileName,length(CurrentSong.FileName)-3,4) = '.xml' then - Error := not CurrentSong.LoadXMLSong() - else - Error := not CurrentSong.LoadSong(); + //Check if File is XML + FileExt := CurrentSong.FileName.GetExtension; + if FileExt.ToUTF8 = '.xml' then + Error := not CurrentSong.LoadXMLSong() + else + begin + // reread header with custom tags + Error := not CurrentSong.Analyse(true); + if not Error then + Error := not CurrentSong.LoadSong; + end; except Error := true; end; @@ -1263,18 +1578,16 @@ begin begin {$IFDEF UseMIDIPort} MidiOut := TMidiOutput.Create(nil); - if Ini.Debug = 1 then - MidiOut.ProductName := 'Microsoft GS Wavetable SW Synth'; // for my kxproject without midi table MidiOut.Open; {$ENDIF} Text[TextTitle].Text := CurrentSong.Title; Text[TextArtist].Text := CurrentSong.Artist; - Text[TextMp3].Text := CurrentSong.Mp3; + Text[TextMp3].Text := CurrentSong.Mp3.ToUTF8; Lines[0].Current := 0; CurrentNote := 0; - Lines[0].Line[0].Note[0].Color := 1; - AudioPlayback.Open(CurrentSong.Path + CurrentSong.Mp3); + Lines[0].Line[0].Note[0].Color := 2; + AudioPlayback.Open(CurrentSong.Path.Append(CurrentSong.Mp3)); //Set Down Music Volume for Better hearability of Midi Sounds //Music.SetVolume(0.4); @@ -1304,8 +1617,8 @@ end; function TScreenEditSub.Draw: boolean; var Pet: integer; - AktBeat: integer; begin + glClearColor(1,1,1,1); // midi music @@ -1395,15 +1708,17 @@ begin Text[TextNText].Text := Text[TextNText].Text + '|'; // draw static menu - inherited Draw; - + DrawStatics; + DrawInfoBar(20, 460, 760, 20); + //inherited Draw; + DrawFG; // draw notes - SingDrawNoteLines(20, 300, 780, 15); + SingDrawNoteLines(20, 305, 780, 15); //Error Drawing when no Song is loaded if not Error then begin - SingDrawBeatDelimeters(40, 300, 760, 0); - EditDrawLine(40, 405, 760, 0, 15); + SingDrawBeatDelimeters(40, 305, 760, 0); + EditDrawLine(40, 410, 760, 0, 15); end; // draw text @@ -1412,7 +1727,7 @@ begin Result := true; end; -procedure TScreenEditSub.onHide; +procedure TScreenEditSub.OnHide; begin {$IFDEF UseMIDIPort} MidiOut.Close; @@ -1463,4 +1778,4 @@ begin end; end; -end. +end.
\ No newline at end of file diff --git a/cmake/src/screens/UScreenLevel.pas b/cmake/src/screens/UScreenLevel.pas index b41a8535..1ead9773 100644 --- a/cmake/src/screens/UScreenLevel.pas +++ b/cmake/src/screens/UScreenLevel.pas @@ -46,8 +46,8 @@ type TScreenLevel = class(TMenu) public constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; procedure SetAnimationProgress(Progress: real); override; end; @@ -58,29 +58,34 @@ uses UMain, UIni, USong, - UTexture; + UTexture, + UUnicodeUtils; -function TScreenLevel.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenLevel.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; end; end; - + // check special keys case PressedKey of SDLK_ESCAPE, SDLK_BACKSPACE : begin AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenName); + + if Ini.OnSongClick = sSelectPlayer then + FadeTo(@ScreenMain) + else + FadeTo(@ScreenName); end; SDLK_RETURN: @@ -105,8 +110,6 @@ begin end; constructor TScreenLevel.Create; -//var -// I: integer; // Auto Removed, Unused Variable begin inherited Create; @@ -119,7 +122,7 @@ begin Interaction := 0; end; -procedure TScreenLevel.onShow; +procedure TScreenLevel.OnShow; begin inherited; diff --git a/cmake/src/screens/UScreenLoading.pas b/cmake/src/screens/UScreenLoading.pas index ea639ba3..e368f181 100644 --- a/cmake/src/screens/UScreenLoading.pas +++ b/cmake/src/screens/UScreenLoading.pas @@ -43,10 +43,11 @@ uses type TScreenLoading = class(TMenu) public - Fadeout: boolean; + Fadeout: boolean; + constructor Create; override; - procedure onShow; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; + procedure OnShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; end; implementation @@ -55,7 +56,7 @@ uses UGraphic, UTime; -function TScreenLoading.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenLoading.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; end; @@ -69,7 +70,7 @@ begin Fadeout := false; end; -procedure TScreenLoading.onShow; +procedure TScreenLoading.OnShow; begin inherited; end; diff --git a/cmake/src/screens/UScreenMain.pas b/cmake/src/screens/UScreenMain.pas index a4e6009f..8bb9365b 100644 --- a/cmake/src/screens/UScreenMain.pas +++ b/cmake/src/screens/UScreenMain.pas @@ -49,9 +49,9 @@ type TextDescriptionLong: integer; constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: widechar; + function ParseInput(PressedKey: Cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure onShow; override; + procedure OnShow; override; procedure SetInteraction(Num: integer); override; procedure SetAnimationProgress(Progress: real); override; end; @@ -67,11 +67,11 @@ uses Textgl, ULanguage, UParty, - UDLLManager, UScreenCredits, - USkins; + USkins, + UUnicodeUtils; -function TScreenMain.ParseInput(PressedKey: cardinal; CharCode: widechar; +function TScreenMain.ParseInput(PressedKey: Cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; var SDL_ModState: word; @@ -84,37 +84,32 @@ begin if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': - begin + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; end; - 'C': - begin + Ord('C'): begin if (SDL_ModState = KMOD_LALT) then begin FadeTo(@ScreenCredits, SoundLib.Start); Exit; end; end; - 'M': - begin - if (Ini.Players >= 1) and (Length(DLLMan.Plugins) >= 1) then + Ord('M'): begin + if (Ini.Players >= 1) and (Party.ModesAvailable) then begin FadeTo(@ScreenPartyOptions, SoundLib.Start); Exit; end; end; - 'S': - begin + Ord('S'): begin FadeTo(@ScreenStatMain, SoundLib.Start); Exit; end; - 'E': - begin + Ord('E'): begin FadeTo(@ScreenEdit, SoundLib.Start); Exit; end; @@ -140,8 +135,13 @@ begin if (Ini.Players = 4) then PlayersPlay := 6; - ScreenName.Goto_SingScreen := false; - FadeTo(@ScreenName, SoundLib.Start); + if Ini.OnSongClick = sSelectPlayer then + FadeTo(@ScreenLevel) + else + begin + ScreenName.Goto_SingScreen := false; + FadeTo(@ScreenName, SoundLib.Start); + end; end else //show error message ScreenPopupError.ShowPopup(Language.Translate('ERROR_NO_SONGS')); @@ -152,12 +152,7 @@ begin begin if (Songs.SongList.Count >= 1) then begin - if (Length(DLLMan.Plugins) >= 1) then - begin - FadeTo(@ScreenPartyOptions, SoundLib.Start); - end - else //show error message, No Plugins Loaded - ScreenPopupError.ShowPopup(Language.Translate('ERROR_NO_PLUGINS')); + FadeTo(@ScreenPartyOptions, SoundLib.Start); end else //show error message, No Songs Loaded ScreenPopupError.ShowPopup(Language.Translate('ERROR_NO_SONGS')); @@ -172,7 +167,11 @@ begin //Editor if Interaction = 3 then begin + {$IFDEF UseMIDIPort} FadeTo(@ScreenEdit, SoundLib.Start); + {$ELSE} + ScreenPopupError.ShowPopup(Language.Translate('ERROR_NO_EDITOR')); + {$ENDIF} end; //Options @@ -232,17 +231,14 @@ begin Interaction := 0; end; -procedure TScreenMain.onShow; +procedure TScreenMain.OnShow; begin inherited; - - { display cursor (on moved) } - Display.SetCursor; - -{** - * Start background music - *} - SoundLib.StartBgMusic; + {** + * Clean up TPartyGame here + * at the moment there is no better place for this + *} + Party.Clear; end; procedure TScreenMain.SetInteraction(Num: integer); @@ -254,8 +250,8 @@ end; procedure TScreenMain.SetAnimationProgress(Progress: real); begin - Static[0].Texture.ScaleW := Progress; - Static[0].Texture.ScaleH := Progress; + Statics[0].Texture.ScaleW := Progress; + Statics[0].Texture.ScaleH := Progress; end; end. diff --git a/cmake/src/screens/UScreenName.pas b/cmake/src/screens/UScreenName.pas index d13db170..42af50d7 100644 --- a/cmake/src/screens/UScreenName.pas +++ b/cmake/src/screens/UScreenName.pas @@ -47,8 +47,8 @@ type public Goto_SingScreen: boolean; //If true then next Screen in SingScreen constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; procedure SetAnimationProgress(Progress: real); override; end; @@ -59,9 +59,11 @@ uses UGraphic, UIni, UNote, - UTexture; + UTexture, + UUnicodeUtils; -function TScreenName.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; + +function TScreenName.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; var I: integer; SDL_ModState: word; @@ -74,10 +76,10 @@ begin + KMOD_LCTRL + KMOD_RCTRL + KMOD_LALT + KMOD_RALT); // check normal keys - if (IsAlphaNumericChar(CharCode) or - {(CharCode in [' ','-','_','!',',','<','/','*','?','''','"']))} IsPunctuationChar(CharCode)) then + if (IsPrintableChar(CharCode)) then begin - Button[Interaction].Text[0].Text := Button[Interaction].Text[0].Text + CharCode; + Button[Interaction].Text[0].Text := Button[Interaction].Text[0].Text + + UCS4ToUTF8String(CharCode); Exit; end; @@ -195,7 +197,7 @@ begin SDLK_BACKSPACE: begin - Button[Interaction].Text[0].DeleteLastL; + Button[Interaction].Text[0].DeleteLastLetter(); end; SDLK_ESCAPE : @@ -248,7 +250,7 @@ begin Interaction := 0; end; -procedure TScreenName.onShow; +procedure TScreenName.OnShow; var I: integer; begin diff --git a/cmake/src/screens/UScreenOpen.pas b/cmake/src/screens/UScreenOpen.pas index a854e81b..70b883c4 100644 --- a/cmake/src/screens/UScreenOpen.pas +++ b/cmake/src/screens/UScreenOpen.pas @@ -34,10 +34,13 @@ interface {$I switches.inc} uses + Math, + SysUtils, + gl, + SDL, + UPath, UMenu, UMusic, - SDL, - SysUtils, UFiles, UTime, USongs, @@ -46,26 +49,31 @@ uses UTexture, UMenuText, ULyrics, - Math, - gl, UThemes; type TScreenOpen = class(TMenu) private - TextF: array[0..1] of integer; - TextN: integer; - public - Tex_Background: TTexture; - FadeOut: boolean; - Path: string; - BackScreen: pointer; + //fTextF: array[0..1] of integer; + fTextN: integer; // text-box ID of filename + fFilename: IPath; + fBackScreen: PMenu; + procedure AddBox(X, Y, W, H: real); + public constructor Create; override; - procedure onShow; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; -// function Draw: boolean; override; -// procedure Finish; + procedure OnShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + + {** + * Set by the caller to provide a default filename. + * Set to the selected filename after calling this screen or to PATH_NONE + * if the screen was aborted. + * TODO: maybe pass this value with a callback OnValueChanged() + *} + property Filename: IPath READ fFilename WRITE fFilename; + {** The screen that is shown after this screen is closed (set by the caller) *} + property BackScreen: PMenu READ fBackScreen WRITE fBackScreen; end; implementation @@ -75,45 +83,41 @@ uses UDraw, UMain, UScreenEditConvert, - USkins; + USkins, + UUnicodeUtils; -function TScreenOpen.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenOpen.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then // Key Down begin // check normal keys - case CharCode of - '0'..'9', 'a'..'z', 'A'..'Z', ' ', '-', '.', ':', '\': - begin - if Interaction = 0 then - begin - Text[TextN].Text := Text[TextN].Text + CharCode; - end; - end; + if (IsPrintableChar(CharCode)) then + begin + if (Interaction = 0) then + begin + Text[fTextN].Text := Text[fTextN].Text + UCS4ToUTF8String(CharCode); + Exit; + end; end; // check special keys case PressedKey of - SDLK_Q: - begin - Result := false; - end; - 8: // del + SDLK_BACKSPACE: // del begin if Interaction = 0 then begin - Text[TextN].DeleteLastL; + Text[fTextN].DeleteLastLetter; end; end; SDLK_ESCAPE: begin //Empty Filename and go to last Screen - ConversionFileName := ''; + fFileName := PATH_NONE; AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(BackScreen); + FadeTo(fBackScreen); end; SDLK_RETURN: @@ -121,16 +125,16 @@ begin if (Interaction = 2) then begin //Update Filename and go to last Screen - ConversionFileName := Text[TextN].Text; + fFileName := Path(Text[fTextN].Text); AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(BackScreen); + FadeTo(fBackScreen); end else if (Interaction = 1) then begin //Empty Filename and go to last Screen - ConversionFileName := ''; + fFileName := PATH_NONE; AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(BackScreen); + FadeTo(fBackScreen); end; end; @@ -165,21 +169,25 @@ constructor TScreenOpen.Create; begin inherited Create; + fFilename := PATH_NONE; + // line -{ AddStatic(20, 10, 80, 30, 0, 0, 0, 'MainBar', 'JPG', TEXTURE_TYPE_COLORIZED); + { + AddStatic(20, 10, 80, 30, 0, 0, 0, 'MainBar', 'JPG', TEXTURE_TYPE_COLORIZED); AddText(35, 17, 1, 18, 1, 1, 1, 'line'); - TextSentence := AddText(120, 14, 1, 24, 0, 0, 0, '0 / 0');} + TextSentence := AddText(120, 14, 1, 24, 0, 0, 0, '0 / 0'); + } // file list -// AddBox(400, 100, 350, 450); + //AddBox(400, 100, 350, 450); -// TextF[0] := AddText(430, 155, 0, 24, 0, 0, 0, 'a'); -// TextF[1] := AddText(430, 180, 0, 24, 0, 0, 0, 'a'); + //TextF[0] := AddText(430, 155, 0, 24, 0, 0, 0, 'a'); + //TextF[1] := AddText(430, 180, 0, 24, 0, 0, 0, 'a'); // file name AddBox(20, 540, 500, 40); - TextN := AddText(50, 548, 0, 24, 0, 0, 0, ConversionFileName); - AddInteraction(iText, TextN); + fTextN := AddText(50, 548, 0, 24, 0, 0, 0, fFileName.ToUTF8); + AddInteraction(iText, fTextN); // buttons {AddButton(540, 540, 100, 40, Skin.SkinPath + Skin.ButtonF); @@ -196,11 +204,12 @@ begin end; -procedure TScreenOpen.onShow; +procedure TScreenOpen.OnShow; begin inherited; Interaction := 0; + Text[fTextN].Text := fFilename.ToUTF8(); end; (* diff --git a/cmake/src/screens/UScreenOptions.pas b/cmake/src/screens/UScreenOptions.pas index a6486075..bdb37701 100644 --- a/cmake/src/screens/UScreenOptions.pas +++ b/cmake/src/screens/UScreenOptions.pas @@ -34,9 +34,9 @@ interface {$I switches.inc} uses - UMenu, SDL, SysUtils, + UMenu, UDisplay, UMusic, UFiles, @@ -48,8 +48,8 @@ type public TextDescription: integer; constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; procedure InteractNext; override; procedure InteractPrev; override; procedure InteractNextRow; override; @@ -60,16 +60,17 @@ type implementation uses - UGraphic; + UGraphic, + UUnicodeUtils; -function TScreenOptions.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenOptions.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -145,8 +146,6 @@ begin end; constructor TScreenOptions.Create; -//var -// I: integer; // Auto Removed, Unused Variable begin inherited Create; @@ -189,7 +188,7 @@ begin Interaction := 0; end; -procedure TScreenOptions.onShow; +procedure TScreenOptions.OnShow; begin inherited; end; diff --git a/cmake/src/screens/UScreenOptionsAdvanced.pas b/cmake/src/screens/UScreenOptionsAdvanced.pas index 0fb8153c..dd727dd8 100644 --- a/cmake/src/screens/UScreenOptionsAdvanced.pas +++ b/cmake/src/screens/UScreenOptionsAdvanced.pas @@ -34,8 +34,8 @@ interface {$I switches.inc} uses - UMenu, SDL, + UMenu, UDisplay, UMusic, UFiles, @@ -46,24 +46,25 @@ type TScreenOptionsAdvanced = class(TMenu) public constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; end; implementation uses UGraphic, + UUnicodeUtils, SysUtils; -function TScreenOptionsAdvanced.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenOptionsAdvanced.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -75,8 +76,7 @@ begin SDLK_ESCAPE, SDLK_BACKSPACE : begin - // Escape -> save nothing - just leave this screen - + Ini.Save; AudioPlayback.PlaySound(SoundLib.Back); FadeTo(@ScreenOptions); end; @@ -120,8 +120,6 @@ begin end; constructor TScreenOptionsAdvanced.Create; -//var -// I: integer; // Auto Removed, Unused Variable begin inherited Create; @@ -155,12 +153,12 @@ begin AddButton(Theme.OptionsAdvanced.ButtonExit); if (Length(Button[0].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[7]); + AddButtonText(20, 5, Theme.Options.Description[7]); Interaction := 0; end; -procedure TScreenOptionsAdvanced.onShow; +procedure TScreenOptionsAdvanced.OnShow; begin inherited; diff --git a/cmake/src/screens/UScreenOptionsGame.pas b/cmake/src/screens/UScreenOptionsGame.pas index 1d741d25..39de61e4 100644 --- a/cmake/src/screens/UScreenOptionsGame.pas +++ b/cmake/src/screens/UScreenOptionsGame.pas @@ -35,40 +35,39 @@ interface uses SDL, + UMenu, UDisplay, + UMusic, UFiles, UIni, - UMenu, - UMusic, - USongs, - UThemes; + UThemes, + USongs; type TScreenOptionsGame = class(TMenu) public old_Tabs, old_Sorting: integer; constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; procedure RefreshSongs; end; implementation uses - SysUtils, - UGraphic; + UGraphic, + UUnicodeUtils, + SysUtils; -function TScreenOptionsGame.ParseInput(PressedKey: cardinal; - CharCode: WideChar; - PressedDown: boolean): boolean; +function TScreenOptionsGame.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if PressedDown then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -137,7 +136,7 @@ begin Theme.OptionsGame.SelectLanguage.showArrows := true; Theme.OptionsGame.SelectLanguage.oneItemOnly := true; - AddSelectSlide(Theme.OptionsGame.SelectLanguage, Ini.Language, ILanguage); + AddSelectSlide(Theme.OptionsGame.SelectLanguage, Ini.Language, ILanguageTranslated); Theme.OptionsGame.SelectTabs.showArrows := true; Theme.OptionsGame.SelectTabs.oneItemOnly := true; @@ -155,7 +154,7 @@ begin AddButton(Theme.OptionsGame.ButtonExit); if (Length(Button[0].Text) = 0) then - AddButtonText(14, 20, Theme.Options.Description[7]); + AddButtonText(20, 5, Theme.Options.Description[7]); end; @@ -166,7 +165,7 @@ begin ScreenSong.Refresh; end; -procedure TScreenOptionsGame.onShow; +procedure TScreenOptionsGame.OnShow; begin inherited; diff --git a/cmake/src/screens/UScreenOptionsGraphics.pas b/cmake/src/screens/UScreenOptionsGraphics.pas index ba1465b2..e2aacccd 100644 --- a/cmake/src/screens/UScreenOptionsGraphics.pas +++ b/cmake/src/screens/UScreenOptionsGraphics.pas @@ -46,26 +46,25 @@ type TScreenOptionsGraphics = class(TMenu) public constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; end; implementation uses UGraphic, - UMain, - SysUtils, - TypInfo; + UUnicodeUtils, + SysUtils; -function TScreenOptionsGraphics.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenOptionsGraphics.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -77,17 +76,12 @@ begin SDLK_ESCAPE, SDLK_BACKSPACE : begin - // Escape -> save nothing - just leave this screen - + Ini.Save; AudioPlayback.PlaySound(SoundLib.Back); FadeTo(@ScreenOptions); end; SDLK_RETURN: begin -{ if SelInteraction <= 1 then - begin - Restart := true; - end;} if SelInteraction = 6 then begin Ini.Save; @@ -126,8 +120,6 @@ begin end; constructor TScreenOptionsGraphics.Create; -//var -// I: integer; // Auto Removed, Unused Variable begin inherited Create; LoadFromTheme(Theme.OptionsGraphics); @@ -158,11 +150,11 @@ begin AddButton(Theme.OptionsGraphics.ButtonExit); if (Length(Button[0].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[7]); + AddButtonText(20, 5, Theme.Options.Description[7]); end; -procedure TScreenOptionsGraphics.onShow; +procedure TScreenOptionsGraphics.OnShow; begin inherited; diff --git a/cmake/src/screens/UScreenOptionsLyrics.pas b/cmake/src/screens/UScreenOptionsLyrics.pas index 035b0089..468082de 100644 --- a/cmake/src/screens/UScreenOptionsLyrics.pas +++ b/cmake/src/screens/UScreenOptionsLyrics.pas @@ -46,24 +46,25 @@ type TScreenOptionsLyrics = class(TMenu) public constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; end; implementation uses UGraphic, + UUnicodeUtils, SysUtils; -function TScreenOptionsLyrics.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenOptionsLyrics.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -75,8 +76,7 @@ begin SDLK_ESCAPE, SDLK_BACKSPACE : begin - // Escape -> save nothing - just leave this screen - + Ini.Save; AudioPlayback.PlaySound(SoundLib.Back); FadeTo(@ScreenOptions); end; @@ -133,11 +133,11 @@ begin AddButton(Theme.OptionsLyrics.ButtonExit); if (Length(Button[0].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[7]); + AddButtonText(20, 5, Theme.Options.Description[7]); end; -procedure TScreenOptionsLyrics.onShow; +procedure TScreenOptionsLyrics.OnShow; begin inherited; diff --git a/cmake/src/screens/UScreenOptionsRecord.pas b/cmake/src/screens/UScreenOptionsRecord.pas index cf799204..0f9cd49a 100644 --- a/cmake/src/screens/UScreenOptionsRecord.pas +++ b/cmake/src/screens/UScreenOptionsRecord.pas @@ -61,8 +61,8 @@ type PreviewDeviceIndex: integer; // string arrays for select-slide options - InputSourceNames: array of string; - InputDeviceNames: array of string; + InputSourceNames: array of UTF8String; + InputDeviceNames: array of UTF8String; // dynamic generated themes for channel select-sliders SelectSlideChannelTheme: array of TThemeSelectSlide; @@ -95,9 +95,9 @@ type public constructor Create; override; function Draw: boolean; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; - procedure onHide; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; + procedure OnHide; override; end; const @@ -126,33 +126,34 @@ uses UFiles, UDisplay, UIni, + UUnicodeUtils, ULog; -function TScreenOptionsRecord.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenOptionsRecord.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; end; - '+': + Ord('+'): begin // FIXME: add a nice volume-slider instead // or at least provide visualization and acceleration if the user holds the key pressed. ChangeVolume(0.02); end; - '-': + Ord('-'): begin // FIXME: add a nice volume-slider instead // or at least provide visualization and acceleration if the user holds the key pressed. ChangeVolume(-0.02); end; - 'T': + Ord('T'): begin if ((SDL_GetModState() and KMOD_SHIFT) <> 0) then Ini.ThresholdIndex := (Ini.ThresholdIndex + Length(IThresholdVals) - 1) mod Length(IThresholdVals) @@ -167,17 +168,23 @@ begin SDLK_BACKSPACE: begin // TODO: Show Save/Abort screen - Ini.Save; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenOptions); + if (AudioInputProcessor.ValidateSettings()) then + begin + Ini.Save; + AudioPlayback.PlaySound(SoundLib.Back); + FadeTo(@ScreenOptions); + end; end; SDLK_RETURN: begin if (SelInteraction = ExitButtonIID) then begin - Ini.Save; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenOptions); + if (AudioInputProcessor.ValidateSettings()) then + begin + Ini.Save; + AudioPlayback.PlaySound(SoundLib.Back); + FadeTo(@ScreenOptions); + end; end; end; SDLK_DOWN: @@ -299,7 +306,7 @@ begin // add slider SelectSlideChannelID[ChannelIndex] := AddSelectSlide(ChannelTheme^, - InputDeviceCfg.ChannelToPlayerMap[ChannelIndex], IChannelPlayer); + InputDeviceCfg.ChannelToPlayerMap[ChannelIndex], IChannelPlayerTranslated); end else begin @@ -307,7 +314,7 @@ begin // add slider but hide it and assign a dummy variable to it SelectSlideChannelID[ChannelIndex] := AddSelectSlide(ChannelTheme^, - ChannelToPlayerMapDummy, IChannelPlayer); + ChannelToPlayerMapDummy, IChannelPlayerTranslated); SelectsS[SelectSlideChannelID[ChannelIndex]].Visible := false; end; end; @@ -322,7 +329,7 @@ begin // <mog> I uncommented the stuff above, because it's not skinable :X AddButton(Theme.OptionsRecord.ButtonExit); if (Length(Button[0].Text) = 0) then - AddButtonText(14, 20, Theme.Options.Description[7]); + AddButtonText(20, 5, Theme.Options.Description[7]); // store InteractionID if (Length(AudioInputProcessor.DeviceList) > 0) then ExitButtonIID := MaxChannelCount + 2 @@ -373,7 +380,7 @@ begin // show slider UpdateSelectSlideOptions(SelectSlideChannelTheme[ChannelIndex], - SelectSlideChannelID[ChannelIndex], IChannelPlayer, + SelectSlideChannelID[ChannelIndex], IChannelPlayerTranslated, InputDeviceCfg.ChannelToPlayerMap[ChannelIndex]); SelectsS[SelectSlideChannelID[ChannelIndex]].Visible := true; end @@ -383,7 +390,7 @@ begin // hide slider and assign a dummy variable to it UpdateSelectSlideOptions(SelectSlideChannelTheme[ChannelIndex], - SelectSlideChannelID[ChannelIndex], IChannelPlayer, + SelectSlideChannelID[ChannelIndex], IChannelPlayerTranslated, ChannelToPlayerMapDummy); SelectsS[SelectSlideChannelID[ChannelIndex]].Visible := false; end; @@ -418,7 +425,7 @@ begin NextVolumePollTime := 0; end; -procedure TScreenOptionsRecord.onShow; +procedure TScreenOptionsRecord.OnShow; var ChannelIndex: integer; begin @@ -433,10 +440,10 @@ begin SetLength(ChannelPeak, MaxChannelCount); - StartPreview(); + UpdateInputDevice(); end; -procedure TScreenOptionsRecord.onHide; +procedure TScreenOptionsRecord.OnHide; var ChannelIndex: integer; begin diff --git a/cmake/src/screens/UScreenOptionsSound.pas b/cmake/src/screens/UScreenOptionsSound.pas index aa87ceb4..c0efa4d8 100644 --- a/cmake/src/screens/UScreenOptionsSound.pas +++ b/cmake/src/screens/UScreenOptionsSound.pas @@ -34,8 +34,8 @@ interface {$I switches.inc} uses - UMenu, SDL, + UMenu, UDisplay, UMusic, UFiles, @@ -46,26 +46,27 @@ type TScreenOptionsSound = class(TMenu) public constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: widechar; + function ParseInput(PressedKey: Cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure onShow; override; + procedure OnShow; override; end; implementation uses UGraphic, + UUnicodeUtils, SysUtils; function TScreenOptionsSound.ParseInput(PressedKey: cardinal; - CharCode: widechar; PressedDown: boolean): boolean; + CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -77,7 +78,7 @@ begin SDLK_ESCAPE, SDLK_BACKSPACE: begin - // Escape -> save nothing - just leave this screen + Ini.Save; AudioPlayback.PlaySound(SoundLib.Back); FadeTo(@ScreenOptions); end; @@ -172,12 +173,12 @@ begin AddButton(Theme.OptionsSound.ButtonExit); if (Length(Button[0].Text) = 0) then - AddButtonText(14, 20, Theme.Options.Description[7]); + AddButtonText(20, 5, Theme.Options.Description[7]); Interaction := 0; end; -procedure TScreenOptionsSound.onShow; +procedure TScreenOptionsSound.OnShow; begin inherited; Interaction := 0; diff --git a/cmake/src/screens/UScreenOptionsThemes.pas b/cmake/src/screens/UScreenOptionsThemes.pas index 1e7407f1..94475cc7 100644 --- a/cmake/src/screens/UScreenOptionsThemes.pas +++ b/cmake/src/screens/UScreenOptionsThemes.pas @@ -49,8 +49,8 @@ type public SkinSelect: integer; constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; procedure InteractInc; override; procedure InteractDec; override; end; @@ -61,17 +61,18 @@ uses SysUtils, UGraphic, UMain, - UPath, + UPathUtils, + UUnicodeUtils, USkins; -function TScreenOptionsThemes.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenOptionsThemes.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -83,7 +84,12 @@ begin SDLK_ESCAPE, SDLK_BACKSPACE : begin - // Escape -> save nothing - just leave this screen + Ini.Save; + + // Reload all screens, after Theme changed + // Todo : JB - Check if theme was actually changed + UGraphic.UnLoadScreens(); + UGraphic.LoadScreens(); AudioPlayback.PlaySound(SoundLib.Back); FadeTo(@ScreenOptions); @@ -135,7 +141,16 @@ begin if (SelInteraction = 0) then begin Skin.OnThemeChange; - UpdateSelectSlideOptions (Theme.OptionsThemes.SelectSkin, SkinSelect, ISkin, Ini.SkinNo); + UpdateSelectSlideOptions(Theme.OptionsThemes.SelectSkin, SkinSelect, ISkin, Ini.SkinNo); + + // set skin to themes default skin + Ini.SkinNo := Theme.Themes[Ini.Theme].DefaultSkin; + end; + + { set skins default color } + if (SelInteraction = 0) or (SelInteraction = 1) then + begin + Ini.Color := Skin.GetDefaultColor(Ini.SkinNo); end; ReloadTheme(); @@ -150,6 +165,15 @@ begin begin Skin.OnThemeChange; UpdateSelectSlideOptions (Theme.OptionsThemes.SelectSkin, SkinSelect, ISkin, Ini.SkinNo); + + // set skin to themes default skin + Ini.SkinNo := Theme.Themes[Ini.Theme].DefaultSkin; + end; + + { set skins default color } + if (SelInteraction = 0) or (SelInteraction = 1) then + begin + Ini.Color := Skin.GetDefaultColor(Ini.SkinNo); end; ReloadTheme(); @@ -175,10 +199,10 @@ begin AddButton(Theme.OptionsThemes.ButtonExit); if (Length(Button[0].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[7]); + AddButtonText(20, 5, Theme.Options.Description[7]); end; -procedure TScreenOptionsThemes.onShow; +procedure TScreenOptionsThemes.OnShow; begin inherited; @@ -187,7 +211,7 @@ end; procedure TScreenOptionsThemes.ReloadTheme; begin - Theme.LoadTheme(ThemePath + ITheme[Ini.Theme] + '.ini', Ini.Color); + Theme.LoadTheme(Ini.Theme, Ini.Color); ScreenOptionsThemes := TScreenOptionsThemes.create(); ScreenOptionsThemes.onshow; diff --git a/cmake/src/screens/UScreenPartyNewRound.pas b/cmake/src/screens/UScreenPartyNewRound.pas index 03a72fa9..8024108c 100644 --- a/cmake/src/screens/UScreenPartyNewRound.pas +++ b/cmake/src/screens/UScreenPartyNewRound.pas @@ -34,33 +34,21 @@ interface {$I switches.inc} uses - UMenu, SDL, + SysUtils, + UMenu, UDisplay, UMusic, UFiles, - SysUtils, UThemes; type TScreenPartyNewRound = class(TMenu) public //Texts: - TextRound1: cardinal; - TextRound2: cardinal; - TextRound3: cardinal; - TextRound4: cardinal; - TextRound5: cardinal; - TextRound6: cardinal; - TextRound7: cardinal; - - TextWinner1: cardinal; - TextWinner2: cardinal; - TextWinner3: cardinal; - TextWinner4: cardinal; - TextWinner5: cardinal; - TextWinner6: cardinal; - TextWinner7: cardinal; + TextRound: array [0..6] of cardinal; + + TextWinner: array [0..6] of cardinal; TextNextRound: cardinal; TextNextRoundNo: cardinal; @@ -69,13 +57,7 @@ type TextNextPlayer3: cardinal; //Statics - StaticRound1: cardinal; - StaticRound2: cardinal; - StaticRound3: cardinal; - StaticRound4: cardinal; - StaticRound5: cardinal; - StaticRound6: cardinal; - StaticRound7: cardinal; + StaticRound: array [0..6] of cardinal; //Scores TextScoreTeam1: cardinal; @@ -99,8 +81,8 @@ type constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; procedure SetAnimationProgress(Progress: real); override; end; @@ -112,19 +94,19 @@ uses UIni, UTexture, UParty, - UDLLManager, ULanguage, USong, - ULog; + ULog, + UUnicodeUtils; -function TScreenPartyNewRound.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenPartyNewRound.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -143,16 +125,7 @@ begin SDLK_RETURN: begin AudioPlayback.PlaySound(SoundLib.Start); - if DLLMan.Selected.LoadSong then - begin - //Select PartyMode ScreenSong - ScreenSong.Mode := smPartyMode; - FadeTo(@ScreenSong); - end - else - begin - FadeTo(@ScreenSingModi); - end; + Party.CallBeforeSongSelect; end; end; end; @@ -162,21 +135,21 @@ constructor TScreenPartyNewRound.Create; begin inherited Create; - TextRound1 := AddText (Theme.PartyNewRound.TextRound1); - TextRound2 := AddText (Theme.PartyNewRound.TextRound2); - TextRound3 := AddText (Theme.PartyNewRound.TextRound3); - TextRound4 := AddText (Theme.PartyNewRound.TextRound4); - TextRound5 := AddText (Theme.PartyNewRound.TextRound5); - TextRound6 := AddText (Theme.PartyNewRound.TextRound6); - TextRound7 := AddText (Theme.PartyNewRound.TextRound7); - - TextWinner1 := AddText (Theme.PartyNewRound.TextWinner1); - TextWinner2 := AddText (Theme.PartyNewRound.TextWinner2); - TextWinner3 := AddText (Theme.PartyNewRound.TextWinner3); - TextWinner4 := AddText (Theme.PartyNewRound.TextWinner4); - TextWinner5 := AddText (Theme.PartyNewRound.TextWinner5); - TextWinner6 := AddText (Theme.PartyNewRound.TextWinner6); - TextWinner7 := AddText (Theme.PartyNewRound.TextWinner7); + TextRound[0] := AddText (Theme.PartyNewRound.TextRound1); + TextRound[1] := AddText (Theme.PartyNewRound.TextRound2); + TextRound[2] := AddText (Theme.PartyNewRound.TextRound3); + TextRound[3] := AddText (Theme.PartyNewRound.TextRound4); + TextRound[4] := AddText (Theme.PartyNewRound.TextRound5); + TextRound[5] := AddText (Theme.PartyNewRound.TextRound6); + TextRound[6] := AddText (Theme.PartyNewRound.TextRound7); + + TextWinner[0] := AddText (Theme.PartyNewRound.TextWinner1); + TextWinner[1] := AddText (Theme.PartyNewRound.TextWinner2); + TextWinner[2] := AddText (Theme.PartyNewRound.TextWinner3); + TextWinner[3] := AddText (Theme.PartyNewRound.TextWinner4); + TextWinner[4] := AddText (Theme.PartyNewRound.TextWinner5); + TextWinner[5] := AddText (Theme.PartyNewRound.TextWinner6); + TextWinner[6] := AddText (Theme.PartyNewRound.TextWinner7); TextNextRound := AddText (Theme.PartyNewRound.TextNextRound); TextNextRoundNo := AddText (Theme.PartyNewRound.TextNextRoundNo); @@ -184,13 +157,13 @@ begin TextNextPlayer2 := AddText (Theme.PartyNewRound.TextNextPlayer2); TextNextPlayer3 := AddText (Theme.PartyNewRound.TextNextPlayer3); - StaticRound1 := AddStatic (Theme.PartyNewRound.StaticRound1); - StaticRound2 := AddStatic (Theme.PartyNewRound.StaticRound2); - StaticRound3 := AddStatic (Theme.PartyNewRound.StaticRound3); - StaticRound4 := AddStatic (Theme.PartyNewRound.StaticRound4); - StaticRound5 := AddStatic (Theme.PartyNewRound.StaticRound5); - StaticRound6 := AddStatic (Theme.PartyNewRound.StaticRound6); - StaticRound7 := AddStatic (Theme.PartyNewRound.StaticRound7); + StaticRound[0] := AddStatic (Theme.PartyNewRound.StaticRound1); + StaticRound[1] := AddStatic (Theme.PartyNewRound.StaticRound2); + StaticRound[2] := AddStatic (Theme.PartyNewRound.StaticRound3); + StaticRound[3] := AddStatic (Theme.PartyNewRound.StaticRound4); + StaticRound[4] := AddStatic (Theme.PartyNewRound.StaticRound5); + StaticRound[5] := AddStatic (Theme.PartyNewRound.StaticRound6); + StaticRound[6] := AddStatic (Theme.PartyNewRound.StaticRound7); //Scores TextScoreTeam1 := AddText (Theme.PartyNewRound.TextScoreTeam1); @@ -215,21 +188,21 @@ begin LoadFromTheme(Theme.PartyNewRound); end; -procedure TScreenPartyNewRound.onShow; +procedure TScreenPartyNewRound.OnShow; var I: integer; - function GetTeamPlayers(const Num: byte): string; + function GetTeamPlayers(const Num: integer): UTF8String; var - Players: array of string; - J: byte; + Players: array of UTF8String; + J: integer; begin - if (Num-1 >= PartySession.Teams.NumTeams) then + if (Num > High(Party.Teams)) or (Num < 0) then exit; //Create Players array - SetLength(Players, PartySession.Teams.TeamInfo[Num-1].NumPlayers); - for J := 0 to PartySession.Teams.TeamInfo[Num-1].NumPlayers-1 do - Players[J] := string(PartySession.Teams.TeamInfo[Num-1].PlayerInfo[J].Name); + SetLength(Players, Length(Party.Teams[Num].Players)); + For J := 0 to High(Party.Teams[Num].Players) do + Players[J] := UTF8String(Party.Teams[Num].Players[J].Name); //Implode and Return Result := Language.Implode(Players); @@ -237,215 +210,114 @@ var begin inherited; - PartySession.StartRound; - //Set Visibility of Round Infos - I := Length(PartySession.Rounds); - if (I >= 1) then - begin - Static[StaticRound1].Visible := true; - Text[TextRound1].Visible := true; - Text[TextWinner1].Visible := true; - - //Texts: - Text[TextRound1].Text := Language.Translate(DllMan.Plugins[PartySession.Rounds[0].Plugin].Name); - Text[TextWinner1].Text := PartySession.GetWinnerString(0); - end - else - begin - Static[StaticRound1].Visible := false; - Text[TextRound1].Visible := false; - Text[TextWinner1].Visible := false; - end; - - if (I >= 2) then - begin - Static[StaticRound2].Visible := true; - Text[TextRound2].Visible := true; - Text[TextWinner2].Visible := true; - - //Texts: - Text[TextRound2].Text := Language.Translate(DllMan.Plugins[PartySession.Rounds[1].Plugin].Name); - Text[TextWinner2].Text := PartySession.GetWinnerString(1); - end - else - begin - Static[StaticRound2].Visible := false; - Text[TextRound2].Visible := false; - Text[TextWinner2].Visible := false; - end; - - if (I >= 3) then - begin - Static[StaticRound3].Visible := true; - Text[TextRound3].Visible := true; - Text[TextWinner3].Visible := true; - - //Texts: - Text[TextRound3].Text := Language.Translate(DllMan.Plugins[PartySession.Rounds[2].Plugin].Name); - Text[TextWinner3].Text := PartySession.GetWinnerString(2); - end - else - begin - Static[StaticRound3].Visible := false; - Text[TextRound3].Visible := false; - Text[TextWinner3].Visible := false; - end; - - if (I >= 4) then + for I := 0 to 6 do begin - Static[StaticRound4].Visible := true; - Text[TextRound4].Visible := true; - Text[TextWinner4].Visible := true; - - //Texts: - Text[TextRound4].Text := Language.Translate(DllMan.Plugins[PartySession.Rounds[3].Plugin].Name); - Text[TextWinner4].Text := PartySession.GetWinnerString(3); - end - else - begin - Static[StaticRound4].Visible := false; - Text[TextRound4].Visible := false; - Text[TextWinner4].Visible := false; - end; - - if (I >= 5) then - begin - Static[StaticRound5].Visible := true; - Text[TextRound5].Visible := true; - Text[TextWinner5].Visible := true; - - //Texts: - Text[TextRound5].Text := Language.Translate(DllMan.Plugins[PartySession.Rounds[4].Plugin].Name); - Text[TextWinner5].Text := PartySession.GetWinnerString(4); - end - else - begin - Static[StaticRound5].Visible := false; - Text[TextRound5].Visible := false; - Text[TextWinner5].Visible := false; - end; - - if (I >= 6) then - begin - Static[StaticRound6].Visible := true; - Text[TextRound6].Visible := true; - Text[TextWinner6].Visible := true; - - //Texts: - Text[TextRound6].Text := Language.Translate(DllMan.Plugins[PartySession.Rounds[5].Plugin].Name); - Text[TextWinner6].Text := PartySession.GetWinnerString(5); - end - else - begin - Static[StaticRound6].Visible := false; - Text[TextRound6].Visible := false; - Text[TextWinner6].Visible := false; + if (I <= High(Party.Rounds)) then + begin + Statics[StaticRound[I]].Visible := True; + Text[TextRound[I]].Visible := True; + Text[TextWinner[I]].Visible := True; + + // update texts: + Text[TextRound[I]].Text := Language.Translate('MODE_' + uppercase(Party.Modes[Party.Rounds[I].Mode].Name) + '_NAME'); + Text[TextWinner[I]].Text := Party.GetWinnerString(I); + end + else + begin + Statics[StaticRound[I]].Visible := False; + Text[TextRound[I]].Visible := False; + Text[TextWinner[I]].Visible := False; + end; end; - if (I >= 7) then - begin - Static[StaticRound7].Visible := true; - Text[TextRound7].Visible := true; - Text[TextWinner7].Visible := true; - - //Texts: - Text[TextRound7].Text := Language.Translate(DllMan.Plugins[PartySession.Rounds[6].Plugin].Name); - Text[TextWinner7].Text := PartySession.GetWinnerString(6); - end - else - begin - Static[StaticRound7].Visible := false; - Text[TextRound7].Visible := false; - Text[TextWinner7].Visible := false; - end; //Display Scores - if (PartySession.Teams.NumTeams >= 1) then + if (Length(Party.Teams) >= 1) then begin - Text[TextScoreTeam1].Text := InttoStr(PartySession.Teams.TeamInfo[0].Score); - Text[TextNameTeam1].Text := string(PartySession.Teams.TeamInfo[0].Name); - Text[TextTeam1Players].Text := GetTeamPlayers(1); + Text[TextScoreTeam1].Text := InttoStr(Party.Teams[0].Score); + Text[TextNameTeam1].Text := UTF8String(Party.Teams[0].Name); + Text[TextTeam1Players].Text := GetTeamPlayers(0); Text[TextScoreTeam1].Visible := true; Text[TextNameTeam1].Visible := true; Text[TextTeam1Players].Visible := true; - Static[StaticTeam1].Visible := true; - Static[StaticNextPlayer1].Visible := true; + Statics[StaticTeam1].Visible := true; + Statics[StaticNextPlayer1].Visible := true; end else begin Text[TextScoreTeam1].Visible := false; Text[TextNameTeam1].Visible := false; Text[TextTeam1Players].Visible := false; - Static[StaticTeam1].Visible := false; - Static[StaticNextPlayer1].Visible := false; + Statics[StaticTeam1].Visible := false; + Statics[StaticNextPlayer1].Visible := false; end; - if (PartySession.Teams.NumTeams >= 2) then + if (Length(Party.Teams) >= 2) then begin - Text[TextScoreTeam2].Text := InttoStr(PartySession.Teams.TeamInfo[1].Score); - Text[TextNameTeam2].Text := string(PartySession.Teams.TeamInfo[1].Name); - Text[TextTeam2Players].Text := GetTeamPlayers(2); + Text[TextScoreTeam2].Text := InttoStr(Party.Teams[1].Score); + Text[TextNameTeam2].Text := UTF8String(Party.Teams[1].Name); + Text[TextTeam2Players].Text := GetTeamPlayers(1); Text[TextScoreTeam2].Visible := true; Text[TextNameTeam2].Visible := true; Text[TextTeam2Players].Visible := true; - Static[StaticTeam2].Visible := true; - Static[StaticNextPlayer2].Visible := true; + Statics[StaticTeam2].Visible := true; + Statics[StaticNextPlayer2].Visible := true; end else begin Text[TextScoreTeam2].Visible := false; Text[TextNameTeam2].Visible := false; Text[TextTeam2Players].Visible := false; - Static[StaticTeam2].Visible := false; - Static[StaticNextPlayer2].Visible := false; + Statics[StaticTeam2].Visible := false; + Statics[StaticNextPlayer2].Visible := false; end; - if (PartySession.Teams.NumTeams >= 3) then + if (Length(Party.Teams) >= 3) then begin - Text[TextScoreTeam3].Text := InttoStr(PartySession.Teams.TeamInfo[2].Score); - Text[TextNameTeam3].Text := string(PartySession.Teams.TeamInfo[2].Name); - Text[TextTeam3Players].Text := GetTeamPlayers(3); + Text[TextScoreTeam3].Text := InttoStr(Party.Teams[2].Score); + Text[TextNameTeam3].Text := UTF8String(Party.Teams[2].Name); + Text[TextTeam3Players].Text := GetTeamPlayers(2); Text[TextScoreTeam3].Visible := true; Text[TextNameTeam3].Visible := true; Text[TextTeam3Players].Visible := true; - Static[StaticTeam3].Visible := true; - Static[StaticNextPlayer3].Visible := true; + Statics[StaticTeam3].Visible := true; + Statics[StaticNextPlayer3].Visible := true; end else begin Text[TextScoreTeam3].Visible := false; Text[TextNameTeam3].Visible := false; Text[TextTeam3Players].Visible := false; - Static[StaticTeam3].Visible := false; - Static[StaticNextPlayer3].Visible := false; - end; + Statics[StaticTeam3].Visible := false; + Statics[StaticNextPlayer3].Visible := false; + end; //nextRound Texts - Text[TextNextRound].Text := Language.Translate(DllMan.Selected.PluginDesc); - Text[TextNextRoundNo].Text := InttoStr(PartySession.CurRound + 1); - if (PartySession.Teams.NumTeams >= 1) then + Text[TextNextRound].Text := Language.Translate('MODE_' + uppercase(Party.Modes[Party.Rounds[Party.CurrentRound].Mode].Name) + '_DESC'); + Text[TextNextRoundNo].Text := InttoStr(Party.CurrentRound + 1); + if (Length(Party.Teams) >= 1) then begin - Text[TextNextPlayer1].Text := PartySession.Teams.Teaminfo[0].Playerinfo[PartySession.Teams.Teaminfo[0].CurPlayer].Name; + Text[TextNextPlayer1].Text := Party.Teams[0].Players[Party.Teams[0].NextPlayer].Name; Text[TextNextPlayer1].Visible := true; end else Text[TextNextPlayer1].Visible := false; - - if (PartySession.Teams.NumTeams >= 2) then + + if (Length(Party.Teams) >= 2) then begin - Text[TextNextPlayer2].Text := PartySession.Teams.Teaminfo[1].Playerinfo[PartySession.Teams.Teaminfo[1].CurPlayer].Name; + Text[TextNextPlayer2].Text := Party.Teams[1].Players[Party.Teams[1].NextPlayer].Name; Text[TextNextPlayer2].Visible := true; end else Text[TextNextPlayer2].Visible := false; - if (PartySession.Teams.NumTeams >= 3) then + if (Length(Party.Teams) >= 3) then begin - Text[TextNextPlayer3].Text := PartySession.Teams.Teaminfo[2].Playerinfo[PartySession.Teams.Teaminfo[2].CurPlayer].Name; + Text[TextNextPlayer3].Text := Party.Teams[2].Players[Party.Teams[2].NextPlayer].Name; Text[TextNextPlayer3].Visible := true; end else diff --git a/cmake/src/screens/UScreenPartyOptions.pas b/cmake/src/screens/UScreenPartyOptions.pas index 5f7f1d9e..f63b37fb 100644 --- a/cmake/src/screens/UScreenPartyOptions.pas +++ b/cmake/src/screens/UScreenPartyOptions.pas @@ -44,38 +44,26 @@ uses type TScreenPartyOptions = class(TMenu) - public + private SelectLevel: cardinal; SelectPlayList: cardinal; SelectPlayList2: cardinal; SelectRounds: cardinal; - SelectTeams: cardinal; - SelectPlayers1: cardinal; - SelectPlayers2: cardinal; - SelectPlayers3: cardinal; + + IPlaylist: array[0..2] of UTF8String; + IPlaylist2: array of UTF8String; PlayList: integer; PlayList2: integer; - Rounds: integer; - NumTeams: integer; - NumPlayer1, NumPlayer2, NumPlayer3: integer; - + + procedure SetPlaylist2; + public constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; procedure SetAnimationProgress(Progress: real); override; - procedure SetPlaylist2; end; -var - IPlaylist: array[0..2] of string; - IPlaylist2: array of string; - - const - ITeams: array[0..1] of string = ('2', '3'); - IPlayers: array[0..3] of string = ('1', '2', '3', '4'); - IRounds: array[0..5] of string = ('2', '3', '4', '5', '6', '7'); - implementation uses @@ -86,21 +74,20 @@ uses ULanguage, UParty, USong, - UDLLManager, UPlaylist, - USongs; + USongs, + UUnicodeUtils; -function TScreenPartyOptions.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenPartyOptions.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; var I, J: integer; - OnlyMultiPlayer: boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -121,27 +108,11 @@ begin //Don'T start when Playlist is Selected and there are no Playlists if (Playlist = 2) and (Length(PlaylistMan.Playlists) = 0) then Exit; - // Don't start when SinglePlayer Teams but only Multiplayer Plugins available - OnlyMultiPlayer := true; - for I := 0 to High(DLLMan.Plugins) do - begin - OnlyMultiPlayer := (OnlyMultiPlayer and DLLMan.Plugins[I].TeamModeOnly); - end; - if (OnlyMultiPlayer) and ((NumPlayer1 = 0) or (NumPlayer2 = 0) or ((NumPlayer3 = 0) and (NumTeams = 1))) then - begin - ScreenPopupError.ShowPopup(Language.Translate('ERROR_NO_PLUGINS')); - Exit; - end; + //Save Difficulty Ini.Difficulty := SelectsS[SelectLevel].SelectedOption; Ini.SaveLevel; - //Save Num Teams: - PartySession.Teams.NumTeams := NumTeams + 2; - PartySession.Teams.Teaminfo[0].NumPlayers := NumPlayer1+1; - PartySession.Teams.Teaminfo[1].NumPlayers := NumPlayer2+1; - PartySession.Teams.Teaminfo[2].NumPlayers := NumPlayer3+1; - //Save Playlist PlaylistMan.Mode := TSingMode( Playlist ); PlaylistMan.CurPlayList := High(cardinal); @@ -168,9 +139,6 @@ begin else PlaylistMan.CurPlayList := Playlist2; - //Start Party - PartySession.StartNewParty(Rounds + 2); - AudioPlayback.PlaySound(SoundLib.Start); //Go to Player Screen FadeTo(@ScreenPartyPlayer); @@ -190,10 +158,6 @@ begin if (Interaction = 1) then begin SetPlaylist2; - end //Change Team3 Players visibility - else if (Interaction = 4) then - begin - SelectsS[7].Visible := (NumTeams = 1); end; end; SDLK_LEFT: @@ -205,10 +169,6 @@ begin if (Interaction = 1) then begin SetPlaylist2; - end //Change Team3 Players visibility - else if (Interaction = 4) then - begin - SelectsS[7].Visible := (NumTeams = 1); end; end; end; @@ -228,30 +188,25 @@ begin IPlaylist2[0] := '---'; //Clear all Selects - NumTeams := 0; - NumPlayer1 := 0; - NumPlayer2 := 0; - NumPlayer3 := 0; - Rounds := 5; PlayList := 0; PlayList2 := 0; //Load Screen From Theme LoadFromTheme(Theme.PartyOptions); - SelectLevel := AddSelectSlide (Theme.PartyOptions.SelectLevel, Ini.Difficulty, Theme.ILevel); - SelectPlayList := AddSelectSlide (Theme.PartyOptions.SelectPlayList, PlayList, IPlaylist); - SelectPlayList2 := AddSelectSlide (Theme.PartyOptions.SelectPlayList2, PlayList2, IPlaylist2); - SelectRounds := AddSelectSlide (Theme.PartyOptions.SelectRounds, Rounds, IRounds); - SelectTeams := AddSelectSlide (Theme.PartyOptions.SelectTeams, NumTeams, ITeams); - SelectPlayers1 := AddSelectSlide (Theme.PartyOptions.SelectPlayers1, NumPlayer1, IPlayers); - SelectPlayers2 := AddSelectSlide (Theme.PartyOptions.SelectPlayers2, NumPlayer2, IPlayers); - SelectPlayers3 := AddSelectSlide (Theme.PartyOptions.SelectPlayers3, NumPlayer3, IPlayers); + Theme.PartyOptions.SelectLevel.oneItemOnly := true; + Theme.PartyOptions.SelectLevel.showArrows := true; + SelectLevel := AddSelectSlide(Theme.PartyOptions.SelectLevel, Ini.Difficulty, Theme.ILevel); - Interaction := 0; + Theme.PartyOptions.SelectPlayList.oneItemOnly := true; + Theme.PartyOptions.SelectPlayList.showArrows := true; + SelectPlayList := AddSelectSlide(Theme.PartyOptions.SelectPlayList, PlayList, IPlaylist); + + Theme.PartyOptions.SelectPlayList2.oneItemOnly := true; + Theme.PartyOptions.SelectPlayList2.showArrows := true; + SelectPlayList2 := AddSelectSlide(Theme.PartyOptions.SelectPlayList2, PlayList2, IPlaylist2); - //Hide Team3 Players - SelectsS[7].Visible := false; + Interaction := 0; end; procedure TScreenPartyOptions.SetPlaylist2; @@ -301,11 +256,23 @@ begin UpdateSelectSlideOptions(Theme.PartyOptions.SelectPlayList2, 2, IPlaylist2, Playlist2); end; -procedure TScreenPartyOptions.onShow; +procedure TScreenPartyOptions.OnShow; begin inherited; - Randomize; + Party.Clear; + + // check if there are loaded modes + if Party.ModesAvailable then + begin + // modes are loaded + Randomize; + end + else + begin // no modes found + ScreenPopupError.ShowPopup(Language.Translate('ERROR_NO_PLUGINS')); + Display.AbortScreenChange; + end; end; procedure TScreenPartyOptions.SetAnimationProgress(Progress: real); diff --git a/cmake/src/screens/UScreenPartyPlayer.pas b/cmake/src/screens/UScreenPartyPlayer.pas index c2070fce..a7f4d627 100644 --- a/cmake/src/screens/UScreenPartyPlayer.pas +++ b/cmake/src/screens/UScreenPartyPlayer.pas @@ -44,6 +44,14 @@ uses type TScreenPartyPlayer = class(TMenu) + private + CountTeams: integer; + CountPlayer: array [0..2] of integer; + + SelectTeams: cardinal; + SelectPlayers: array [0..2] of cardinal; + procedure UpdateInterface; + procedure UpdateParty; public Team1Name: cardinal; Player1Name: cardinal; @@ -64,11 +72,15 @@ type Player12Name: cardinal; constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; procedure SetAnimationProgress(Progress: real); override; end; +const + ITeams: array[0..1] of UTF8String = ('2', '3'); + IPlayers: array[0..3] of UTF8String = ('1', '2', '3', '4'); + implementation uses @@ -76,24 +88,96 @@ uses UMain, UIni, UTexture, - UParty; + UParty, + UUnicodeUtils, + UScreenPartyOptions, + ULanguage; + +procedure TScreenPartyPlayer.UpdateInterface; + var + I: integer; + Btn: integer; +begin + SelectsS[SelectPlayers[2]].Visible := (CountTeams = 1); + + Btn := 0; + for I := 0 to 2 do + begin + if (CountTeams + 1 >= I) then + begin + Button[Btn + 0].Visible := true; + Button[Btn + 1].Visible := (CountPlayer[I] + 1 >= 1); + Button[Btn + 2].Visible := (CountPlayer[I] + 1 >= 2); + Button[Btn + 3].Visible := (CountPlayer[I] + 1 >= 3); + Button[Btn + 4].Visible := (CountPlayer[I] + 1 >= 4); + end + else + begin + Button[Btn + 0].Visible := false; + Button[Btn + 1].Visible := false; + Button[Btn + 2].Visible := false; + Button[Btn + 3].Visible := false; + Button[Btn + 4].Visible := false; + end; + Inc(Btn, 5); + end; +end; + +procedure TScreenPartyPlayer.UpdateParty; + var + I, J: integer; +begin + {//Save PlayerNames + for I := 0 to PartySession.Teams.NumTeams-1 do + begin + PartySession.Teams.Teaminfo[I].Name := PChar(Button[I*5].Text[0].Text); + for J := 0 to PartySession.Teams.Teaminfo[I].NumPlayers-1 do + begin + PartySession.Teams.Teaminfo[I].Playerinfo[J].Name := PChar(Button[I*5 + J+1].Text[0].Text); + PartySession.Teams.Teaminfo[I].Playerinfo[J].TimesPlayed := 0; + end; + end; } + + // add teams to party + + for I := 0 to CountTeams + 1 do + begin + Party.AddTeam(Button[I * 5].Text[0].Text); -function TScreenPartyPlayer.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; + for J := 0 to CountPlayer[I] do + Party.AddPlayer(I, Button[I * 5 + 1 + J].Text[0].Text); + end; + + if (Party.ModesAvailable) then + begin //mode for current playersetup available + FadeTo(@ScreenPartyRounds, SoundLib.Start); + end + else + begin + // no mode available for current player setup + ScreenPopupError.ShowPopup(Language.Translate('ERROR_NO_MODES_FOR_CURRENT_SETUP')); + Party.Clear; + end; +end; + +function TScreenPartyPlayer.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; var SDL_ModState: word; - I, J: integer; - procedure IntNext; begin repeat InteractNext; - until Button[Interaction].Visible; + until ((Interactions[Interaction].Typ = iSelectS) and + SelectsS[Interactions[Interaction].Num].Visible) or + (Button[Interactions[Interaction].Num].Visible); end; procedure IntPrev; begin repeat InteractPrev; - until Button[Interaction].Visible; + until ((Interactions[Interaction].Typ = iSelectS) and + SelectsS[Interactions[Interaction].Num].Visible) or + (Button[Interactions[Interaction].Num].Visible); end; begin Result := true; @@ -104,166 +188,178 @@ begin else SDL_ModState := 0; - begin // Key Down - // check normal keys + // Key Down + // check normal keys + if (Interactions[Interaction].Typ = iButton) then + begin case CharCode of - '0'..'9', 'a'..'z', 'A'..'Z', ' ', '-', '_', '!', ',', '<', '/', '*', '?', '''', '"': + Ord('0')..Ord('9'), + Ord('a')..Ord('z'), + Ord('A')..Ord('Z'), + Ord(' '), Ord('-'), Ord('_'), Ord('!'), Ord(','), Ord('<'), Ord('/'), + Ord('*'), Ord('?'), Ord(''''), Ord('"'): begin - Button[Interaction].Text[0].Text := Button[Interaction].Text[0].Text + CharCode; + Button[Interactions[Interaction].Num].Text[0].Text := + Button[Interactions[Interaction].Num].Text[0].Text + UCS4ToUTF8String(CharCode); Exit; end; end; + // check special keys case PressedKey of // Templates for Names Mod SDLK_F1: if (SDL_ModState = KMOD_LALT) then begin - Ini.NameTemplate[0] := Button[Interaction].Text[0].Text; + Ini.NameTemplate[0] := Button[Interactions[Interaction].Num].Text[0].Text; end else begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[0]; + Button[Interactions[Interaction].Num].Text[0].Text := Ini.NameTemplate[0]; end; SDLK_F2: if (SDL_ModState = KMOD_LALT) then begin - Ini.NameTemplate[1] := Button[Interaction].Text[0].Text; + Ini.NameTemplate[1] := Button[Interactions[Interaction].Num].Text[0].Text; end else begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[1]; + Button[Interactions[Interaction].Num].Text[0].Text := Ini.NameTemplate[1]; end; SDLK_F3: if (SDL_ModState = KMOD_LALT) then begin - Ini.NameTemplate[2] := Button[Interaction].Text[0].Text; + Ini.NameTemplate[2] := Button[Interactions[Interaction].Num].Text[0].Text; end else begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[2]; + Button[Interactions[Interaction].Num].Text[0].Text := Ini.NameTemplate[2]; end; SDLK_F4: if (SDL_ModState = KMOD_LALT) then begin - Ini.NameTemplate[3] := Button[Interaction].Text[0].Text; + Ini.NameTemplate[3] := Button[Interactions[Interaction].Num].Text[0].Text; end else begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[3]; + Button[Interactions[Interaction].Num].Text[0].Text := Ini.NameTemplate[3]; end; SDLK_F5: if (SDL_ModState = KMOD_LALT) then begin - Ini.NameTemplate[4] := Button[Interaction].Text[0].Text; + Ini.NameTemplate[4] := Button[Interactions[Interaction].Num].Text[0].Text; end else begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[4]; + Button[Interactions[Interaction].Num].Text[0].Text := Ini.NameTemplate[4]; end; SDLK_F6: if (SDL_ModState = KMOD_LALT) then begin - Ini.NameTemplate[5] := Button[Interaction].Text[0].Text; + Ini.NameTemplate[5] := Button[Interactions[Interaction].Num].Text[0].Text; end else begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[5]; + Button[Interactions[Interaction].Num].Text[0].Text := Ini.NameTemplate[5]; end; SDLK_F7: if (SDL_ModState = KMOD_LALT) then begin - Ini.NameTemplate[6] := Button[Interaction].Text[0].Text; + Ini.NameTemplate[6] := Button[Interactions[Interaction].Num].Text[0].Text; end else begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[6]; + Button[Interactions[Interaction].Num].Text[0].Text := Ini.NameTemplate[6]; end; SDLK_F8: if (SDL_ModState = KMOD_LALT) then begin - Ini.NameTemplate[7] := Button[Interaction].Text[0].Text; + Ini.NameTemplate[7] := Button[Interactions[Interaction].Num].Text[0].Text; end else begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[7]; + Button[Interactions[Interaction].Num].Text[0].Text := Ini.NameTemplate[7]; end; SDLK_F9: if (SDL_ModState = KMOD_LALT) then begin - Ini.NameTemplate[8] := Button[Interaction].Text[0].Text; + Ini.NameTemplate[8] := Button[Interactions[Interaction].Num].Text[0].Text; end else begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[8]; + Button[Interactions[Interaction].Num].Text[0].Text := Ini.NameTemplate[8]; end; SDLK_F10: if (SDL_ModState = KMOD_LALT) then begin - Ini.NameTemplate[9] := Button[Interaction].Text[0].Text; + Ini.NameTemplate[9] := Button[Interactions[Interaction].Num].Text[0].Text; end else begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[9]; + Button[Interactions[Interaction].Num].Text[0].Text := Ini.NameTemplate[9]; end; SDLK_F11: if (SDL_ModState = KMOD_LALT) then begin - Ini.NameTemplate[10] := Button[Interaction].Text[0].Text; + Ini.NameTemplate[10] := Button[Interactions[Interaction].Num].Text[0].Text; end else begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[10]; + Button[Interactions[Interaction].Num].Text[0].Text := Ini.NameTemplate[10]; end; SDLK_F12: if (SDL_ModState = KMOD_LALT) then begin - Ini.NameTemplate[11] := Button[Interaction].Text[0].Text; + Ini.NameTemplate[11] := Button[Interactions[Interaction].Num].Text[0].Text; end else begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[11]; + Button[Interactions[Interaction].Num].Text[0].Text := Ini.NameTemplate[11]; end; SDLK_BACKSPACE: begin - Button[Interaction].Text[0].DeleteLastL; + Button[Interactions[Interaction].Num].Text[0].DeleteLastLetter; end; + end; + end; - SDLK_ESCAPE: + case PressedKey of + SDLK_ESCAPE: + begin + Ini.SaveNames; + AudioPlayback.PlaySound(SoundLib.Back); + FadeTo(@ScreenPartyOptions); + end; + + SDLK_RETURN: UpdateParty; + + // Up and Down could be done at the same time, + // but I don't want to declare variables inside + // functions like this one, called so many times + SDLK_DOWN: IntNext; + SDLK_UP: IntPrev; + SDLK_RIGHT: + begin + if (Interaction in [0,2,8,14]) then begin - Ini.SaveNames; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenPartyOptions); - end; + AudioPlayback.PlaySound(SoundLib.Option); + InteractInc; - SDLK_RETURN: + UpdateInterface; + end; + end; + SDLK_LEFT: + begin + if (Interaction in [0,2,8,14]) then begin + AudioPlayback.PlaySound(SoundLib.Option); + InteractDec; - //Save PlayerNames - for I := 0 to PartySession.Teams.NumTeams-1 do - begin - PartySession.Teams.Teaminfo[I].Name := PChar(Button[I*5].Text[0].Text); - for J := 0 to PartySession.Teams.Teaminfo[I].NumPlayers-1 do - begin - PartySession.Teams.Teaminfo[I].Playerinfo[J].Name := PChar(Button[I*5 + J+1].Text[0].Text); - PartySession.Teams.Teaminfo[I].Playerinfo[J].TimesPlayed := 0; - end; - end; - - AudioPlayback.PlaySound(SoundLib.Start); - FadeTo(@ScreenPartyNewRound); + UpdateInterface; end; - - // Up and Down could be done at the same time, - // but I don't want to declare variables inside - // functions like this one, called so many times - SDLK_DOWN: IntNext; - SDLK_UP: IntPrev; - SDLK_RIGHT: IntNext; - SDLK_LEFT: IntPrev; - end; + end; end; end; @@ -273,28 +369,50 @@ begin LoadFromTheme(Theme.PartyPlayer); + Theme.PartyPlayer.SelectTeams.oneItemOnly := true; + Theme.PartyPlayer.SelectTeams.showArrows := true; + SelectTeams := AddSelectSlide(Theme.PartyPlayer.SelectTeams, CountTeams, ITeams); + Team1Name := AddButton(Theme.PartyPlayer.Team1Name); + Theme.PartyPlayer.SelectPlayers1.oneItemOnly := true; + Theme.PartyPlayer.SelectPlayers1.showArrows := true; + SelectPlayers[0] := AddSelectSlide(Theme.PartyPlayer.SelectPlayers1, CountPlayer[0], IPlayers); + AddButton(Theme.PartyPlayer.Player1Name); AddButton(Theme.PartyPlayer.Player2Name); AddButton(Theme.PartyPlayer.Player3Name); AddButton(Theme.PartyPlayer.Player4Name); Team2Name := AddButton(Theme.PartyPlayer.Team2Name); + Theme.PartyPlayer.SelectPlayers2.oneItemOnly := true; + Theme.PartyPlayer.SelectPlayers2.showArrows := true; + SelectPlayers[1] := AddSelectSlide(Theme.PartyPlayer.SelectPlayers2, CountPlayer[1], IPlayers); + AddButton(Theme.PartyPlayer.Player5Name); AddButton(Theme.PartyPlayer.Player6Name); AddButton(Theme.PartyPlayer.Player7Name); AddButton(Theme.PartyPlayer.Player8Name); Team3Name := AddButton(Theme.PartyPlayer.Team3Name); + Theme.PartyPlayer.SelectPlayers3.oneItemOnly := true; + Theme.PartyPlayer.SelectPlayers3.showArrows := true; + SelectPlayers[2] := AddSelectSlide(Theme.PartyPlayer.SelectPlayers3, CountPlayer[2], IPlayers); + AddButton(Theme.PartyPlayer.Player9Name); AddButton(Theme.PartyPlayer.Player10Name); AddButton(Theme.PartyPlayer.Player11Name); AddButton(Theme.PartyPlayer.Player12Name); Interaction := 0; + + //Clear Selects + CountTeams := 0; + CountPlayer[0] := 0; + CountPlayer[1] := 0; + CountPlayer[2] := 0; end; -procedure TScreenPartyPlayer.onShow; +procedure TScreenPartyPlayer.OnShow; var I: integer; begin @@ -314,66 +432,18 @@ begin Button[5].Text[0].Text := Ini.NameTeam[1]; Button[10].Text[0].Text := Ini.NameTeam[2]; // Templates for Names Mod end - - if (PartySession.Teams.NumTeams>=1) then - begin - Button[0].Visible := true; - Button[1].Visible := (PartySession.Teams.Teaminfo[0].NumPlayers >=1); - Button[2].Visible := (PartySession.Teams.Teaminfo[0].NumPlayers >=2); - Button[3].Visible := (PartySession.Teams.Teaminfo[0].NumPlayers >=3); - Button[4].Visible := (PartySession.Teams.Teaminfo[0].NumPlayers >=4); - end - else - begin - Button[0].Visible := false; - Button[1].Visible := false; - Button[2].Visible := false; - Button[3].Visible := false; - Button[4].Visible := false; - end; - if (PartySession.Teams.NumTeams>=2) then - begin - Button[5].Visible := true; - Button[6].Visible := (PartySession.Teams.Teaminfo[1].NumPlayers >=1); - Button[7].Visible := (PartySession.Teams.Teaminfo[1].NumPlayers >=2); - Button[8].Visible := (PartySession.Teams.Teaminfo[1].NumPlayers >=3); - Button[9].Visible := (PartySession.Teams.Teaminfo[1].NumPlayers >=4); - end - else - begin - Button[5].Visible := false; - Button[6].Visible := false; - Button[7].Visible := false; - Button[8].Visible := false; - Button[9].Visible := false; - end; - - if (PartySession.Teams.NumTeams>=3) then - begin - Button[10].Visible := true; - Button[11].Visible := (PartySession.Teams.Teaminfo[2].NumPlayers >=1); - Button[12].Visible := (PartySession.Teams.Teaminfo[2].NumPlayers >=2); - Button[13].Visible := (PartySession.Teams.Teaminfo[2].NumPlayers >=3); - Button[14].Visible := (PartySession.Teams.Teaminfo[2].NumPlayers >=4); - end - else - begin - Button[10].Visible := false; - Button[11].Visible := false; - Button[12].Visible := false; - Button[13].Visible := false; - Button[14].Visible := false; - end; + Party.Clear; + UpdateInterface; end; procedure TScreenPartyPlayer.SetAnimationProgress(Progress: real); var I: integer; begin - for I := 0 to high(Button) do - Button[I].Texture.ScaleW := Progress; + {for I := 0 to high(Button) do + Button[I].Texture.ScaleW := Progress; } end; end. diff --git a/cmake/src/screens/UScreenPartyRounds.pas b/cmake/src/screens/UScreenPartyRounds.pas new file mode 100644 index 00000000..070c9eb8 --- /dev/null +++ b/cmake/src/screens/UScreenPartyRounds.pas @@ -0,0 +1,233 @@ +{* UltraStar Deluxe - Karaoke Game
+ *
+ * UltraStar Deluxe is the legal property of its developers, whose names
+ * are too numerous to list here. Please refer to the COPYRIGHT
+ * file distributed with this source distribution.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301, USA.
+ *
+ * $URL: https://ultrastardx.svn.sourceforge.net/svnroot/ultrastardx/branches/experimental/Lua/src/screens/UScreenPartyOptions.pas $
+ * $Id: UScreenPartyOptions.pas 2036 2009-12-14 20:59:44Z whiteshark0 $
+ *}
+
+unit UScreenPartyRounds;
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+{$ENDIF}
+
+{$I switches.inc}
+
+uses
+ UMenu,
+ SDL,
+ UDisplay,
+ UMusic,
+ UFiles,
+ SysUtils,
+ UThemes;
+
+type
+ TScreenPartyRounds = class(TMenu)
+ private
+ SelectRoundCount: cardinal;
+ SelectRound: array [0..6] of cardinal;
+
+ RoundCount: integer;
+ Round: array [0..6] of integer;
+
+ IModeNames: array of UTF8String;
+ IModeIDs: array of integer;
+
+ procedure UpdateInterface;
+ procedure StartParty;
+ public
+ constructor Create; override;
+ function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override;
+ procedure OnShow; override;
+ procedure SetAnimationProgress(Progress: real); override;
+ end;
+
+const
+ IRoundCount: array[0..5] of UTF8String = ('2', '3', '4', '5', '6', '7');
+
+implementation
+
+uses
+ UGraphic,
+ UMain,
+ UIni,
+ UTexture,
+ ULanguage,
+ UParty,
+ USong,
+ UPlaylist,
+ USongs,
+ UUnicodeUtils;
+
+procedure TScreenPartyRounds.UpdateInterface;
+ var
+ I: integer;
+ ActualRounds: integer;
+begin
+ ActualRounds := RoundCount + 2;
+
+ for I := 0 to High(SelectRound) do
+ SelectsS[SelectRound[I]].Visible := (I < ActualRounds);
+end;
+
+procedure TScreenPartyRounds.StartParty;
+ var
+ GameRounds: ARounds;
+ I: integer;
+begin
+ SetLength(GameRounds, RoundCount + 2);
+
+ for I := 0 to High(GameRounds) do
+ GameRounds[I] := IModeIds[Round[I]];
+
+ // start party game
+ if (Party.StartGame(GameRounds)) then
+ begin
+ FadeTo(@ScreenPartyNewRound, SoundLib.Start);
+ end
+ else
+ begin
+ //error starting party game
+ ScreenPopupError.ShowPopup(Language.Translate('ERROR_CAN_NOT_START_PARTY'));
+ end;
+end;
+
+function TScreenPartyRounds.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean;
+begin
+ Result := true;
+ if (PressedDown) then
+ begin // Key Down
+ // check normal keys
+ case UCS4UpperCase(CharCode) of
+ Ord('Q'):
+ begin
+ Result := false;
+ Exit;
+ end;
+ end;
+
+ // check special keys
+ case PressedKey of
+ SDLK_ESCAPE,
+ SDLK_BACKSPACE :
+ begin
+ AudioPlayback.PlaySound(SoundLib.Back);
+ FadeTo(@ScreenPartyPlayer);
+ end;
+
+ SDLK_RETURN: StartParty;
+
+ // Up and Down could be done at the same time,
+ // but I don't want to declare variables inside
+ // functions like this one, called so many times
+ SDLK_DOWN: InteractNext;
+ SDLK_UP: InteractPrev;
+ SDLK_RIGHT:
+ begin
+ AudioPlayback.PlaySound(SoundLib.Option);
+ InteractInc;
+
+ if Interaction = 0 then
+ UpdateInterface;
+ end;
+ SDLK_LEFT:
+ begin
+ AudioPlayback.PlaySound(SoundLib.Option);
+ InteractDec;
+
+ if Interaction = 0 then
+ UpdateInterface;
+ end;
+ end;
+ end;
+end;
+
+constructor TScreenPartyRounds.Create;
+ var
+ I: integer;
+begin
+ inherited Create;
+ RoundCount := 5;
+
+ //Load Screen From Theme
+ LoadFromTheme(Theme.PartyRounds);
+
+ Theme.PartyRounds.SelectRoundCount.oneItemOnly := true;
+ Theme.PartyRounds.SelectRoundCount.showArrows := true;
+ SelectRoundCount := AddSelectSlide(Theme.PartyRounds.SelectRoundCount, RoundCount, IRoundCount);
+
+ SetLength(IModeNames, 1);
+ IModeNames[0] := '---';
+ for I := 0 to high(Theme.PartyRounds.SelectRound) do
+ begin
+ Round[I] := 0;
+ Theme.PartyRounds.SelectRound[I].oneItemOnly := true;
+ Theme.PartyRounds.SelectRound[I].showArrows := true;
+ SelectRound[I] := AddSelectSlide(Theme.PartyRounds.SelectRound[I], Round[I], IModeNames);
+ end;
+
+
+ Interaction := 0;
+end;
+
+procedure TScreenPartyRounds.OnShow;
+ var
+ ModeList: AParty_ModeList;
+ I: integer;
+begin
+ inherited;
+
+ // check if there are loaded modes
+ if Party.ModesAvailable then
+ begin
+ UpdateInterface;
+
+ ModeList := Party.GetAvailableModes;
+ SetLength(IModeNames, Length(ModeList));
+ SetLength(IModeIds, Length(ModeList));
+ for I := 0 to High(ModeList) do
+ begin
+ IModeNames[I] := ModeList[I].Name;
+ IModeIds[I] := ModeList[I].Index;
+ end;
+
+ for I := 0 to High(SelectRound) do
+ UpdateSelectSlideOptions(Theme.PartyRounds.SelectRound[I] , SelectRound[I], IModeNames, Round[I]);
+ end
+ else
+ begin
+ // no mode available for current player setup
+ ScreenPopupError.ShowPopup(Language.Translate('ERROR_NO_MODES_FOR_CURRENT_SETUP'));
+ Party.Clear;
+ Display.AbortScreenChange;
+ end;
+end;
+
+procedure TScreenPartyRounds.SetAnimationProgress(Progress: real);
+begin
+ {for I := 0 to 6 do
+ SelectS[I].Texture.ScaleW := Progress;}
+end;
+
+end.
diff --git a/cmake/src/screens/UScreenPartyScore.pas b/cmake/src/screens/UScreenPartyScore.pas index 23cf666d..32ca5db2 100644 --- a/cmake/src/screens/UScreenPartyScore.pas +++ b/cmake/src/screens/UScreenPartyScore.pas @@ -34,11 +34,11 @@ interface {$I switches.inc} uses - UMenu, SDL, + SysUtils, + UMenu, UDisplay, UMusic, - SysUtils, UThemes; type @@ -69,8 +69,8 @@ type MaxScore: word; constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; procedure SetAnimationProgress(Progress: real); override; end; @@ -80,19 +80,19 @@ uses UGraphic, UMain, UParty, - UScreenSingModi, ULanguage, UTexture, - USkins; + USkins, + UUnicodeUtils; -function TScreenPartyScore.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenPartyScore.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -102,33 +102,28 @@ begin // check special keys case PressedKey of SDLK_ESCAPE, - SDLK_BACKSPACE : + SDLK_BACKSPACE, + SDLK_RETURN : begin AudioPlayback.PlaySound(SoundLib.Start); - if (PartySession.CurRound < High(PartySession.Rounds)) then - FadeTo(@ScreenPartyNewRound) + + Party.NextRound; //< go to next round + + if (not Party.GameFinished) then + begin + FadeTo(@ScreenPartyNewRound); + end else begin - PartySession.EndRound; FadeTo(@ScreenPartyWin); end; end; - - SDLK_RETURN: - begin - AudioPlayback.PlaySound(SoundLib.Start); - if (PartySession.CurRound < High(PartySession.Rounds)) then - FadeTo(@ScreenPartyNewRound) - else - FadeTo(@ScreenPartyWin); - end; end; end; end; constructor TScreenPartyScore.Create; var -// I: integer; // Auto Removed, Unused Variable Tex: TTexture; R, G, B: real; Color: integer; @@ -165,7 +160,9 @@ begin DecoColor[0].B := B; //Load Texture - Tex := Texture.LoadTexture(pchar(Skin.GetTextureFileName(Theme.PartyScore.DecoTextures.FirstTexture)), Theme.PartyScore.DecoTextures.FirstTyp, Color); + Tex := Texture.LoadTexture( + Skin.GetTextureFileName(Theme.PartyScore.DecoTextures.FirstTexture), + Theme.PartyScore.DecoTextures.FirstTyp, Color); DecoTex[0] := Tex.TexNum; //Get Second Color @@ -176,7 +173,9 @@ begin DecoColor[1].B := B; //Load Second Texture - Tex := Texture.LoadTexture(pchar(Skin.GetTextureFileName(Theme.PartyScore.DecoTextures.SecondTexture)), Theme.PartyScore.DecoTextures.SecondTyp, Color); + Tex := Texture.LoadTexture( + Skin.GetTextureFileName(Theme.PartyScore.DecoTextures.SecondTexture), + Theme.PartyScore.DecoTextures.SecondTyp, Color); DecoTex[1] := Tex.TexNum; //Get Third Color @@ -187,150 +186,146 @@ begin DecoColor[2].B := B; //Load Third Texture - Tex := Texture.LoadTexture(pchar(Skin.GetTextureFileName(Theme.PartyScore.DecoTextures.ThirdTexture)), Theme.PartyScore.DecoTextures.ThirdTyp, Color); + Tex := Texture.LoadTexture( + Skin.GetTextureFileName(Theme.PartyScore.DecoTextures.ThirdTexture), + Theme.PartyScore.DecoTextures.ThirdTyp, Color); DecoTex[2] := Tex.TexNum; end; LoadFromTheme(Theme.PartyScore); end; -procedure TScreenPartyScore.onShow; +procedure TScreenPartyScore.OnShow; var - I, J: integer; - Placings: array [0..5] of byte; + Ranking: AParty_TeamRanking; begin inherited; - //Get Maxscore - - MaxScore := 0; - for I := 0 to ScreenSingModi.PlayerInfo.NumPlayers - 1 do - begin - if (ScreenSingModi.PlayerInfo.Playerinfo[I].Score > MaxScore) then - MaxScore := ScreenSingModi.PlayerInfo.Playerinfo[I].Score; - end; + // indicate that round is finished + Party.RoundPlayed; - //Get Placings - for I := 0 to ScreenSingModi.PlayerInfo.NumPlayers - 1 do - begin - Placings[I] := 0; - for J := 0 to ScreenSingModi.PlayerInfo.NumPlayers - 1 do - if (ScreenSingModi.PlayerInfo.Playerinfo[J].Score > ScreenSingModi.PlayerInfo.Playerinfo[I].Score) then - Inc(Placings[I]); - end; + // get rankings for current round + Ranking := Party.Rounds[Party.CurrentRound].Ranking; - //Set Static Length - Static[StaticTeam1].Texture.ScaleW := ScreenSingModi.PlayerInfo.Playerinfo[0].Percentage / 100; - Static[StaticTeam2].Texture.ScaleW := ScreenSingModi.PlayerInfo.Playerinfo[1].Percentage / 100; - Static[StaticTeam3].Texture.ScaleW := ScreenSingModi.PlayerInfo.Playerinfo[2].Percentage / 100; - //fix: prevents static from drawn out of bounds. - if Static[StaticTeam1].Texture.ScaleW > 99 then Static[StaticTeam1].Texture.ScaleW := 99; - if Static[StaticTeam2].Texture.ScaleW > 99 then Static[StaticTeam2].Texture.ScaleW := 99; - if Static[StaticTeam3].Texture.ScaleW > 99 then Static[StaticTeam3].Texture.ScaleW := 99; + {//Set Statics Length + Statics[StaticTeam1].Texture.ScaleW := ScreenSingModi.PlayerInfo.Playerinfo[0].Percentage / 100; + Statics[StaticTeam2].Texture.ScaleW := ScreenSingModi.PlayerInfo.Playerinfo[1].Percentage / 100; + Statics[StaticTeam3].Texture.ScaleW := ScreenSingModi.PlayerInfo.Playerinfo[2].Percentage / 100; - //End Last Round - PartySession.EndRound; + //fix: prevents statics from drawn out of bounds. + if Statics[StaticTeam1].Texture.ScaleW > 99 then Statics[StaticTeam1].Texture.ScaleW := 99; + if Statics[StaticTeam2].Texture.ScaleW > 99 then Statics[StaticTeam2].Texture.ScaleW := 99; + if Statics[StaticTeam3].Texture.ScaleW > 99 then Statics[StaticTeam3].Texture.ScaleW := 99; } //Set Winnertext - Text[TextWinner].Text := Format(Language.Translate('PARTY_SCORE_WINS'), [PartySession.GetWinnerString(PartySession.CurRound)]); + Text[TextWinner].Text := Format(Language.Translate('PARTY_SCORE_WINS'), [Party.GetWinnerString(Party.CurrentRound)]); - if (ScreenSingModi.PlayerInfo.NumPlayers >= 1) then + if (Length(Party.Teams) >= 1) then begin - Text[TextScoreTeam1].Text := InttoStr(ScreenSingModi.PlayerInfo.Playerinfo[0].Score); - Text[TextNameTeam1].Text := string(ScreenSingModi.TeamInfo.Teaminfo[0].Name); + Text[TextScoreTeam1].Text := InttoStr(Party.Teams[0].Score); + Text[TextNameTeam1].Text := Utf8String(Party.Teams[0].Name); //Set Deco Texture if Theme.PartyScore.DecoTextures.ChangeTextures then begin - Static[StaticTeam1Deco].Texture.TexNum := DecoTex[Placings[0]]; - Static[StaticTeam1Deco].Texture.ColR := DecoColor[Placings[0]].R; - Static[StaticTeam1Deco].Texture.ColG := DecoColor[Placings[0]].G; - Static[StaticTeam1Deco].Texture.ColB := DecoColor[Placings[0]].B; + if (Length(Ranking) >= 1) and (Ranking[0].Rank >= 1) and (Ranking[0].Rank <= Length(DecoTex)) then + begin + Statics[StaticTeam1Deco].Texture.TexNum := DecoTex[Ranking[0].Rank-1]; + Statics[StaticTeam1Deco].Texture.ColR := DecoColor[Ranking[0].Rank-1].R; + Statics[StaticTeam1Deco].Texture.ColG := DecoColor[Ranking[0].Rank-1].G; + Statics[StaticTeam1Deco].Texture.ColB := DecoColor[Ranking[0].Rank-1].B; + end; end; Text[TextScoreTeam1].Visible := true; Text[TextNameTeam1].Visible := true; - Static[StaticTeam1].Visible := true; - Static[StaticTeam1BG].Visible := true; - Static[StaticTeam1Deco].Visible := true; + Statics[StaticTeam1].Visible := true; + Statics[StaticTeam1BG].Visible := true; + Statics[StaticTeam1Deco].Visible := true; end else begin Text[TextScoreTeam1].Visible := false; Text[TextNameTeam1].Visible := false; - Static[StaticTeam1].Visible := false; - Static[StaticTeam1BG].Visible := false; - Static[StaticTeam1Deco].Visible := false; + Statics[StaticTeam1].Visible := false; + Statics[StaticTeam1BG].Visible := false; + Statics[StaticTeam1Deco].Visible := false; end; - if (ScreenSingModi.PlayerInfo.NumPlayers >= 2) then + if (Length(Party.Teams) >= 2) then begin - Text[TextScoreTeam2].Text := InttoStr(ScreenSingModi.PlayerInfo.Playerinfo[1].Score); - Text[TextNameTeam2].Text := string(ScreenSingModi.TeamInfo.Teaminfo[1].Name); + Text[TextScoreTeam2].Text := InttoStr(Party.Teams[1].Score); + Text[TextNameTeam2].Text := UTF8String(Party.Teams[1].Name); //Set Deco Texture if Theme.PartyScore.DecoTextures.ChangeTextures then begin - Static[StaticTeam2Deco].Texture.TexNum := DecoTex[Placings[1]]; - Static[StaticTeam2Deco].Texture.ColR := DecoColor[Placings[1]].R; - Static[StaticTeam2Deco].Texture.ColG := DecoColor[Placings[1]].G; - Static[StaticTeam2Deco].Texture.ColB := DecoColor[Placings[1]].B; + if (Length(Ranking) >= 2) and (Ranking[1].Rank >= 1) and (Ranking[1].Rank <= Length(DecoTex)) then + begin + Statics[StaticTeam2Deco].Texture.TexNum := DecoTex[Ranking[1].Rank-1]; + Statics[StaticTeam2Deco].Texture.ColR := DecoColor[Ranking[1].Rank-1].R; + Statics[StaticTeam2Deco].Texture.ColG := DecoColor[Ranking[1].Rank-1].G; + Statics[StaticTeam2Deco].Texture.ColB := DecoColor[Ranking[1].Rank-1].B; + end; end; Text[TextScoreTeam2].Visible := true; Text[TextNameTeam2].Visible := true; - Static[StaticTeam2].Visible := true; - Static[StaticTeam2BG].Visible := true; - Static[StaticTeam2Deco].Visible := true; + Statics[StaticTeam2].Visible := true; + Statics[StaticTeam2BG].Visible := true; + Statics[StaticTeam2Deco].Visible := true; end else begin Text[TextScoreTeam2].Visible := false; Text[TextNameTeam2].Visible := false; - Static[StaticTeam2].Visible := false; - Static[StaticTeam2BG].Visible := false; - Static[StaticTeam2Deco].Visible := false; + Statics[StaticTeam2].Visible := false; + Statics[StaticTeam2BG].Visible := false; + Statics[StaticTeam2Deco].Visible := false; end; - if (ScreenSingModi.PlayerInfo.NumPlayers >= 3) then + if (Length(Party.Teams) >= 3) then begin - Text[TextScoreTeam3].Text := InttoStr(ScreenSingModi.PlayerInfo.Playerinfo[2].Score); - Text[TextNameTeam3].Text := string(ScreenSingModi.TeamInfo.Teaminfo[2].Name); + Text[TextScoreTeam3].Text := InttoStr(Party.Teams[2].Score); + Text[TextNameTeam3].Text := UTF8String(Party.Teams[2].Name); //Set Deco Texture if Theme.PartyScore.DecoTextures.ChangeTextures then begin - Static[StaticTeam3Deco].Texture.TexNum := DecoTex[Placings[2]]; - Static[StaticTeam3Deco].Texture.ColR := DecoColor[Placings[2]].R; - Static[StaticTeam3Deco].Texture.ColG := DecoColor[Placings[2]].G; - Static[StaticTeam3Deco].Texture.ColB := DecoColor[Placings[2]].B; + if (Length(Ranking) >= 3) and (Ranking[2].Rank >= 1) and (Ranking[2].Rank <= Length(DecoTex)) then + begin + Statics[StaticTeam3Deco].Texture.TexNum := DecoTex[Ranking[2].Rank-1]; + Statics[StaticTeam3Deco].Texture.ColR := DecoColor[Ranking[2].Rank-1].R; + Statics[StaticTeam3Deco].Texture.ColG := DecoColor[Ranking[2].Rank-1].G; + Statics[StaticTeam3Deco].Texture.ColB := DecoColor[Ranking[2].Rank-1].B; + end; end; Text[TextScoreTeam3].Visible := true; Text[TextNameTeam3].Visible := true; - Static[StaticTeam3].Visible := true; - Static[StaticTeam3BG].Visible := true; - Static[StaticTeam3Deco].Visible := true; + Statics[StaticTeam3].Visible := true; + Statics[StaticTeam3BG].Visible := true; + Statics[StaticTeam3Deco].Visible := true; end else begin Text[TextScoreTeam3].Visible := false; Text[TextNameTeam3].Visible := false; - Static[StaticTeam3].Visible := false; - Static[StaticTeam3BG].Visible := false; - Static[StaticTeam3Deco].Visible := false; + Statics[StaticTeam3].Visible := false; + Statics[StaticTeam3BG].Visible := false; + Statics[StaticTeam3Deco].Visible := false; end; end; procedure TScreenPartyScore.SetAnimationProgress(Progress: real); begin - if (ScreenSingModi.PlayerInfo.NumPlayers >= 1) then - Static[StaticTeam1].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[0].Percentage / 100; + {if (ScreenSingModi.PlayerInfo.NumPlayers >= 1) then + Statics[StaticTeam1].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[0].Percentage / 100; if (ScreenSingModi.PlayerInfo.NumPlayers >= 2) then - Static[StaticTeam2].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[1].Percentage / 100; + Statics[StaticTeam2].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[1].Percentage / 100; if (ScreenSingModi.PlayerInfo.NumPlayers >= 3) then - Static[StaticTeam3].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[2].Percentage / 100; + Statics[StaticTeam3].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[2].Percentage / 100;} end; end. diff --git a/cmake/src/screens/UScreenPartyWin.pas b/cmake/src/screens/UScreenPartyWin.pas index 3c105c7d..ed8d017c 100644 --- a/cmake/src/screens/UScreenPartyWin.pas +++ b/cmake/src/screens/UScreenPartyWin.pas @@ -34,10 +34,11 @@ interface {$I switches.inc} uses + SDL, + SysUtils, UMenu, - SDL, UDisplay, + UDisplay, UMusic, - SysUtils, UThemes; type @@ -61,28 +62,28 @@ type TextWinner: cardinal; constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; procedure SetAnimationProgress(Progress: real); override; end; implementation -uses +uses UGraphic, UMain, UParty, - UScreenSingModi, - ULanguage; + ULanguage, + UUnicodeUtils; -function TScreenPartyWin.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenPartyWin.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -92,13 +93,8 @@ begin // check special keys case PressedKey of SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - AudioPlayback.PlaySound(SoundLib.Start); - FadeTo(@ScreenMain); - end; - - SDLK_RETURN: + SDLK_BACKSPACE, + SDLK_RETURN : begin AudioPlayback.PlaySound(SoundLib.Start); FadeTo(@ScreenMain); @@ -108,8 +104,6 @@ begin end; constructor TScreenPartyWin.Create; -//var -// I: integer; // Auto Removed, Unused Variable begin inherited Create; @@ -135,12 +129,12 @@ begin LoadFromTheme(Theme.PartyWin); end; -procedure TScreenPartyWin.onShow; +procedure TScreenPartyWin.OnShow; var - I: integer; - Placing: TeamOrderArray; + I: integer; + Ranking: AParty_TeamRanking; - Function GetTeamColor(Team: byte): cardinal; + Function GetTeamColor(Team: integer): cardinal; var NameString: string; begin @@ -152,42 +146,43 @@ var begin inherited; - //Get Team Placing - Placing := PartySession.GetTeamOrder; + // get team ranking + // Ranking is sorted by score + Ranking := Party.GetTeamRanking; //Set Winnertext - Text[TextWinner].Text := Format(Language.Translate('PARTY_SCORE_WINS'), [PartySession.Teams.Teaminfo[Placing[0]].Name]); - if (PartySession.Teams.NumTeams >= 1) then + Text[TextWinner].Text := Format(Language.Translate('PARTY_SCORE_WINS'), [Party.GetWinnerString(-1)]); + if (Length(Party.Teams) >= 1) then begin - Text[TextScoreTeam1].Text := InttoStr(PartySession.Teams.TeamInfo[Placing[0]].Score); - Text[TextNameTeam1].Text := string(PartySession.Teams.TeamInfo[Placing[0]].Name); + Text[TextScoreTeam1].Text := IntToStr(Party.Teams[Ranking[0].Team].Score); + Text[TextNameTeam1].Text := Party.Teams[Ranking[0].Team].Name; Text[TextScoreTeam1].Visible := true; Text[TextNameTeam1].Visible := true; - Static[StaticTeam1].Visible := true; - Static[StaticTeam1BG].Visible := true; - Static[StaticTeam1Deco].Visible := true; + Statics[StaticTeam1].Visible := true; + Statics[StaticTeam1BG].Visible := true; + Statics[StaticTeam1Deco].Visible := true; //Set Static Color to Team Color if (Theme.PartyWin.StaticTeam1BG.Color = 'TeamColor') then begin - I := GetTeamColor(Placing[0]); + I := GetTeamColor(Ranking[0].Team); if (I <> -1) then begin - Static[StaticTeam1BG].Texture.ColR := Color[I].RGB.R; - Static[StaticTeam1BG].Texture.ColG := Color[I].RGB.G; - Static[StaticTeam1BG].Texture.ColB := Color[I].RGB.B; + Statics[StaticTeam1BG].Texture.ColR := Color[I].RGB.R; + Statics[StaticTeam1BG].Texture.ColG := Color[I].RGB.G; + Statics[StaticTeam1BG].Texture.ColB := Color[I].RGB.B; end; end; if (Theme.PartyWin.StaticTeam1.Color = 'TeamColor') then begin - I := GetTeamColor(Placing[0]); + I := GetTeamColor(Ranking[0].Team); if (I <> -1) then begin - Static[StaticTeam1].Texture.ColR := Color[I].RGB.R; - Static[StaticTeam1].Texture.ColG := Color[I].RGB.G; - Static[StaticTeam1].Texture.ColB := Color[I].RGB.B; + Statics[StaticTeam1].Texture.ColR := Color[I].RGB.R; + Statics[StaticTeam1].Texture.ColG := Color[I].RGB.G; + Statics[StaticTeam1].Texture.ColB := Color[I].RGB.B; end; end; end @@ -195,42 +190,42 @@ begin begin Text[TextScoreTeam1].Visible := false; Text[TextNameTeam1].Visible := false; - Static[StaticTeam1].Visible := false; - Static[StaticTeam1BG].Visible := false; - Static[StaticTeam1Deco].Visible := false; + Statics[StaticTeam1].Visible := false; + Statics[StaticTeam1BG].Visible := false; + Statics[StaticTeam1Deco].Visible := false; end; - if (PartySession.Teams.NumTeams >= 2) then + if (Length(Party.Teams) >= 2) then begin - Text[TextScoreTeam2].Text := InttoStr(PartySession.Teams.TeamInfo[Placing[1]].Score); - Text[TextNameTeam2].Text := string(PartySession.Teams.TeamInfo[Placing[1]].Name); + Text[TextScoreTeam2].Text := IntToStr(Party.Teams[Ranking[1].Team].Score); + Text[TextNameTeam2].Text := Party.Teams[Ranking[1].Team].Name; Text[TextScoreTeam2].Visible := true; Text[TextNameTeam2].Visible := true; - Static[StaticTeam2].Visible := true; - Static[StaticTeam2BG].Visible := true; - Static[StaticTeam2Deco].Visible := true; + Statics[StaticTeam2].Visible := true; + Statics[StaticTeam2BG].Visible := true; + Statics[StaticTeam2Deco].Visible := true; //Set Static Color to Team Color if (Theme.PartyWin.StaticTeam2BG.Color = 'TeamColor') then begin - I := GetTeamColor(Placing[1]); + I := GetTeamColor(Ranking[1].Team); if (I <> -1) then begin - Static[StaticTeam2BG].Texture.ColR := Color[I].RGB.R; - Static[StaticTeam2BG].Texture.ColG := Color[I].RGB.G; - Static[StaticTeam2BG].Texture.ColB := Color[I].RGB.B; + Statics[StaticTeam2BG].Texture.ColR := Color[I].RGB.R; + Statics[StaticTeam2BG].Texture.ColG := Color[I].RGB.G; + Statics[StaticTeam2BG].Texture.ColB := Color[I].RGB.B; end; end; if (Theme.PartyWin.StaticTeam2.Color = 'TeamColor') then begin - I := GetTeamColor(Placing[1]); + I := GetTeamColor(Ranking[1].Team); if (I <> -1) then begin - Static[StaticTeam2].Texture.ColR := Color[I].RGB.R; - Static[StaticTeam2].Texture.ColG := Color[I].RGB.G; - Static[StaticTeam2].Texture.ColB := Color[I].RGB.B; + Statics[StaticTeam2].Texture.ColR := Color[I].RGB.R; + Statics[StaticTeam2].Texture.ColG := Color[I].RGB.G; + Statics[StaticTeam2].Texture.ColB := Color[I].RGB.B; end; end; end @@ -238,42 +233,42 @@ begin begin Text[TextScoreTeam2].Visible := false; Text[TextNameTeam2].Visible := false; - Static[StaticTeam2].Visible := false; - Static[StaticTeam2BG].Visible := false; - Static[StaticTeam2Deco].Visible := false; + Statics[StaticTeam2].Visible := false; + Statics[StaticTeam2BG].Visible := false; + Statics[StaticTeam2Deco].Visible := false; end; - if (PartySession.Teams.NumTeams >= 3) then + if (Length(Party.Teams) >= 3) then begin - Text[TextScoreTeam3].Text := InttoStr(PartySession.Teams.TeamInfo[Placing[2]].Score); - Text[TextNameTeam3].Text := string(PartySession.Teams.TeamInfo[Placing[2]].Name); + Text[TextScoreTeam3].Text := IntToStr(Party.Teams[Ranking[2].Team].Score); + Text[TextNameTeam3].Text := Party.Teams[Ranking[2].Team].Name; Text[TextScoreTeam3].Visible := true; Text[TextNameTeam3].Visible := true; - Static[StaticTeam3].Visible := true; - Static[StaticTeam3BG].Visible := true; - Static[StaticTeam3Deco].Visible := true; + Statics[StaticTeam3].Visible := true; + Statics[StaticTeam3BG].Visible := true; + Statics[StaticTeam3Deco].Visible := true; //Set Static Color to Team Color if (Theme.PartyWin.StaticTeam3BG.Color = 'TeamColor') then begin - I := GetTeamColor(Placing[2]); + I := GetTeamColor(Ranking[2].Team); if (I <> -1) then begin - Static[StaticTeam3BG].Texture.ColR := Color[I].RGB.R; - Static[StaticTeam3BG].Texture.ColG := Color[I].RGB.G; - Static[StaticTeam3BG].Texture.ColB := Color[I].RGB.B; + Statics[StaticTeam3BG].Texture.ColR := Color[I].RGB.R; + Statics[StaticTeam3BG].Texture.ColG := Color[I].RGB.G; + Statics[StaticTeam3BG].Texture.ColB := Color[I].RGB.B; end; end; if (Theme.PartyWin.StaticTeam3.Color = 'TeamColor') then begin - I := GetTeamColor(Placing[2]); + I := GetTeamColor(Ranking[2].Team); if (I <> -1) then begin - Static[StaticTeam3].Texture.ColR := Color[I].RGB.R; - Static[StaticTeam3].Texture.ColG := Color[I].RGB.G; - Static[StaticTeam3].Texture.ColB := Color[I].RGB.B; + Statics[StaticTeam3].Texture.ColR := Color[I].RGB.R; + Statics[StaticTeam3].Texture.ColG := Color[I].RGB.G; + Statics[StaticTeam3].Texture.ColB := Color[I].RGB.B; end; end; end @@ -281,20 +276,20 @@ begin begin Text[TextScoreTeam3].Visible := false; Text[TextNameTeam3].Visible := false; - Static[StaticTeam3].Visible := false; - Static[StaticTeam3BG].Visible := false; - Static[StaticTeam3Deco].Visible := false; + Statics[StaticTeam3].Visible := false; + Statics[StaticTeam3BG].Visible := false; + Statics[StaticTeam3Deco].Visible := false; end; end; procedure TScreenPartyWin.SetAnimationProgress(Progress: real); begin {if (ScreenSingModi.PlayerInfo.NumPlayers >= 1) then - Static[StaticTeam1].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[0].Score / maxScore; + Statics[StaticTeam1].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[0].Score / maxScore; if (ScreenSingModi.PlayerInfo.NumPlayers >= 2) then - Static[StaticTeam2].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[1].Score / maxScore; + Statics[StaticTeam2].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[1].Score / maxScore; if (ScreenSingModi.PlayerInfo.NumPlayers >= 3) then - Static[StaticTeam3].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[2].Score / maxScore;} + Statics[StaticTeam3].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[2].Score / maxScore;} end; end. diff --git a/cmake/src/screens/UScreenPopup.pas b/cmake/src/screens/UScreenPopup.pas index 7e4671d6..fdf4a69c 100644 --- a/cmake/src/screens/UScreenPopup.pas +++ b/cmake/src/screens/UScreenPopup.pas @@ -34,42 +34,61 @@ interface {$I switches.inc} uses - UMenu, SDL, + SysUtils, + UMenu, UMusic, UFiles, - SysUtils, UThemes; type + TPopupCheckHandler = procedure(Value: boolean; Data: Pointer); + TScreenPopupCheck = class(TMenu) + private + fHandler: TPopupCheckHandler; + fHandlerData: Pointer; + public - Visible: boolean; //Whether the Menu should be Drawn + Visible: boolean; // whether the menu should be drawn constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; - procedure ShowPopup(msg: string); + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; + procedure ShowPopup(const Msg: UTF8String; Handler: TPopupCheckHandler; + HandlerData: Pointer; DefaultValue: boolean = false); function Draw: boolean; override; end; type - TScreenPopupError = class(TMenu) -{ private - CurMenu: byte; //Num of the cur. Shown Menu} + TScreenPopup = class(TMenu) + { + private + CurMenu: byte; //Num of the cur. Shown Menu + } public Visible: boolean; //Whether the Menu should be Drawn constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; - procedure onHide; override; - procedure ShowPopup(msg: string); + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; + procedure OnHide; override; + procedure ShowPopup(const Msg: UTF8String); function Draw: boolean; override; end; + TScreenPopupError = class(TScreenPopup) + public + constructor Create; + end; + + TScreenPopupInfo = class(TScreenPopup) + public + constructor Create; + end; + var -// ISelections: array of string; + //ISelections: array of string; SelectValue: integer; implementation @@ -82,70 +101,57 @@ uses ULanguage, UParty, UPlaylist, - UDisplay; + UDisplay, + UUnicodeUtils; -function TScreenPopupCheck.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +{ TScreenPopupCheck } + +function TScreenPopupCheck.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; +var + Value: boolean; begin Result := true; if (PressedDown) then begin // Key Down - // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': - begin - Result := false; - Exit; - end; - end; - // check special keys case PressedKey of SDLK_ESCAPE, SDLK_BACKSPACE : begin - Display.CheckOK := false; - Display.NextScreenWithCheck := NIL; + Value := false; Visible := false; Result := false; end; SDLK_RETURN: begin - case Interaction of - 0: begin - //Hack to Finish Singscreen correct on Exit with Q Shortcut - if (Display.NextScreenWithCheck = NIL) then - begin - if (Display.CurrentScreen = @ScreenSing) then - ScreenSing.Finish - else if (Display.CurrentScreen = @ScreenSingModi) then - ScreenSingModi.Finish; - end; - - Display.CheckOK := true; - end; - 1: begin - Display.CheckOK := false; - Display.NextScreenWithCheck := NIL; - end; - end; + Value := (Interaction = 0); Visible := false; Result := false; end; - SDLK_DOWN: InteractNext; - SDLK_UP: InteractPrev; - + SDLK_DOWN: InteractNext; + SDLK_UP: InteractPrev; + SDLK_RIGHT: InteractNext; - SDLK_LEFT: InteractPrev; + SDLK_LEFT: InteractPrev; end; end; + + if (not Result) then + begin + if (@fHandler <> nil) then + fHandler(Value, fHandlerData); + end; end; constructor TScreenPopupCheck.Create; begin inherited Create; + fHandler := nil; + fHandlerData := nil; + AddText(Theme.CheckPopup.TextCheck); LoadFromTheme(Theme.CheckPopup); @@ -163,18 +169,24 @@ end; function TScreenPopupCheck.Draw: boolean; begin - Draw:=inherited Draw; + Result := inherited Draw; end; -procedure TScreenPopupCheck.onShow; +procedure TScreenPopupCheck.OnShow; begin inherited; end; -procedure TScreenPopupCheck.ShowPopup(msg: string); +procedure TScreenPopupCheck.ShowPopup(const Msg: UTF8String; Handler: TPopupCheckHandler; + HandlerData: Pointer; DefaultValue: boolean); begin - Interaction := 0; //Reset Interaction + if (DefaultValue) then + Interaction := 0 + else + Interaction := 1; Visible := true; //Set Visible + fHandler := Handler; + fHandlerData := HandlerData; Text[0].Text := Language.Translate(msg); @@ -187,9 +199,9 @@ begin Background.OnShow end; -// error popup +{ TScreenPopup } -function TScreenPopupError.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenPopup.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then @@ -223,7 +235,7 @@ begin end; end; -constructor TScreenPopupError.Create; +constructor TScreenPopup.Create; begin inherited Create; @@ -238,22 +250,22 @@ begin Interaction := 0; end; -function TScreenPopupError.Draw: boolean; +function TScreenPopup.Draw: boolean; begin Draw := inherited Draw; end; -procedure TScreenPopupError.onShow; +procedure TScreenPopup.OnShow; begin inherited; end; -procedure TScreenPopupError.onHide; +procedure TScreenPopup.OnHide; begin end; -procedure TScreenPopupError.ShowPopup(msg: string); +procedure TScreenPopup.ShowPopup(const Msg: UTF8String); begin Interaction := 0; //Reset Interaction Visible := true; //Set Visible @@ -277,4 +289,20 @@ begin Button[0].Text[0].Text := 'OK'; end; +{ TScreenPopupError } + +constructor TScreenPopupError.Create; +begin + inherited; + Text[1].Text := Language.Translate('MSG_ERROR_TITLE'); +end; + +{ TScreenPopupInfo } + +constructor TScreenPopupInfo.Create; +begin + inherited; + Text[1].Text := Language.Translate('MSG_INFO_TITLE'); +end; + end. diff --git a/cmake/src/screens/UScreenScore.pas b/cmake/src/screens/UScreenScore.pas index a01c7691..de7675bf 100644 --- a/cmake/src/screens/UScreenScore.pas +++ b/cmake/src/screens/UScreenScore.pas @@ -51,9 +51,10 @@ const EaseOut_MaxSteps: real = 10; // that's the speed of the bars (10 is fast | 100 is slower) - BarRaiseSpeed: cardinal = 0; // Time for raising the bar one step higher (in ms) + BarRaiseSpeed: cardinal = 14; // Time for raising the bar one step higher (in ms) type + TScoreBarType = (sbtScore, sbtLine, sbtGolden); TPlayerScoreScreenTexture = record // holds all colorized textures for up to 6 players //Bar textures Score_NoteBarLevel_Dark: TTexture; // Note @@ -64,6 +65,8 @@ type Score_NoteBarLevel_Lightest: TTexture; // GoldenNotes Score_NoteBarRound_Lightest: TTexture; + + Player_Id_Box: TTexture; // boxes with player numbers end; TPlayerScoreScreenData = record // holds the positions and other data @@ -79,11 +82,27 @@ type RateEaseValue: real; end; + { hold maps of players to the different positions } + TPlayerPositionMap = record + Position: byte; // 1..6: Position of Player; 0: no position (e.g. too little screens) + Screen: byte; // 0 - Screen 1; 1 - Screen 2 + BothScreens: boolean; // true if player is drawn on both screens + end; + APlayerPositionMap = array of TPlayerPositionMap; + + { textures for playerstatics of seconds screen players } + TPlayerStaticTexture = record + Tex: TTexture; + end; + TScreenScore = class(TMenu) private + { holds position and screen of players(index) + set by calling MapPlayerstoPosition() } + PlayerPositionMap: APlayerPositionMap; + BarTime: cardinal; - ArrayStartModifier: integer; - public + aPlayerScoreScreenTextures: array[1..6] of TPlayerScoreScreenTexture; aPlayerScoreScreenDatas: array[1..6] of TPlayerScoreScreenData; aPlayerScoreScreenRatings: array[1..6] of TPlayerScoreRatingPics; @@ -110,42 +129,77 @@ type TextTotalScore: array[1..6] of integer; PlayerStatic: array[1..6] of array of integer; + { texture pairs for swapping when screens = 2 + first array level: index of player ( actually this is a position + 1 - Player 1 if PlayersPlay = 1 <- we don't need swapping here + 2..3 - Player 1 and 2 or 3 and 4 if PlayersPlay = 2 or 4 + 4..6 - Player 1 - 3 or 4 - 6 if PlayersPlay = 3 or 6 ) + second array level: different playerstatics for positions + third array level: texture for screen 1 or 2 } + PlayerStaticTextures: array[1..6] of array of array [1..2] of TPlayerStaticTexture; PlayerTexts: array[1..6] of array of integer; StaticBoxLightest: array[1..6] of integer; StaticBoxLight: array[1..6] of integer; StaticBoxDark: array[1..6] of integer; + { texture pairs for swapping when screens = 2 + for boxes + first array level: index of player ( actually this is a position + 1 - Player 1 if PlayersPlay = 1 <- we don't need swapping here + 2..3 - Player 1 and 2 or 3 and 4 if PlayersPlay = 2 or 4 + 4..6 - Player 1 - 3 or 4 - 6 if PlayersPlay = 3 or 6 ) + second array level: different boxes for positions (0: lightest; 1: light; 2: dark) + third array level: texture for screen 1 or 2 } + PlayerBoxTextures: array[1..6] of array[0..2] of array [1..2] of TPlayerStaticTexture; StaticBackLevel: array[1..6] of integer; StaticBackLevelRound: array[1..6] of integer; StaticLevel: array[1..6] of integer; StaticLevelRound: array[1..6] of integer; + { statics with players ids } + StaticPlayerIdBox: array[1..6] of integer; + TexturePlayerIdBox: array[1..6] of TTexture; + Animation: real; TextScore_ActualValue: array[1..6] of integer; TextPhrase_ActualValue: array[1..6] of integer; TextGolden_ActualValue: array[1..6] of integer; - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - function ParseMouse(MouseButton: Integer; BtnDown: Boolean; X, Y: integer): boolean; override; - procedure onShow; override; - procedure onShowFinish; override; - function Draw: boolean; override; + procedure MapPlayersToPosition; + procedure FillPlayer(Item, P: integer); + procedure FillPlayerItems(PlayerNumber: integer); - procedure EaseBarIn(PlayerNumber: integer; BarType: string); - procedure EaseScoreIn(PlayerNumber: integer; ScoreType: string); + procedure UpdateAnimation; + {**** + * helpers for bar easing + *} + procedure EaseBarIn(PlayerNumber: integer; BarType: TScoreBarType); + procedure EaseScoreIn(PlayerNumber: integer; ScoreType: TScoreBarType); - procedure FillPlayerItems(PlayerNumber: integer; ScoreType: string); + procedure DrawPlayerBars; - procedure DrawBar(BarType: string; PlayerNumber: integer; BarStartPosY: single; NewHeight: real); + procedure DrawBar(BarType: TScoreBarType; PlayerNumber: integer; BarStartPosY: single; NewHeight: real); - //Rating Picture + {**** + * helpers for rating picture + *} procedure ShowRating(PlayerNumber: integer); function CalculateBouncing(PlayerNumber: integer): real; procedure DrawRating(PlayerNumber: integer; Rating: integer); + + { for player static texture swapping } + procedure LoadSwapTextures; + procedure SwapToScreen(Screen: integer); + public + constructor Create; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + function ParseMouse(MouseButton: Integer; BtnDown: Boolean; X, Y: integer): boolean; override; + procedure OnShow; override; + procedure OnShowFinish; override; + function Draw: boolean; override; end; implementation @@ -156,18 +210,21 @@ uses UMenuStatic, UTime, UIni, + USkins, ULog, ULanguage, - UNote; + UNote, + UUnicodeUtils; -function TScreenScore.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; + +function TScreenScore.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -197,7 +254,189 @@ begin Result := True; if (MouseButton = SDL_BUTTON_LEFT) and BtnDown then begin //left-click anywhere sends return - ParseInput(SDLK_RETURN, #0, true); + ParseInput(SDLK_RETURN, 0, true); + end; +end; + +procedure TScreenScore.LoadSwapTextures; + var + P, I: integer; + PlayerNum, PlayerNum2: integer; + Color: string; + R, G, B: real; + StaticNum: integer; + ThemeStatic: TThemeStatic; +begin + { we only need to load swapping textures if in dualscreen mode } + if Screens = 2 then + begin + { load swapping textures for custom statics } + for P := low(PlayerStatic) to High(PlayerStatic) do + begin + SetLength(PlayerStaticTextures[P], Length(PlayerStatic[P])); + + { get the players that actually are on this position } + case P of + 1: begin + PlayerNum := 1; + PlayerNum2 := 1; + end; + + 2, 3: begin + PlayerNum := P - 1; + PlayerNum2 := PlayerNum + 2; + end; + + 4..6: begin + PlayerNum := P - 3; + PlayerNum2 := PlayerNum + 3; + end; + end; + + for I := 0 to High(PlayerStatic[P]) do + begin + // copy current statics texture to texture for screen 1 + PlayerStaticTextures[P, I, 1].Tex := Statics[PlayerStatic[P, I]].Texture; + + // fallback to first screen texture for 2nd screen + PlayerStaticTextures[P, I, 2].Tex := PlayerStaticTextures[P, I, 1].Tex; + + { texture for second screen } + { we only change color for statics with playercolor + and with Texture type colorized + also we don't need to swap for one player position } + if (P <> 1) and + (Theme.Score.PlayerStatic[P, I].Typ = Texture_Type_Colorized) and + (Length(Theme.Score.PlayerStatic[P, I].Color) >= 2) and + (copy(Theme.Score.PlayerStatic[P, I].Color, 1, 2) = 'P' + IntToStr(PlayerNum)) then + begin + // get the color + Color := Theme.Score.PlayerStatic[P, I].Color; + Color[2] := IntToStr(PlayerNum2)[1]; + LoadColor(R, G, B, Color); + + with Theme.Score.PlayerStatic[P, I] do + PlayerStaticTextures[P, I, 2].Tex := Texture.GetTexture(Skin.GetTextureFileName(Tex), Typ, RGBFloatToInt(R, G, B)); + + PlayerStaticTextures[P, I, 2].Tex.X := Statics[PlayerStatic[P, I]].Texture.X; + PlayerStaticTextures[P, I, 2].Tex.Y := Statics[PlayerStatic[P, I]].Texture.Y; + PlayerStaticTextures[P, I, 2].Tex.W := Statics[PlayerStatic[P, I]].Texture.W; + PlayerStaticTextures[P, I, 2].Tex.H := Statics[PlayerStatic[P, I]].Texture.H; + end; + end; + end; + + { load swap textures for boxes } + for P := low(PlayerBoxTextures) to High(PlayerBoxTextures) do + begin + { get the players that actually are on this position } + case P of + 1: begin + PlayerNum := 1; + PlayerNum2 := 1; + end; + + 2, 3: begin + PlayerNum := P - 1; + PlayerNum2 := PlayerNum + 2; + end; + + 4..6: begin + PlayerNum := P - 3; + PlayerNum2 := PlayerNum + 3; + end; + end; + + for I := 0 to High(PlayerBoxTextures[P]) do + begin + case I of + 0: begin + StaticNum := StaticBoxLightest[P]; + ThemeStatic := Theme.Score.StaticBoxLightest[P]; + end; + 1: begin + StaticNum := StaticBoxLight[P]; + ThemeStatic := Theme.Score.StaticBoxLight[P]; + end; + 2: begin + StaticNum := StaticBoxDark[P]; + ThemeStatic := Theme.Score.StaticBoxDark[P]; + end; + end; + // copy current statics texture to texture for screen 1 + PlayerBoxTextures[P, I, 1].Tex := Statics[StaticNum].Texture; + + // fallback to first screen texture for 2nd screen + PlayerBoxTextures[P, I, 2].Tex := PlayerBoxTextures[P, I, 1].Tex; + + { texture for second screen } + { we only change color for statics with playercolor + and with Texture type colorized + also we don't need to swap for one player position } + if (P <> 1) and + (ThemeStatic.Typ = Texture_Type_Colorized) and + (Length(ThemeStatic.Color) >= 2) and + (copy(ThemeStatic.Color, 1, 2) = 'P' + IntToStr(PlayerNum)) then + begin + // get the color + Color := ThemeStatic.Color; + Color[2] := IntToStr(PlayerNum2)[1]; + LoadColor(R, G, B, Color); + + with ThemeStatic do + PlayerBoxTextures[P, I, 2].Tex := Texture.GetTexture(Skin.GetTextureFileName(Tex), Typ, RGBFloatToInt(R, G, B)); + + PlayerBoxTextures[P, I, 2].Tex.X := Statics[StaticNum].Texture.X; + PlayerBoxTextures[P, I, 2].Tex.Y := Statics[StaticNum].Texture.Y; + PlayerBoxTextures[P, I, 2].Tex.W := Statics[StaticNum].Texture.W; + PlayerBoxTextures[P, I, 2].Tex.H := Statics[StaticNum].Texture.H; + end; + end; + end; + end; +end; + +procedure TScreenScore.SwapToScreen(Screen: integer); + var + P, I: integer; +begin + { if screens = 2 and playerplay <= 3 the 2nd screen shows the + textures of screen 1 } + if (PlayersPlay <= 3) and (Screen = 2) then + Screen := 1; + + { set correct box textures } + for I := 0 to High(PlayerPositionMap) do + begin + if (PlayerPositionMap[I].Position > 0) and ((ScreenAct = PlayerPositionMap[I].Screen) or (PlayerPositionMap[I].BothScreens)) then + begin + // we just set the texture specific stuff + // so we don't overwrite e.g. width and height + with Statics[StaticPlayerIdBox[PlayerPositionMap[I].Position]].Texture do + begin + TexNum := aPlayerScoreScreenTextures[I+1].Player_Id_Box.TexNum; + TexW := aPlayerScoreScreenTextures[I+1].Player_Id_Box.TexW; + TexH := aPlayerScoreScreenTextures[I+1].Player_Id_Box.TexH; + end; + end; + end; + + if (Screens = 2) then + begin + { to keep it simple we just swap all statics, not just the shown ones } + for P := Low(PlayerStatic) to High(PlayerStatic) do + for I := 0 to High(PlayerStatic[P]) do + begin + Statics[PlayerStatic[P, I]].Texture := PlayerStaticTextures[P, I, Screen].Tex; + end; + + { box statics } + for P := Low(PlayerStatic) to High(PlayerStatic) do + begin + Statics[StaticBoxLightest[P]].Texture := PlayerBoxTextures[P, 0, Screen].Tex; + Statics[StaticBoxLight[P]].Texture := PlayerBoxTextures[P, 1, Screen].Tex; + Statics[StaticBoxDark[P]].Texture := PlayerBoxTextures[P, 2, Screen].Tex; + end; end; end; @@ -224,6 +463,8 @@ begin for Counter := 0 to High(Theme.Score.PlayerStatic[Player]) do PlayerStatic[Player, Counter] := AddStatic(Theme.Score.PlayerStatic[Player, Counter]); + + for Counter := 0 to High(Theme.Score.PlayerTexts[Player]) do PlayerTexts[Player, Counter] := AddText(Theme.Score.PlayerTexts[Player, Counter]); @@ -247,6 +488,7 @@ begin StaticBackLevelRound[Player] := AddStatic(Theme.Score.StaticBackLevelRound[Player]); StaticLevel[Player] := AddStatic(Theme.Score.StaticLevel[Player]); StaticLevelRound[Player] := AddStatic(Theme.Score.StaticLevelRound[Player]); + StaticPlayerIdBox[Player] := AddStatic(Theme.Score.StaticPlayerIdBox[Player]); //textures aPlayerScoreScreenTextures[Player].Score_NoteBarLevel_Dark := Tex_Score_NoteBarLevel_Dark[Player]; @@ -257,25 +499,18 @@ begin aPlayerScoreScreenTextures[Player].Score_NoteBarLevel_Lightest := Tex_Score_NoteBarLevel_Lightest[Player]; aPlayerScoreScreenTextures[Player].Score_NoteBarRound_Lightest := Tex_Score_NoteBarRound_Lightest[Player]; + aPlayerScoreScreenTextures[Player].Player_Id_Box := Texture.GetTexture(Skin.GetTextureFileName('PlayerIDBox0' + IntToStr(Player)), Texture_Type_Transparent); end; + LoadSwapTextures; end; -procedure TScreenScore.onShow; -var - P: integer; // player - I: integer; - V: array[1..6] of boolean; // visibility array - +procedure TScreenScore.MapPlayersToPosition; + var + ArrayStartModifier: integer; + PlayersPerScreen: integer; + I: integer; begin - -{** - * Turn backgroundmusic on - *} - SoundLib.StartBgMusic; - - inherited; - // all statics / texts are loaded at start - so that we have them all even if we change the amount of players // To show the corrects statics / text from the them, we simply modify the start of the according arrays // 1 Player -> Player[0].Score (The score for one player starts at 0) @@ -285,21 +520,122 @@ begin // 3 Player -> Player[0..5].Score // -> Statics[4..6] case PlayersPlay of - 1: ArrayStartModifier := 0; - 2, 4: ArrayStartModifier := 1; - 3, 6: ArrayStartModifier := 3; + 1: ArrayStartModifier := 1; + 2, 4: ArrayStartModifier := 2; + 3, 6: ArrayStartModifier := 4; else ArrayStartModifier := 0; //this should never happen end; + if (PlayersPlay <= 3) then + PlayersPerScreen := PlayersPlay + else + PlayersPerScreen := PlayersPlay div 2; + + SetLength(PlayerPositionMap, PlayersPlay); + + // actually map players to positions + for I := 0 to PlayersPlay - 1 do + begin + PlayerPositionMap[I].Screen := (I div PlayersPerScreen) + 1; + if (PlayerPositionMap[I].Screen > Screens) then + PlayerPositionMap[I].Position := 0 + else + PlayerPositionMap[I].Position := ArrayStartModifier + (I mod PlayersPerScreen); + PlayerPositionMap[I].BothScreens := (PlayersPlay <= 3) and (Screens > 1); + end; +end; + +procedure TScreenScore.UpdateAnimation; +var + CurrentTime: integer; + I: integer; +begin + CurrentTime := SDL_GetTicks(); + + if (ScreenAct = 1) and ShowFinish then + while (CurrentTime >= BarTime) do + begin + Inc(BarTime, BarRaiseSpeed); + + // We actually arise them in the right order, but we have to draw them in reverse order (golden -> phrase -> mainscore) + if (BarScore_EaseOut_Step < EaseOut_MaxSteps * 10) then + BarScore_EaseOut_Step:= BarScore_EaseOut_Step + 1 + + // PhrasenBonus + else if (BarPhrase_EaseOut_Step < EaseOut_MaxSteps * 10) then + BarPhrase_EaseOut_Step := BarPhrase_EaseOut_Step + 1 + + // GoldenNotebonus + else if (BarGolden_EaseOut_Step < EaseOut_MaxSteps * 10) then + BarGolden_EaseOut_Step := BarGolden_EaseOut_Step + 1 + + // rating icon + else + for I := 1 to PlayersPlay do + CalculateBouncing(I); + end; +end; + +procedure TScreenScore.DrawPlayerBars; + var + I: integer; +begin + for I := 0 to PlayersPlay-1 do + begin + if (PlayerPositionMap[I].Position > 0) and ((ScreenAct = PlayerPositionMap[I].Screen) or (PlayerPositionMap[I].BothScreens)) then + begin + if (BarScore_EaseOut_Step >= (EaseOut_MaxSteps * 10)) then + begin + if (BarPhrase_EaseOut_Step >= (EaseOut_MaxSteps * 10)) then + begin + // Draw golden score bar # + EaseBarIn(I + 1, sbtGolden); + EaseScoreIn(I + 1, sbtGolden); + end; + + // Draw phrase score bar # + EaseBarIn(I + 1, sbtLine); + EaseScoreIn(I + 1, sbtLine); + end; + + // Draw plain score bar # + EaseBarIn(I + 1, sbtScore); + EaseScoreIn(I + 1, sbtScore); + end; + end; +end; + +procedure TScreenScore.OnShow; +var + P: integer; // player + I: integer; + V: array[1..6] of boolean; // visibility array + +begin + + {** + * Turn backgroundmusic on + *} + SoundLib.StartBgMusic; + + inherited; + + MapPlayersToPosition; + for P := 1 to PlayersPlay do begin // data - aPlayerScoreScreenDatas[P].Bar_Y := Theme.Score.StaticBackLevel[P + ArrayStartModifier].Y; + aPlayerScoreScreenDatas[P].Bar_Y := Theme.Score.StaticBackLevel[PlayerPositionMap[P-1].Position].Y; // ratings aPlayerScoreScreenRatings[P].RateEaseStep := 1; aPlayerScoreScreenRatings[P].RateEaseValue := 20; + + // actual values + TextScore_ActualValue[P] := 0; + TextPhrase_ActualValue[P] := 0; + TextGolden_ActualValue[P] := 0; end; Text[TextArtist].Text := CurrentSong.Artist; @@ -349,9 +685,9 @@ begin Text[TextGoldenNotesScore[P]].Alpha := 0; Text[TextTotal[P]].Alpha := 0; Text[TextTotalScore[P]].Alpha := 0; - Static[StaticBoxLightest[P]].Texture.Alpha := 0; - Static[StaticBoxLight[P]].Texture.Alpha := 0; - Static[StaticBoxDark[P]].Texture.Alpha := 0; + Statics[StaticBoxLightest[P]].Texture.Alpha := 0; + Statics[StaticBoxLight[P]].Texture.Alpha := 0; + Statics[StaticBoxDark[P]].Texture.Alpha := 0; Text[TextNotes[P]].Visible := V[P]; Text[TextNotesScore[P]].Visible := V[P]; @@ -363,21 +699,27 @@ begin Text[TextTotalScore[P]].Visible := V[P]; for I := 0 to high(PlayerStatic[P]) do - Static[PlayerStatic[P, I]].Visible := V[P]; + Statics[PlayerStatic[P, I]].Visible := V[P]; for I := 0 to high(PlayerTexts[P]) do Text[PlayerTexts[P, I]].Visible := V[P]; - Static[StaticBoxLightest[P]].Visible := V[P]; - Static[StaticBoxLight[P]].Visible := V[P]; - Static[StaticBoxDark[P]].Visible := V[P]; + Statics[StaticBoxLightest[P]].Visible := V[P]; + Statics[StaticBoxLight[P]].Visible := V[P]; + Statics[StaticBoxDark[P]].Visible := V[P]; + + Statics[StaticPlayerIdBox[P]].Visible := V[P]; // we draw that on our own - Static[StaticBackLevel[P]].Visible := false; - Static[StaticBackLevelRound[P]].Visible := false; - Static[StaticLevel[P]].Visible := false; - Static[StaticLevelRound[P]].Visible := false; + Statics[StaticBackLevel[P]].Visible := false; + Statics[StaticBackLevelRound[P]].Visible := false; + Statics[StaticLevel[P]].Visible := false; + Statics[StaticLevelRound[P]].Visible := false; end; + + BarScore_EaseOut_Step := 1; + BarPhrase_EaseOut_Step := 1; + BarGolden_EaseOut_Step := 1; end; procedure TScreenScore.onShowFinish; @@ -391,17 +733,12 @@ begin TextGolden_ActualValue[index] := 0; end; - BarScore_EaseOut_Step := 1; - BarPhrase_EaseOut_Step := 1; - BarGolden_EaseOut_Step := 1; + BarTime := SDL_GetTicks(); end; function TScreenScore.Draw: boolean; var - CurrentTime: cardinal; PlayerCounter: integer; - PStart: integer; - PHigh: integer; begin {* player[0].ScoreInt := 7000; @@ -413,94 +750,33 @@ begin player[1].ScoreLineInt := 1100; player[1].ScoreGoldenInt := 900; player[1].ScoreTotalInt := 4500; -*} +//*} + // swap static textures to current screen ones + SwapToScreen(ScreenAct); //Draw the Background DrawBG; - //Calculate first and last Player on this Screen - if (PlayersPlay > 3) then - begin - case PlayersPlay of - 4: begin - PStart := 1 + ((ScreenAct-1) * 2); - PHigh := 2 + ((ScreenAct-1) * 2); - end; - - 6: begin - PStart := 1 + ((ScreenAct-1) * 3); - PHigh := 3 + ((ScreenAct-1) * 3); - end; - end; - end - else - begin - PStart := 1; - PHigh := PlayersPlay; - end; - // Let's start to arise the bars - CurrentTime := SDL_GetTicks(); - if((CurrentTime >= BarTime) and ShowFinish) then - begin - BarTime := CurrentTime + BarRaiseSpeed; - - for PlayerCounter := PStart to PHigh do - begin - // We actually arise them in the right order, but we have to draw them in reverse order (golden -> phrase -> mainscore) - if (BarScore_EaseOut_Step < EaseOut_MaxSteps * 10) then - BarScore_EaseOut_Step:= BarScore_EaseOut_Step + 1; - - // PhrasenBonus - if (BarScore_EaseOut_Step >= (EaseOut_MaxSteps * 10)) then - begin - if (BarPhrase_EaseOut_Step < EaseOut_MaxSteps * 10) then - BarPhrase_EaseOut_Step := BarPhrase_EaseOut_Step + 1; - - // GoldenNotebonus - if (BarPhrase_EaseOut_Step >= (EaseOut_MaxSteps * 10)) then - begin - if (BarGolden_EaseOut_Step < EaseOut_MaxSteps * 10) then - BarGolden_EaseOut_Step := BarGolden_EaseOut_Step + 1; - - // Draw golden score bar # - EaseBarIn(PlayerCounter, 'Golden'); - EaseScoreIn(PlayerCounter,'Golden'); - end; - - // Draw phrase score bar # - EaseBarIn(PlayerCounter, 'Line'); - EaseScoreIn(PlayerCounter,'Line'); - end; - - // Draw plain score bar # - EaseBarIn(PlayerCounter, 'Note'); - EaseScoreIn(PlayerCounter,'Note'); + UpdateAnimation; - if (PlayersPlay <= 3) then - //If we play w/ 3 or less players they fit in one screen - //so we don't have to swap the values of themeobjects - //on every draw - FillPlayerItems(PlayerCounter,'Funky'); - - end; + // we have to swap the themeobjects values on every draw + // to support dual screen + for PlayerCounter := 1 to PlayersPlay do + begin + FillPlayerItems(PlayerCounter); end; - if (PlayersPlay > 3) then - //more then 3 players don't fit the screen - //so we have to swap the themeobjects values on every draw - for PlayerCounter := PStart to PHigh do - begin - FillPlayerItems(PlayerCounter,'Funky'); - end; + if (ShowFinish) then + DrawPlayerBars; //Draw Theme Objects DrawFG; (* //todo: i need a clever method to draw statics with their z value - for I := 0 to Length(Static) - 1 do - Static[I].Draw; + for I := 0 to Length(Statics) - 1 do + Statics[I].Draw; for I := 0 to Length(Text) - 1 do Text[I].Draw; *) @@ -508,54 +784,48 @@ begin Result := true; end; -procedure TscreenScore.FillPlayerItems(PlayerNumber: integer; ScoreType: string); +procedure TscreenScore.FillPlayerItems(PlayerNumber: integer); var ThemeIndex: integer; begin - // todo: take the name from player[PlayerNumber].Name instead of the ini when this is done (mog) - Text[TextName[PlayerNumber + ArrayStartModifier]].Text := Ini.Name[PlayerNumber - 1]; - // end todo - - // We have to do this here because we use the same Theme Object - // for players on the first and second screen - case PlayersPlay of - 1, 2, 3: ThemeIndex := PlayerNumber + ArrayStartModifier; - 4: ThemeIndex := ((PlayerNumber-1) mod 2) + 1 + ArrayStartModifier; - 6: ThemeIndex := ((PlayerNumber-1) mod 3) + 1 + ArrayStartModifier; - end; - - //golden - Text[TextGoldenNotesScore[ThemeIndex]].Text := IntToStr(TextGolden_ActualValue[PlayerNumber]); - Text[TextGoldenNotesScore[ThemeIndex]].Alpha := (BarGolden_EaseOut_Step / 100); + ThemeIndex := PlayerPositionMap[PlayerNumber-1].Position; + if (ThemeIndex > 0) and ((ScreenAct = PlayerPositionMap[PlayerNumber-1].Screen) or (PlayerPositionMap[PlayerNumber-1].BothScreens)) then + begin + // todo: take the name from player[PlayerNumber].Name instead of the ini when this is done (mog) + Text[TextName[ThemeIndex]].Text := Ini.Name[PlayerNumber-1]; + // end todo - Static[StaticBoxLightest[ThemeIndex]].Texture.Alpha := (BarGolden_EaseOut_Step / 100); - Text[TextGoldenNotes[ThemeIndex]].Alpha := (BarGolden_EaseOut_Step / 100); + //golden + Text[TextGoldenNotesScore[ThemeIndex]].Text := IntToStr(TextGolden_ActualValue[PlayerNumber]); + Text[TextGoldenNotesScore[ThemeIndex]].Alpha := (BarGolden_EaseOut_Step / 100); - // line bonus - Text[TextLineBonusScore[ThemeIndex]].Text := IntToStr(TextPhrase_ActualValue[PlayerNumber]); - Text[TextLineBonusScore[ThemeIndex]].Alpha := (BarPhrase_EaseOut_Step / 100); + Statics[StaticBoxLightest[ThemeIndex]].Texture.Alpha := (BarGolden_EaseOut_Step / 100); + Text[TextGoldenNotes[ThemeIndex]].Alpha := (BarGolden_EaseOut_Step / 100); - Static[StaticBoxLight[ThemeIndex]].Texture.Alpha := (BarPhrase_EaseOut_Step / 100); - Text[TextLineBonus[ThemeIndex]].Alpha := (BarPhrase_EaseOut_Step / 100); + // line bonus + Text[TextLineBonusScore[ThemeIndex]].Text := IntToStr(TextPhrase_ActualValue[PlayerNumber]); + Text[TextLineBonusScore[ThemeIndex]].Alpha := (BarPhrase_EaseOut_Step / 100); - // plain score - Text[TextNotesScore[ThemeIndex]].Text := IntToStr(TextScore_ActualValue[PlayerNumber]); - Text[TextNotes[ThemeIndex]].Alpha := (BarScore_EaseOut_Step / 100); + Statics[StaticBoxLight[ThemeIndex]].Texture.Alpha := (BarPhrase_EaseOut_Step / 100); + Text[TextLineBonus[ThemeIndex]].Alpha := (BarPhrase_EaseOut_Step / 100); - Static[StaticBoxDark[ThemeIndex]].Texture.Alpha := (BarScore_EaseOut_Step / 100); - Text[TextNotesScore[ThemeIndex]].Alpha := (BarScore_EaseOut_Step / 100); + // plain score + Text[TextNotesScore[ThemeIndex]].Text := IntToStr(TextScore_ActualValue[PlayerNumber]); + Text[TextNotes[ThemeIndex]].Alpha := (BarScore_EaseOut_Step / 100); - // total score - Text[TextTotalScore[ThemeIndex]].Text := IntToStr(TextScore_ActualValue[PlayerNumber] + TextPhrase_ActualValue[PlayerNumber] + TextGolden_ActualValue[PlayerNumber]); - Text[TextTotalScore[ThemeIndex]].Alpha := (BarScore_EaseOut_Step / 100); + Statics[StaticBoxDark[ThemeIndex]].Texture.Alpha := (BarScore_EaseOut_Step / 100); + Text[TextNotesScore[ThemeIndex]].Alpha := (BarScore_EaseOut_Step / 100); - Text[TextTotal[ThemeIndex]].Alpha := (BarScore_EaseOut_Step / 100); + // total score + Text[TextTotalScore[ThemeIndex]].Text := IntToStr(TextScore_ActualValue[PlayerNumber] + TextPhrase_ActualValue[PlayerNumber] + TextGolden_ActualValue[PlayerNumber]); + Text[TextTotalScore[ThemeIndex]].Alpha := (BarScore_EaseOut_Step / 100); - Text[TextTotal[ThemeIndex]].Alpha := (BarScore_EaseOut_Step / 100); + Text[TextTotal[ThemeIndex]].Alpha := (BarScore_EaseOut_Step / 100); - if(BarGolden_EaseOut_Step = 100) then - begin - ShowRating(PlayerNumber); + if(BarGolden_EaseOut_Step = 100) then + begin + ShowRating(PlayerNumber); + end; end; end; @@ -564,68 +834,63 @@ var Rating: integer; ThemeIndex: integer; begin + ThemeIndex := PlayerPositionMap[PlayerNumber-1].Position; + if (ThemeIndex > 0) and ((ScreenAct = PlayerPositionMap[PlayerNumber-1].Screen) or (PlayerPositionMap[PlayerNumber-1].BothScreens)) then + begin + case (Player[PlayerNumber-1].ScoreTotalInt) of + 0..2009: + begin + Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_TONE_DEAF'); + Rating := 0; + end; + 2010..4009: + begin + Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_AMATEUR'); + Rating := 1; + end; + 4010..5009: + begin + Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_WANNABE'); + Rating := 2; + end; + 5010..6009: + begin + Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_HOPEFUL'); + Rating := 3; + end; + 6010..7509: + begin + Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_RISING_STAR'); + Rating := 4; + end; + 7510..8509: + begin + Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_LEAD_SINGER'); + Rating := 5; + end; + 8510..9009: + begin + Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_SUPERSTAR'); + Rating := 6; + end; + 9010..10000: + begin + Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_ULTRASTAR'); + Rating := 7; + end; + else + Rating := 0; // Cheata :P + end; - // We have to do this here because we use the same Theme Object - // for players on the first and second screen - case PlayersPlay of - 1, 2, 3: ThemeIndex := PlayerNumber + ArrayStartModifier; - 4: ThemeIndex := ((PlayerNumber-1) mod 2) + 1 + ArrayStartModifier; - 6: ThemeIndex := ((PlayerNumber-1) mod 3) + 1 + ArrayStartModifier; - end; - - case (Player[PlayerNumber-1].ScoreTotalInt) of - 0..2009: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_TONE_DEAF'); - Rating := 0; - end; - 2010..4009: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_AMATEUR'); - Rating := 1; - end; - 4010..5009: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_WANNABE'); - Rating := 2; - end; - 5010..6009: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_HOPEFUL'); - Rating := 3; - end; - 6010..7509: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_RISING_STAR'); - Rating := 4; - end; - 7510..8509: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_LEAD_SINGER'); - Rating := 5; - end; - 8510..9009: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_SUPERSTAR'); - Rating := 6; - end; - 9010..10000: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_ULTRASTAR'); - Rating := 7; - end; - else - Rating := 0; // Cheata :P - end; + //todo: this could break if the width is not given, for instance when there's a skin with no picture for ratings + if ( Theme.Score.StaticRatings[ThemeIndex].W > 0 ) and ( aPlayerScoreScreenRatings[PlayerNumber].RateEaseValue > 0 ) then + begin + Text[TextScore[ThemeIndex]].Alpha := aPlayerScoreScreenRatings[PlayerNumber].RateEaseValue / Theme.Score.StaticRatings[ThemeIndex].W; + end; + // end todo - //todo: this could break if the width is not given, for instance when there's a skin with no picture for ratings - if ( Theme.Score.StaticRatings[ThemeIndex].W > 0 ) and ( aPlayerScoreScreenRatings[PlayerNumber].RateEaseValue > 0 ) then - begin - Text[TextScore[ThemeIndex]].Alpha := aPlayerScoreScreenRatings[PlayerNumber].RateEaseValue / Theme.Score.StaticRatings[ThemeIndex].W; + DrawRating(PlayerNumber, Rating); end; - // end todo - - DrawRating(PlayerNumber, Rating); end; procedure TscreenScore.DrawRating(PlayerNumber: integer; Rating: integer); @@ -633,12 +898,12 @@ var Posx: real; Posy: real; Width: real; + ThemeIndex: integer; begin + ThemeIndex := PlayerPositionMap[PlayerNumber-1].Position; - CalculateBouncing(PlayerNumber); - - PosX := Theme.Score.StaticRatings[PlayerNumber + ArrayStartModifier].X + (Theme.Score.StaticRatings[PlayerNumber + ArrayStartModifier].W * 0.5); - PosY := Theme.Score.StaticRatings[PlayerNumber + ArrayStartModifier].Y + (Theme.Score.StaticRatings[PlayerNumber + ArrayStartModifier].H * 0.5); ; + PosX := Theme.Score.StaticRatings[ThemeIndex].X + (Theme.Score.StaticRatings[ThemeIndex].W * 0.5); + PosY := Theme.Score.StaticRatings[ThemeIndex].Y + (Theme.Score.StaticRatings[ThemeIndex].H * 0.5); ; Width := aPlayerScoreScreenRatings[PlayerNumber].RateEaseValue/2; @@ -661,14 +926,16 @@ end; function TscreenScore.CalculateBouncing(PlayerNumber: integer): real; var - ReturnValue: real; p, s: real; RaiseStep, MaxVal: real; EaseOut_Step: integer; + ThemeIndex: integer; begin + ThemeIndex := PlayerPositionMap[PlayerNumber-1].Position; + EaseOut_Step := aPlayerScoreScreenRatings[PlayerNumber].RateEaseStep; - MaxVal := Theme.Score.StaticRatings[PlayerNumber + ArrayStartModifier].W; + MaxVal := Theme.Score.StaticRatings[ThemeIndex].W; RaiseStep := EaseOut_Step; @@ -677,23 +944,21 @@ begin if (RaiseStep = 1) then begin - ReturnValue := MaxVal; + Result := MaxVal; end else begin p := MaxVal * 0.4; s := p/(2*PI) * arcsin (1); - ReturnValue := MaxVal * power(2,-5 * RaiseStep) * sin( (RaiseStep * MaxVal - s) * (2 * PI) / p) + MaxVal; + Result := MaxVal * power(2,-5 * RaiseStep) * sin( (RaiseStep * MaxVal - s) * (2 * PI) / p) + MaxVal; inc(aPlayerScoreScreenRatings[PlayerNumber].RateEaseStep); - aPlayerScoreScreenRatings[PlayerNumber].RateEaseValue := ReturnValue; + aPlayerScoreScreenRatings[PlayerNumber].RateEaseValue := Result; end; - - Result := ReturnValue; end; -procedure TscreenScore.EaseBarIn(PlayerNumber: integer; BarType: string); +procedure TscreenScore.EaseBarIn(PlayerNumber: integer; BarType: TScoreBarType); const RaiseSmoothness: integer = 100; var @@ -706,34 +971,31 @@ var lTmp: real; Score: integer; + ThemeIndex: integer; begin - MaxHeight := Theme.Score.StaticBackLevel[PlayerNumber + ArrayStartModifier].H; + ThemeIndex := PlayerPositionMap[PlayerNumber-1].Position; + MaxHeight := Theme.Score.StaticBackLevel[ThemeIndex].H; // let's get the points according to the bar we draw // score array starts at 0, which means the score for player 1 is in score[0] // EaseOut_Step is the actual step in the raising process, like the 20iest step of EaseOut_MaxSteps - if (BarType = 'Note') then + if (BarType = sbtScore) then begin Score := Player[PlayerNumber - 1].ScoreInt; RaiseStep := BarScore_EaseOut_Step; - BarStartPosY := Theme.Score.StaticBackLevel[PlayerNumber + ArrayStartModifier].Y + MaxHeight; + BarStartPosY := Theme.Score.StaticBackLevel[ThemeIndex].Y + MaxHeight; end - else if (BarType = 'Line') then + else if (BarType = sbtLine) then begin Score := Player[PlayerNumber - 1].ScoreLineInt; RaiseStep := BarPhrase_EaseOut_Step; - BarStartPosY := Theme.Score.StaticBackLevel[PlayerNumber + ArrayStartModifier].Y - aPlayerScoreScreenDatas[PlayerNumber].BarScore_ActualHeight + MaxHeight; + BarStartPosY := Theme.Score.StaticBackLevel[ThemeIndex].Y - aPlayerScoreScreenDatas[PlayerNumber].BarScore_ActualHeight + MaxHeight; end - else if (BarType = 'Golden') then + else if (BarType = sbtGolden) then begin Score := Player[PlayerNumber - 1].ScoreGoldenInt; RaiseStep := BarGolden_EaseOut_Step; - BarStartPosY := Theme.Score.StaticBackLevel[PlayerNumber + ArrayStartModifier].Y - aPlayerScoreScreenDatas[PlayerNumber].BarScore_ActualHeight - aPlayerScoreScreenDatas[PlayerNumber].BarLine_ActualHeight + MaxHeight; - end - else - begin - Log.LogCritical('Unknown bar-type: ' + BarType, 'TScreenScore.EaseBarIn'); - Exit; // suppress warnings + BarStartPosY := Theme.Score.StaticBackLevel[ThemeIndex].Y - aPlayerScoreScreenDatas[PlayerNumber].BarScore_ActualHeight - aPlayerScoreScreenDatas[PlayerNumber].BarLine_ActualHeight + MaxHeight; end; // the height dependend of the score @@ -758,31 +1020,34 @@ begin DrawBar(BarType, PlayerNumber, BarStartPosY, NewHeight); - if (BarType = 'Note') then + if (BarType = sbtScore) then aPlayerScoreScreenDatas[PlayerNumber].BarScore_ActualHeight := NewHeight - else if (BarType = 'Line') then + else if (BarType = sbtLine) then aPlayerScoreScreenDatas[PlayerNumber].BarLine_ActualHeight := NewHeight - else if (BarType = 'Golden') then + else if (BarType = sbtGolden) then aPlayerScoreScreenDatas[PlayerNumber].BarGolden_ActualHeight := NewHeight; end; -procedure TscreenScore.DrawBar(BarType: string; PlayerNumber: integer; BarStartPosY: single; NewHeight: real); +procedure TscreenScore.DrawBar(BarType: TScoreBarType; PlayerNumber: integer; BarStartPosY: single; NewHeight: real); var Width: real; BarStartPosX: real; + ThemeIndex: integer; begin + ThemeIndex := PlayerPositionMap[PlayerNumber-1].Position; + // this is solely for better readability of the drawing - Width := Theme.Score.StaticBackLevel[PlayerNumber + ArrayStartModifier].W; - BarStartPosX := Theme.Score.StaticBackLevel[PlayerNumber + ArrayStartModifier].X; + Width := Theme.Score.StaticBackLevel[ThemeIndex].W; + BarStartPosX := Theme.Score.StaticBackLevel[ThemeIndex].X; glColor4f(1, 1, 1, 1); // set the texture for the bar - if (BarType = 'Note') then + if (BarType = sbtScore) then glBindTexture(GL_TEXTURE_2D, aPlayerScoreScreenTextures[PlayerNumber].Score_NoteBarLevel_Dark.TexNum); - if (BarType = 'Line') then + if (BarType = sbtLine) then glBindTexture(GL_TEXTURE_2D, aPlayerScoreScreenTextures[PlayerNumber].Score_NoteBarLevel_Light.TexNum); - if (BarType = 'Golden') then + if (BarType = sbtGolden) then glBindTexture(GL_TEXTURE_2D, aPlayerScoreScreenTextures[PlayerNumber].Score_NoteBarLevel_Lightest.TexNum); //draw it @@ -801,11 +1066,11 @@ begin glDisable(GL_TEXTURE_2d); //the round thing on top - if (BarType = 'Note') then + if (BarType = sbtScore) then glBindTexture(GL_TEXTURE_2D, aPlayerScoreScreenTextures[PlayerNumber].Score_NoteBarRound_Dark.TexNum); - if (BarType = 'Line') then + if (BarType = sbtLine) then glBindTexture(GL_TEXTURE_2D, aPlayerScoreScreenTextures[PlayerNumber].Score_NoteBarRound_Light.TexNum); - if (BarType = 'Golden') then + if (BarType = sbtGolden) then glBindTexture(GL_TEXTURE_2D, aPlayerScoreScreenTextures[PlayerNumber].Score_NoteBarRound_Lightest.TexNum); glEnable(GL_TEXTURE_2D); @@ -813,8 +1078,8 @@ begin glEnable(GL_BLEND); glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex3f(BarStartPosX, (BarStartPosY - Static[StaticLevelRound[PlayerNumber + ArrayStartModifier]].Texture.h) - NewHeight, ZBars); - glTexCoord2f(1, 0); glVertex3f(BarStartPosX + Width, (BarStartPosY - Static[StaticLevelRound[PlayerNumber + ArrayStartModifier]].Texture.h) - NewHeight, ZBars); + glTexCoord2f(0, 0); glVertex3f(BarStartPosX, (BarStartPosY - Statics[StaticLevelRound[ThemeIndex]].Texture.h) - NewHeight, ZBars); + glTexCoord2f(1, 0); glVertex3f(BarStartPosX + Width, (BarStartPosY - Statics[StaticLevelRound[ThemeIndex]].Texture.h) - NewHeight, ZBars); glTexCoord2f(1, 1); glVertex3f(BarStartPosX + Width, BarStartPosY - NewHeight, ZBars); glTexCoord2f(0, 1); glVertex3f(BarStartPosX, BarStartPosY - NewHeight, ZBars); glEnd; @@ -823,7 +1088,7 @@ begin glDisable(GL_TEXTURE_2d); end; -procedure TScreenScore.EaseScoreIn(PlayerNumber: integer; ScoreType: string); +procedure TScreenScore.EaseScoreIn(PlayerNumber: integer; ScoreType: TScoreBarType); const RaiseSmoothness: integer = 100; var @@ -833,19 +1098,19 @@ var EaseOut_Step: real; ActualScoreValue: integer; begin - if (ScoreType = 'Note') then + if (ScoreType = sbtScore) then begin EaseOut_Step := BarScore_EaseOut_Step; ActualScoreValue := TextScore_ActualValue[PlayerNumber]; ScoreReached := Player[PlayerNumber-1].ScoreInt; end; - if (ScoreType = 'Line') then + if (ScoreType = sbtLine) then begin EaseOut_Step := BarPhrase_EaseOut_Step; ActualScoreValue := TextPhrase_ActualValue[PlayerNumber]; ScoreReached := Player[PlayerNumber-1].ScoreLineInt; end; - if (ScoreType = 'Golden') then + if (ScoreType = sbtGolden) then begin EaseOut_Step := BarGolden_EaseOut_Step; ActualScoreValue := TextGolden_ActualValue[PlayerNumber]; @@ -866,21 +1131,21 @@ begin if ( lTmpA > 0 ) and ( RaiseSmoothness > 0 ) then begin - if (ScoreType = 'Note') then + if (ScoreType = sbtScore) then TextScore_ActualValue[PlayerNumber] := floor( lTmpA / RaiseSmoothness); - if (ScoreType = 'Line') then + if (ScoreType = sbtLine) then TextPhrase_ActualValue[PlayerNumber] := floor( lTmpA / RaiseSmoothness); - if (ScoreType = 'Golden') then + if (ScoreType = sbtGolden) then TextGolden_ActualValue[PlayerNumber] := floor( lTmpA / RaiseSmoothness); end; end else begin - if (ScoreType = 'Note') then + if (ScoreType = sbtScore) then TextScore_ActualValue[PlayerNumber] := ScoreReached; - if (ScoreType = 'Line') then + if (ScoreType = sbtLine) then TextPhrase_ActualValue[PlayerNumber] := ScoreReached; - if (ScoreType = 'Golden') then + if (ScoreType = sbtGolden) then TextGolden_ActualValue[PlayerNumber] := ScoreReached; end; end; diff --git a/cmake/src/screens/UScreenSing.pas b/cmake/src/screens/UScreenSing.pas index ae75c74d..233f1e38 100644 --- a/cmake/src/screens/UScreenSing.pas +++ b/cmake/src/screens/UScreenSing.pas @@ -35,9 +35,9 @@ interface uses SysUtils, - gl, SDL, TextGL, + gl, UFiles, UGraphicClasses, UIni, @@ -49,19 +49,30 @@ uses USongs, UTexture, UThemes, - UTime; + UPath, + UTime, + UHookableEvent; type TLyricsSyncSource = class(TSyncSource) function GetClock(): real; override; end; + TMusicSyncSource = class(TSyncSource) + function GetClock(): real; override; + end; + type TScreenSing = class(TMenu) + private + fShowVisualization: boolean; + fCurrentVideo: IVideo; + fVideoClip: IVideo; + fLyricsSync: TLyricsSyncSource; + fMusicSync: TMusicSyncSource; protected - VideoLoaded: boolean; - Paused: boolean; // pause mod - LyricsSync: TLyricsSyncSource; + eSongLoaded: THookableEvent; //< event is called after lyrics of a song are loaded on OnShow + Paused: boolean; //pause Mod NumEmptySentences: integer; public // timebar fields @@ -97,15 +108,28 @@ type // score manager: Scores: TSingScores; - fShowVisualization: boolean; - fCurrentVideoPlaybackEngine: IVideoPlayback; + //the song was sung to the end + SungToEnd: boolean; + + // some settings to be set by plugins + Settings: record + Finish: Boolean; //< if true, screen will finish on next draw + + LyricsVisible: Boolean; //< shows or hides lyrics + NotesVisible: Integer; //< if bit[playernum] is set the notes for the specified player are visible. By default all players notes are visible + + PlayerEnabled: Integer; //< defines whether a player can score atm + end; + procedure ClearSettings; + procedure ApplySettings; //< applies changes of settings record + procedure EndSong; constructor Create; override; - procedure onShow; override; - procedure onShowFinish; override; - procedure onHide; override; + procedure OnShow; override; + procedure OnShowFinish; override; + procedure OnHide; override; - function ParseInput(PressedKey: cardinal; CharCode: widechar; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; function Draw: boolean; override; @@ -127,20 +151,22 @@ uses UNote, URecord, USong, - UDisplay; + UDisplay, + UParty, + UUnicodeUtils; // method for input parsing. if false is returned, getnextwindow // should be checked to know the next window to load; -function TScreenSing.ParseInput(PressedKey: cardinal; CharCode: widechar; +function TScreenSing.ParseInput(PressedKey: Cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // key down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin // when not ask before exit then finish now if (Ini.AskbeforeDel <> 1) then @@ -152,21 +178,22 @@ begin Result := false; Exit; end; - 'V': // show visualization + Ord('V'): // show visualization begin fShowVisualization := not fShowVisualization; if fShowVisualization then - fCurrentVideoPlaybackEngine := Visualization + begin + fCurrentVideo := Visualization.Open(PATH_NONE); + fCurrentVideo.play; + end else - fCurrentVideoPlaybackEngine := VideoPlayback; - - if fShowVisualization then - fCurrentVideoPlaybackEngine.play; - + begin + fCurrentVideo := fVideoClip; + end; Exit; end; - 'P': + Ord('P'): begin Pause; Exit; @@ -194,7 +221,7 @@ begin SDLK_TAB: // change visualization preset begin if fShowVisualization then - fCurrentVideoPlaybackEngine.Position := now; // move to a random position + fCurrentVideo.Position := now; // move to a random position end; SDLK_RETURN: @@ -228,22 +255,20 @@ begin AudioPlayback.Pause; // pause video - if (CurrentSong.Video <> '') and FileExists(CurrentSong.Path + - CurrentSong.Video) then - fCurrentVideoPlaybackEngine.Pause; + if (fCurrentVideo <> nil) then + fCurrentVideo.Pause; end else // disable pause begin - LyricsState.Resume(); + LyricsState.Start(); // play music AudioPlayback.Play; // video - if (CurrentSong.Video <> '') and FileExists(CurrentSong.Path + - CurrentSong.Video) then - fCurrentVideoPlaybackEngine.Pause; + if (fCurrentVideo <> nil) then + fCurrentVideo.Pause; Paused := false; end; @@ -259,7 +284,7 @@ begin fShowVisualization := false; - fCurrentVideoPlaybackEngine := VideoPlayback; + fCurrentVideo := nil; // create score class Scores := TSingScores.Create; @@ -298,16 +323,21 @@ begin StaticPausePopup := AddStatic(Theme.Sing.PausePopUp); // <note> pausepopup is not visibile at the beginning </note> - Static[StaticPausePopup].Visible := false; + Statics[StaticPausePopup].Visible := false; Lyrics := TLyricEngine.Create( Theme.LyricBar.UpperX, Theme.LyricBar.UpperY, Theme.LyricBar.UpperW, Theme.LyricBar.UpperH, Theme.LyricBar.LowerX, Theme.LyricBar.LowerY, Theme.LyricBar.LowerW, Theme.LyricBar.LowerH); - LyricsSync := TLyricsSyncSource.Create(); + fLyricsSync := TLyricsSyncSource.Create(); + fMusicSync := TMusicSyncSource.Create(); + + eSongLoaded := THookableEvent.Create('ScreenSing.SongLoaded'); + + ClearSettings; end; -procedure TScreenSing.onShow; +procedure TScreenSing.OnShow; var Index: integer; V1: boolean; @@ -317,16 +347,21 @@ var V2M: boolean; V3R: boolean; Color: TRGB; - + VideoFile, BgFile: IPath; success: boolean; begin inherited; - Log.LogStatus('Begin', 'onShow'); + Log.LogStatus('Begin', 'OnShow'); FadeOut := false; - // reset video playback engine, to play video clip ... - fCurrentVideoPlaybackEngine := VideoPlayback; + //the song was sung to the end + SungToEnd := false; + ClearSettings; + Party.CallBeforeSing; + + // reset video playback engine + fCurrentVideo := nil; // setup score manager Scores.ClearPlayers; // clear old player values @@ -395,24 +430,24 @@ begin end; // this one is shown in 1P mode - Static[StaticP1].Visible := V1; + Statics[StaticP1].Visible := V1; Text[TextP1].Visible := V1; // this one is shown in 2/4P mode - Static[StaticP1TwoP].Visible := V1TwoP; + Statics[StaticP1TwoP].Visible := V1TwoP; Text[TextP1TwoP].Visible := V1TwoP; - Static[StaticP2R].Visible := V2R; + Statics[StaticP2R].Visible := V2R; Text[TextP2R].Visible := V2R; // this one is shown in 3/6P mode - Static[StaticP1ThreeP].Visible := V1ThreeP; + Statics[StaticP1ThreeP].Visible := V1ThreeP; Text[TextP1ThreeP].Visible := V1ThreeP; - Static[StaticP2M].Visible := V2M; + Statics[StaticP2M].Visible := V2M; Text[TextP2M].Visible := V2M; - Static[StaticP3R].Visible := V3R; + Statics[StaticP3R].Visible := V3R; Text[TextP3R].Visible := V3R; // FIXME: sets path and filename to '' @@ -423,7 +458,7 @@ begin // FIXME: bad style, put the try-except into loadsong() and not here try // check if file is xml - if copy(CurrentSong.FileName, length(CurrentSong.FileName) - 3, 4) = '.xml' then + if CurrentSong.FileName.GetExtension.ToUTF8 = '.xml' then success := CurrentSong.LoadXMLSong() else success := CurrentSong.LoadSong(); @@ -433,8 +468,8 @@ begin if (not success) then begin - // error loading song -> go back to song screen and show some error message - FadeTo(@ScreenSong); + // error loading song -> go back to previous screen and show some error message + Display.AbortScreenChange; // select new song in party mode if ScreenSong.Mode = smPartyMode then ScreenSong.SelectRandomSong(); @@ -447,10 +482,6 @@ begin Exit; end; - // reset video playback engine, to play video clip ... - fCurrentVideoPlaybackEngine.Close; - fCurrentVideoPlaybackEngine := VideoPlayback; - {* * == Background == * We have four types of backgrounds: @@ -465,32 +496,34 @@ begin {* * set background to: video *} - VideoLoaded := false; fShowVisualization := false; - if (CurrentSong.Video <> '') and FileExists(CurrentSong.Path + CurrentSong.Video) then + VideoFile := CurrentSong.Path.Append(CurrentSong.Video); + if (CurrentSong.Video.IsSet) and VideoFile.IsFile then begin - if (fCurrentVideoPlaybackEngine.Open(CurrentSong.Path + CurrentSong.Video)) then + fVideoClip := VideoPlayback.Open(VideoFile); + fCurrentVideo := fVideoClip; + if (fVideoClip <> nil) then begin fShowVisualization := false; - fCurrentVideoPlaybackEngine := VideoPlayback; - fCurrentVideoPlaybackEngine.Position := CurrentSong.VideoGAP + CurrentSong.Start; - fCurrentVideoPlaybackEngine.Play; - VideoLoaded := true; + fCurrentVideo.Position := CurrentSong.VideoGAP + CurrentSong.Start; + fCurrentVideo.Play; end; end; {* * set background to: picture *} - if (CurrentSong.Background <> '') and (VideoLoaded = false) + if (CurrentSong.Background.IsSet) and (fVideoClip = nil) and (TVisualizerOption(Ini.VisualizerOption) = voOff) then + begin + BgFile := CurrentSong.Path.Append(CurrentSong.Background); try - Tex_Background := Texture.LoadTexture(CurrentSong.Path + CurrentSong.Background); + Tex_Background := Texture.LoadTexture(BgFile); except - Log.LogError('Background could not be loaded: ' + CurrentSong.Path + - CurrentSong.Background); + Log.LogError('Background could not be loaded: ' + BgFile.ToNative); Tex_Background.TexNum := 0; end + end else begin Tex_Background.TexNum := 0; @@ -502,21 +535,21 @@ begin if (TVisualizerOption(Ini.VisualizerOption) in [voOn]) then begin fShowVisualization := true; - fCurrentVideoPlaybackEngine := Visualization; - if (fCurrentVideoPlaybackEngine <> nil) then - fCurrentVideoPlaybackEngine.Play; + fCurrentVideo := Visualization.Open(PATH_NONE); + if (fCurrentVideo <> nil) then + fCurrentVideo.Play; end; {* * set background to: visualization (Videos are still shown) *} if ((TVisualizerOption(Ini.VisualizerOption) in [voWhenNoVideo]) and - (VideoLoaded = false)) then + (fVideoClip = nil)) then begin fShowVisualization := true; - fCurrentVideoPlaybackEngine := Visualization; - if (fCurrentVideoPlaybackEngine <> nil) then - fCurrentVideoPlaybackEngine.Play; + fCurrentVideo := Visualization.Open(PATH_NONE); + if (fCurrentVideo <> nil) then + fCurrentVideo.Play; end; // prepare lyrics timer @@ -529,12 +562,6 @@ begin LyricsState.TotalTime := AudioPlayback.Length; LyricsState.UpdateBeats(); - // prepare music - AudioPlayback.Stop(); - AudioPlayback.Position := CurrentSong.Start; - // synchronize music to the lyrics - AudioPlayback.SetSyncSource(LyricsSync); - // prepare and start voice-capture AudioInput.CaptureStart; @@ -564,7 +591,7 @@ begin case Ini.LyricsFont of 0: // normal fonts begin - Lyrics.FontStyle := 0; + Lyrics.FontStyle := ftNormal; Lyrics.LineColor_en.R := Skin_FontR; Lyrics.LineColor_en.G := Skin_FontG; @@ -581,9 +608,12 @@ begin Lyrics.LineColor_act.B := 0.8; Lyrics.LineColor_act.A := 1; end; - 1, 2: // outline fonts (is TScalableOutlineFont) + 1, 2: // outline fonts begin - Lyrics.FontStyle := Ini.LyricsFont + 1; + if (Ini.LyricsFont = 1) then + Lyrics.FontStyle := ftOutline1 + else + Lyrics.FontStyle := ftOutline2; Lyrics.LineColor_en.R := 0.75; Lyrics.LineColor_en.G := 0.75; @@ -622,16 +652,37 @@ begin if Lines[0].Line[Index].TotalNotes = 0 then Inc(NumEmptySentences); - Log.LogStatus('End', 'onShow'); + eSongLoaded.CallHookChain(False); + + Log.LogStatus('End', 'OnShow'); end; procedure TScreenSing.onShowFinish; begin // hide cursor on singscreen show Display.SetCursor; - + + // prepare music + // Important: AudioPlayback must not be initialized in onShow() as TScreenSong + // uses stops AudioPlayback in onHide() which interferes with TScreenSings onShow. + AudioPlayback.Open(CurrentSong.Path.Append(CurrentSong.Mp3)); + AudioPlayback.SetVolume(1.0); + AudioPlayback.Position := CurrentSong.Start; + + // synchronize music + if (Ini.SyncTo = Ord(stLyrics)) then + AudioPlayback.SetSyncSource(fLyricsSync) + else + AudioPlayback.SetSyncSource(nil); + + // synchronize lyrics (do not set this before AudioPlayback is initialized) + if (Ini.SyncTo = Ord(stMusic)) then + LyricsState.SetSyncSource(fMusicSync) + else + LyricsState.SetSyncSource(nil); + // start lyrics - LyricsState.Resume(); + LyricsState.Start(true); // start music AudioPlayback.Play(); @@ -640,7 +691,26 @@ begin CountSkipTimeSet; end; -procedure TScreenSing.onHide; +procedure TScreenSing.ClearSettings; +begin + Settings.Finish := False; + Settings.LyricsVisible := True; + Settings.NotesVisible := high(Integer); + Settings.PlayerEnabled := high(Integer); +end; + +{ applies changes of settings record } +procedure TScreenSing.ApplySettings; +begin + // +end; + +procedure TScreenSing.EndSong; +begin + Settings.Finish := True; +end; + +procedure TScreenSing.OnHide; begin // background texture if (Tex_Background.TexNum > 0) then @@ -659,6 +729,9 @@ var Sec: integer; T: integer; CurLyricsTime: real; + VideoFrameTime: Extended; + Line: TLyricLine; + LastWord: TLyricWord; begin Background.Draw; @@ -704,23 +777,23 @@ begin // will move the statics and texts to the correct screen here. // FIXME: clean up this weird stuff. Commenting this stuff out, nothing // was missing on screen w/ 6 players - so do we even need this stuff? - {Static[StaticP1].Texture.X := Static[StaticP1].Texture.X + 10 * ScreenX; + {Statics[StaticP1].Texture.X := Statics[StaticP1].Texture.X + 10 * ScreenX; Text[TextP1].X := Text[TextP1].X + 10 * ScreenX; } - {Static[StaticP1ScoreBG].Texture.X := Static[StaticP1ScoreBG].Texture.X + 10*ScreenX; + {Statics[StaticP1ScoreBG].Texture.X := Statics[StaticP1ScoreBG].Texture.X + 10*ScreenX; Text[TextP1Score].X := Text[TextP1Score].X + 10*ScreenX;} - {Static[StaticP2R].Texture.X := Static[StaticP2R].Texture.X + 10 * ScreenX; + {Statics[StaticP2R].Texture.X := Statics[StaticP2R].Texture.X + 10 * ScreenX; Text[TextP2R].X := Text[TextP2R].X + 10 * ScreenX; } - {Static[StaticP2RScoreBG].Texture.X := Static[StaticP2RScoreBG].Texture.X + 10*ScreenX; + {Statics[StaticP2RScoreBG].Texture.X := Statics[StaticP2RScoreBG].Texture.X + 10*ScreenX; Text[TextP2RScore].X := Text[TextP2RScore].X + 10*ScreenX;} // end of weird stuff { - Static[1].Texture.X := Static[1].Texture.X + 10 * ScreenX; } + Statics[1].Texture.X := Statics[1].Texture.X + 10 * ScreenX; } { for T := 0 to 1 do Text[T].X := Text[T].X + 10 * ScreenX; } @@ -744,18 +817,37 @@ begin // Note: there is no menu and the animated background brakes the video playback //DrawBG; + //the song was sung to the end? + Line := Lyrics.GetUpperLine(); + if Line.LastLine then + begin + LastWord := Line.Words[Length(Line.Words)-1]; + if CurLyricsTime >= GetTimeFromBeat(LastWord.Start+LastWord.Length) then + SungToEnd := true; + end; + // update and draw movie - if (ShowFinish and (VideoLoaded or fShowVisualization)) then + if Assigned(fCurrentVideo) then begin - if assigned(fCurrentVideoPlaybackEngine) then + // Just call this once + // when Screens = 2 + if (ScreenAct = 1) then begin - // Just call this once - // when Screens = 2 - if (ScreenAct = 1) then - fCurrentVideoPlaybackEngine.GetFrame(CurrentSong.VideoGAP + LyricsState.GetCurrentTime()); - - fCurrentVideoPlaybackEngine.DrawGL(ScreenAct); + if (ShowFinish) then + begin + // everything is setup, determine the current position + VideoFrameTime := CurrentSong.VideoGAP + LyricsState.GetCurrentTime(); + end + else + begin + // Important: do not yet start the triggered timer by a call to + // LyricsState.GetCurrentTime() + VideoFrameTime := CurrentSong.VideoGAP; + end; + fCurrentVideo.GetFrame(VideoFrameTime); end; + + fCurrentVideo.DrawGL(ScreenAct); end; // draw static menu (FG) @@ -766,11 +858,14 @@ begin if ShowFinish then begin if (not AudioPlayback.Finished) and ((CurrentSong.Finish = 0) or - (LyricsState.GetCurrentTime() * 1000 <= CurrentSong.Finish)) then + (LyricsState.GetCurrentTime() * 1000 <= CurrentSong.Finish)) and (not Settings.Finish) then begin // analyze song if not paused if (not Paused) then + begin Sing(Self); + Party.CallOnSing; + end; end else begin @@ -778,7 +873,6 @@ begin begin Finish; FadeOut := true; - FadeTo(@ScreenScore); end; end; end; @@ -800,15 +894,15 @@ begin // will move the statics and texts to the correct screen here. // FIXME: clean up this weird stuff - {Static[StaticP1].Texture.X := Static[StaticP1].Texture.X - 10 * ScreenX; + {Statics[StaticP1].Texture.X := Statics[StaticP1].Texture.X - 10 * ScreenX; Text[TextP1].X := Text[TextP1].X - 10 * ScreenX; - Static[StaticP2R].Texture.X := Static[StaticP2R].Texture.X - 10 * ScreenX; + Statics[StaticP2R].Texture.X := Statics[StaticP2R].Texture.X - 10 * ScreenX; Text[TextP2R].X := Text[TextP2R].X - 10 * ScreenX; // end of weird - Static[1].Texture.X := Static[1].Texture.X - 10 * ScreenX; + Statics[1].Texture.X := Statics[1].Texture.X - 10 * ScreenX; for T := 0 to 1 do Text[T].X := Text[T].X - 10 * ScreenX; } @@ -818,9 +912,9 @@ begin // maybe someone could find a better solution if Paused then begin - Static[StaticPausePopup].Visible := true; - Static[StaticPausePopup].Draw; - Static[StaticPausePopup].Visible := false; + Statics[StaticPausePopup].Visible := true; + Statics[StaticPausePopup].Draw; + Statics[StaticPausePopup].Visible := false; end; Result := true; @@ -832,14 +926,12 @@ begin AudioPlayback.Stop; AudioPlayback.SetSyncSource(nil); - if (VideoPlayback <> nil) then - VideoPlayback.Close; + LyricsState.Stop(); + LyricsState.SetSyncSource(nil); - if (Visualization <> nil) then - Visualization.Close; - - // to prevent drawing closed video - VideoLoaded := false; + // close video files + fVideoClip := nil; + fCurrentVideo := nil; // kill all stars and effects GoldenRec.KillAll; @@ -855,11 +947,13 @@ begin end; SetFontItalic(false); + + Party.CallAfterSing; end; procedure TScreenSing.OnSentenceEnd(SentenceIndex: cardinal); var - PlayerIndex: integer; + PlayerIndex: byte; CurrentPlayer: PPLayer; CurrentScore: real; Line: PLine; @@ -898,10 +992,14 @@ begin // points for this line LineScore := CurrentScore - CurrentPlayer.ScoreLast; - // determine LinePerfection - // Note: the "+2" extra points are a little bonus so the player does not - // have to be that perfect to reach the bonus steps. - LinePerfection := (LineScore + 2) / MaxLineScore; + // check for lines with low points + if (MaxLineScore <= 2) then + LinePerfection := 1 + else + // determine LinePerfection + // Note: the "+2" extra points are a little bonus so the player does not + // have to be that perfect to reach the bonus steps. + LinePerfection := LineScore / (MaxLineScore - 2); // clamp LinePerfection to range [0..1] if (LinePerfection < 0) then @@ -928,7 +1026,9 @@ begin // spawn rating pop-up Rating := Round(LinePerfection * MAX_LINE_RATING); Scores.SpawnPopUp(PlayerIndex, Rating, CurrentPlayer.ScoreTotalInt); - end; + end + else + Scores.RaiseScore(PlayerIndex, CurrentPlayer.ScoreTotalInt); // PerfectLineTwinkle (effect), part 1 if (Ini.EffectSing = 1) then @@ -967,5 +1067,10 @@ begin Result := LyricsState.GetCurrentTime(); end; +function TMusicSyncSource.GetClock(): real; +begin + Result := AudioPlayback.Position; +end; + end. diff --git a/cmake/src/screens/UScreenSingModi.pas b/cmake/src/screens/UScreenSingModi.pas deleted file mode 100644 index eeb06004..00000000 --- a/cmake/src/screens/UScreenSingModi.pas +++ /dev/null @@ -1,580 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenSingModi; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - UMusic, - SDL, - SysUtils, - UFiles, - UTime, - USongs, - UIni, - ULog, - UTexture, - ULyrics, - TextGL, - gl, - - UThemes, - UScreenSing, - ModiSDK; - -type - TScreenSingModi = class(TScreenSing) - protected - - public - Winner: byte; //Who Wins - PlayerInfo: TPlayerInfo; - TeamInfo: TTeamInfo; - - constructor Create; override; - procedure onShow; override; - //procedure onShowFinish; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - function Draw: boolean; override; - procedure Finish; override; - end; - -type - TCustomSoundEntry = record - Filename : string; - Stream : TAudioPlaybackStream; - end; - -var - //Custom Sounds - CustomSounds: array of TCustomSoundEntry; - -//Procedured for Plugin -function LoadTex(const Name: PChar; Typ: TTextureType): TsmallTexture; - {$IFDEF MSWINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF} -//function Translate (const Name: PChar): PChar; -// {$IFDEF MSWINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF} -//Procedure to Print Text -procedure Print(const Style, Size: byte; const X, Y: real; const Text: PChar); - {$IFDEF MSWINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF} -//Procedure that loads a Custom Sound -function LoadSound(const Name: PChar): cardinal; - {$IFDEF MSWINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF} -//Plays a Custom Sound -procedure PlaySound(const Index: cardinal); - {$IFDEF MSWINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF} - -//Utilys -function ToSentences(Const Lines: TLines): TSentences; - -implementation - -uses - Classes, - Math, - UDLLManager, - UDraw, - UGraphic, - UGraphicClasses, - ULanguage, - UNote, - UPath, - URecord, - USkins; - -// Method for input parsing. If false is returned, GetNextWindow -// should be checked to know the next window to load; -function TScreenSingModi.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - case PressedKey of - - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - Finish; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenPartyScore); - end; - - else - Result := inherited ParseInput(PressedKey, CharCode, PressedDown); - end; - end; -end; - -constructor TScreenSingModi.Create; -begin - inherited Create; - -end; - -function ToSentences(Const Lines: TLines): TSentences; -var - I, J: integer; -begin - Result.Current := Lines.Current; - Result.High := Lines.High; - Result.Number := Lines.Number; - Result.Resolution := Lines.Resolution; - Result.NotesGAP := Lines.NotesGAP; - Result.TotalLength := Lines.ScoreValue; - - SetLength(Result.Sentence, Length(Lines.Line)); - for I := low(Result.Sentence) to high(Result.Sentence) do - begin - Result.Sentence[I].Start := Lines.Line[I].Start; - Result.Sentence[I].StartNote := Lines.Line[I].Note[0].Start; - Result.Sentence[I].Lyric := Lines.Line[I].Lyric; - Result.Sentence[I].End_ := Lines.Line[I].End_; - Result.Sentence[I].BaseNote := Lines.Line[I].BaseNote; - Result.Sentence[I].HighNote := Lines.Line[I].HighNote; - Result.Sentence[I].TotalNotes := Lines.Line[I].TotalNotes; - - SetLength(Result.Sentence[I].Note, Length(Lines.Line[I].Note)); - for J := low(Result.Sentence[I].Note) to high(Result.Sentence[I].Note) do - begin - Result.Sentence[I].Note[J].Color := Lines.Line[I].Note[J].Color; - Result.Sentence[I].Note[J].Start := Lines.Line[I].Note[J].Start; - Result.Sentence[I].Note[J].Length := Lines.Line[I].Note[J].Length; - Result.Sentence[I].Note[J].Tone := Lines.Line[I].Note[J].Tone; - //Result.Sentence[I].Note[J].Text := Lines.Line[I].Note[J].Text; - Result.Sentence[I].Note[J].FreeStyle := (Lines.Line[I].Note[J].NoteType = ntFreestyle); - end; - end; -end; - -procedure TScreenSingModi.onShow; -var - I: integer; -begin - inherited; - - PlayersPlay := TeamInfo.NumTeams; - - if DLLMan.Selected.LoadSong then //Start with Song - begin - inherited; - end - else //Start Without Song - begin - AudioInput.CaptureStart; - end; - -//Set Playerinfo - PlayerInfo.NumPlayers := PlayersPlay; - for I := 0 to PlayerInfo.NumPlayers-1 do - begin - PlayerInfo.Playerinfo[I].Name := PChar(Ini.Name[I]); - PlayerInfo.Playerinfo[I].Score := 0; - PlayerInfo.Playerinfo[I].Bar := 50; - PlayerInfo.Playerinfo[I].Enabled := true; - end; - - for I := PlayerInfo.NumPlayers to high(PlayerInfo.Playerinfo) do - begin - PlayerInfo.Playerinfo[I].Score:= 0; - PlayerInfo.Playerinfo[I].Bar := 0; - PlayerInfo.Playerinfo[I].Enabled := false; - end; - - {Case PlayersPlay of - 1: begin - PlayerInfo.Playerinfo[0].PosX := Static[StaticP1ScoreBG].Texture.X; - PlayerInfo.Playerinfo[0].PosY := Static[StaticP1ScoreBG].Texture.Y + Static[StaticP1ScoreBG].Texture.H; - end; - 2,4: begin - PlayerInfo.Playerinfo[0].PosX := Static[StaticP1TwoPScoreBG].Texture.X; - PlayerInfo.Playerinfo[0].PosY := Static[StaticP1TwoPScoreBG].Texture.Y + Static[StaticP1TwoPScoreBG].Texture.H; - PlayerInfo.Playerinfo[2].PosX := Static[StaticP1TwoPScoreBG].Texture.X; - PlayerInfo.Playerinfo[2].PosY := Static[StaticP1TwoPScoreBG].Texture.Y + Static[StaticP1TwoPScoreBG].Texture.H; - PlayerInfo.Playerinfo[1].PosX := Static[StaticP2RScoreBG].Texture.X; - PlayerInfo.Playerinfo[1].PosY := Static[StaticP2RScoreBG].Texture.Y + Static[StaticP2RScoreBG].Texture.H; - PlayerInfo.Playerinfo[3].PosX := Static[StaticP2RScoreBG].Texture.X; - PlayerInfo.Playerinfo[3].PosY := Static[StaticP2RScoreBG].Texture.Y + Static[StaticP2RScoreBG].Texture.H; - end; - 3,6: begin - PlayerInfo.Playerinfo[0].PosX := Static[StaticP1ThreePScoreBG].Texture.X; - PlayerInfo.Playerinfo[0].PosY := Static[StaticP1ThreePScoreBG].Texture.Y + Static[StaticP1ThreePScoreBG].Texture.H; - PlayerInfo.Playerinfo[3].PosX := Static[StaticP1ThreePScoreBG].Texture.X; - PlayerInfo.Playerinfo[3].PosY := Static[StaticP1ThreePScoreBG].Texture.Y + Static[StaticP1ThreePScoreBG].Texture.H; - PlayerInfo.Playerinfo[1].PosX := Static[StaticP2MScoreBG].Texture.X; - PlayerInfo.Playerinfo[1].PosY := Static[StaticP2MScoreBG].Texture.Y + Static[StaticP2MScoreBG].Texture.H; - PlayerInfo.Playerinfo[4].PosX := Static[StaticP2MScoreBG].Texture.X; - PlayerInfo.Playerinfo[4].PosY := Static[StaticP2MScoreBG].Texture.Y + Static[StaticP2MScoreBG].Texture.H; - PlayerInfo.Playerinfo[2].PosX := Static[StaticP3RScoreBG].Texture.X; - PlayerInfo.Playerinfo[2].PosY := Static[StaticP3RScoreBG].Texture.Y + Static[StaticP3RScoreBG].Texture.H; - PlayerInfo.Playerinfo[5].PosX := Static[StaticP3RScoreBG].Texture.X; - PlayerInfo.Playerinfo[5].PosY := Static[StaticP3RScoreBG].Texture.Y + Static[StaticP3RScoreBG].Texture.H; - end; - end; } - - // play music (I) - //Music.CaptureStart; - //Music.MoveTo(AktSong.Start); - - //Init Plugin - if not DLLMan.PluginInit(TeamInfo, PlayerInfo, ToSentences(Lines[0]), LoadTex, Print, LoadSound, PlaySound) then - begin - //Fehler - Log.LogError('Could not Init Plugin'); - Halt; - end; - - // Set Background (Little Workaround, maybe change sometime) - if (DLLMan.Selected.LoadBack) and (DLLMan.Selected.LoadSong) then - ScreenSing.Tex_Background := Tex_Background; - - Winner := 0; - - //Set Score Visibility - Scores.Visible := DLLMan.Selected.ShowScore; - - {if PlayersPlay = 1 then - begin - Text[TextP1Score].Visible := DLLMan.Selected.ShowScore; - Static[StaticP1ScoreBG].Visible := DLLMan.Selected.ShowScore; - end; - - if (PlayersPlay = 2) or (PlayersPlay = 4) then - begin - Text[TextP1TwoPScore].Visible := DLLMan.Selected.ShowScore; - Static[StaticP1TwoPScoreBG].Visible := DLLMan.Selected.ShowScore; - - Text[TextP2RScore].Visible := DLLMan.Selected.ShowScore; - Static[StaticP2RScoreBG].Visible := DLLMan.Selected.ShowScore; - end; - - if (PlayersPlay = 3) or (PlayersPlay = 6) then - begin - Text[TextP1ThreePScore].Visible := DLLMan.Selected.ShowScore; - Static[StaticP1ThreePScoreBG].Visible := DLLMan.Selected.ShowScore; - - Text[TextP2MScore].Visible := DLLMan.Selected.ShowScore; - Static[StaticP2MScoreBG].Visible := DLLMan.Selected.ShowScore; - - Text[TextP3RScore].Visible := DLLMan.Selected.ShowScore; - Static[StaticP3RScoreBG].Visible := DLLMan.Selected.ShowScore; - end; } -end; - -function TScreenSingModi.Draw: boolean; -var - Min: integer; - Sec: integer; - TextStr: string; - S, I: integer; - T: integer; - CurLyricsTime: real; -begin - Result := false; - - //Set Playerinfo - PlayerInfo.NumPlayers := PlayersPlay; - for I := 0 to PlayerInfo.NumPlayers-1 do - begin - PlayerInfo.Playerinfo[I].Name := PChar(Player[I].Name); - if PlayerInfo.Playerinfo[I].Enabled then - begin - if (Player[I].ScoreTotalInt <= MAX_SONG_SCORE) then - PlayerInfo.Playerinfo[I].Score:= Player[I].ScoreTotalInt; - PlayerInfo.Playerinfo[I].Bar := Round(Scores.Players[I].RBPos * 100); - end; - end; - - Background.Draw; - - // draw background picture (if any, and if no visualizations) - // when we don't check for visualizations the visualizations would - // be overdrawn by the picture when {UNDEFINED UseTexture} in UVisualizer - if (DllMan.Selected.LoadSong) and (DllMan.Selected.LoadBack) and (not fShowVisualization) then - SingDrawBackground; - - // set player names (for 2 screens and only Singstar skin) - if ScreenAct = 1 then - begin - Text[TextP1].Text := 'P1'; - Text[TextP1TwoP].Text := 'P1'; // added for ps3 skin - Text[TextP1ThreeP].Text := 'P1'; // added for ps3 skin - Text[TextP2R].Text := 'P2'; - Text[TextP2M].Text := 'P2'; - Text[TextP3R].Text := 'P3'; - end - - Else if ScreenAct = 2 then - begin - case PlayersPlay of - 4: begin - Text[TextP1TwoP].Text := 'P3'; - Text[TextP2R].Text := 'P4'; - end; - 6: begin - Text[TextP1ThreeP].Text := 'P4'; - Text[TextP2M].Text := 'P5'; - Text[TextP3R].Text := 'P6'; - end; - end; // case - end; // if - - // stereo <- and where iss P2M? or P3? - Static[StaticP1].Texture.X := Static[StaticP1].Texture.X + 10*ScreenX; - Text[TextP1].X := Text[TextP1].X + 10*ScreenX; - - {Static[StaticP1ScoreBG].Texture.X := Static[StaticP1ScoreBG].Texture.X + 10*ScreenX; - Text[TextP1Score].X := Text[TextP1Score].X + 10*ScreenX;} - - Static[StaticP2R].Texture.X := Static[StaticP2R].Texture.X + 10*ScreenX; - Text[TextP2R].X := Text[TextP2R].X + 10*ScreenX; - - for S := 1 to 1 do - Static[S].Texture.X := Static[S].Texture.X + 10*ScreenX; - - for T := 0 to 1 do - Text[T].X := Text[T].X + 10*ScreenX; - - if DLLMan.Selected.LoadSong then - begin - // update static menu with time ... - CurLyricsTime := LyricsState.GetCurrentTime(); - Min := Round(CurLyricsTime) div 60; - Sec := Round(CurLyricsTime) mod 60; - - Text[TextTimeText].Text := ''; - if Min < 10 then Text[TextTimeText].Text := '0'; - Text[TextTimeText].Text := Text[TextTimeText].Text + IntToStr(Min) + ':'; - if Sec < 10 then Text[TextTimeText].Text := Text[TextTimeText].Text + '0'; - Text[TextTimeText].Text := Text[TextTimeText].Text + IntToStr(Sec); - end; - - // update and draw movie -{ if ShowFinish and CurrentSong.VideoLoaded and DllMan.Selected.LoadVideo then - begin - UpdateSmpeg; // this only draws - end;} - - // update and draw movie - if (ShowFinish and (VideoLoaded or fShowVisualization) and DllMan.Selected.LoadVideo) then - begin - if assigned(fCurrentVideoPlaybackEngine) then - begin - // Just call this once - // when Screens = 2 - if (ScreenAct = 1) then - fCurrentVideoPlaybackEngine.GetFrame(CurrentSong.VideoGAP + LyricsState.GetCurrentTime()); - - fCurrentVideoPlaybackEngine.DrawGL(ScreenAct); - end; - end; - - // draw static menu (FG) - DrawFG; - - if ShowFinish then - begin - if DllMan.Selected.LoadSong then - begin - if (not AudioPlayback.Finished) and ((CurrentSong.Finish = 0) or (LyricsState.GetCurrentTime*1000 <= CurrentSong.Finish)) then - begin - //Pause Mod: - if not Paused then - Sing(Self); // analyze song - end - else - begin - if not FadeOut then - begin - Finish; - FadeOut := true; - FadeTo(@ScreenPartyScore); - end; - end; - end; - end; - - // draw custom items - SingModiDraw(PlayerInfo); // always draw - - //GoldenNoteStarsTwinkle Mod - GoldenRec.SpawnRec; - //GoldenNoteStarsTwinkle Mod - - //Draw Score - Scores.Draw; - - //Update PlayerInfo - for I := 0 to PlayerInfo.NumPlayers-1 do - begin - if PlayerInfo.Playerinfo[I].Enabled then - begin - //PlayerInfo.Playerinfo[I].Bar := Player[I].ScorePercent; - PlayerInfo.Playerinfo[I].Score := Player[I].ScoreTotalInt; - end; - end; - - if ((ShowFinish) and (not Paused)) then - begin - if not DLLMan.PluginDraw(Playerinfo, Lines[0].Current) then - begin - if not FadeOut then - begin - Finish; - FadeOut := true; - FadeTo(@ScreenPartyScore); - end; - end; - end; - - //Change PlayerInfo/Changeables - for I := 0 to PlayerInfo.NumPlayers-1 do - begin - if (Player[I].ScoreTotalInt <> PlayerInfo.Playerinfo[I].Score) then - begin - //Player[I].ScoreTotal := Player[I].ScoreTotal + (PlayerInfo.Playerinfo[I].Score - Player[I].ScoreTotalI); - Player[I].ScoreTotalInt := PlayerInfo.Playerinfo[I].Score; - end; - {if (PlayerInfo.Playerinfo[I].Bar <> Player[I].ScorePercent) then - Player[I].ScorePercentTarget := PlayerInfo.Playerinfo[I].Bar; } - end; - - // back stereo - Static[StaticP1].Texture.X := Static[StaticP1].Texture.X - 10*ScreenX; - Text[TextP1].X := Text[TextP1].X - 10*ScreenX; - - {Static[StaticP1ScoreBG].Texture.X := Static[StaticP1ScoreBG].Texture.X - 10*ScreenX; - Text[TextP1Score].X := Text[TextP1Score].X - 10*ScreenX;} - - Static[StaticP2R].Texture.X := Static[StaticP2R].Texture.X - 10*ScreenX; - Text[TextP2R].X := Text[TextP2R].X - 10*ScreenX; - - {Static[StaticP2RScoreBG].Texture.X := Static[StaticP2RScoreBG].Texture.X - 10*ScreenX; - Text[TextP2RScore].X := Text[TextP2RScore].X - 10*ScreenX;} - - for S := 1 to 1 do - Static[S].Texture.X := Static[S].Texture.X - 10*ScreenX; - - for T := 0 to 1 do - Text[T].X := Text[T].X - 10*ScreenX; - - Result := true; -end; - -procedure TScreenSingModi.Finish; -begin -inherited Finish; - -Winner := DllMan.PluginFinish(PlayerInfo); - -//Log.LogError('Winner: ' + InttoStr(Winner)); - -//DLLMan.UnLoadPlugin; -end; - -function LoadTex(const Name: PChar; Typ: TTextureType): TsmallTexture; -var - Texname, EXT: string; - Tex: TTexture; -begin - //Get texture Name - TexName := Skin.GetTextureFileName(string(Name)); - //Get File Typ - Ext := ExtractFileExt(TexName); - if (uppercase(Ext) = '.JPG') then - Ext := 'JPG' - else - Ext := 'BMP'; - - Tex := Texture.LoadTexture(false, PChar(TexName), UTEXTURE.TTextureType(Typ), 0); - - Result.TexNum := Tex.TexNum; - Result.W := Tex.W; - Result.H := Tex.H; -end; -{ -function Translate (const Name: PChar): PChar; stdcall; -begin - Result := PChar(Language.Translate(string(Name))); -end; } - -//Procedure to Print Text -procedure Print(const Style, Size: byte; const X, Y: real; const Text: PChar); -begin - SetFontItalic ((Style and 128) = 128); - SetFontStyle(Style and 7); - // FIXME: FONTSIZE - // used by Hold_The_Line / TeamDuell - SetFontSize(Size); - SetFontPos (X, Y); - glPrint (Language.Translate(string(Text))); -end; - -//Procedure that loads a Custom Sound -function LoadSound(const Name: PChar): cardinal; -var - Stream: TAudioPlaybackStream; - i: integer; - Filename: string; -begin - //Search for Sound in already loaded Sounds - Filename := UpperCase(SoundPath + Name); - for i := 0 to High(CustomSounds) do - begin - if (UpperCase(CustomSounds[i].Filename) = Filename) then - begin - Result := i; - Exit; - end; - end; - - Stream := AudioPlayback.OpenSound(SoundPath + string(Name)); - if (Stream = nil) then - begin - Result := 0; - Exit; - end; - - SetLength(CustomSounds, Length(CustomSounds)+1); - CustomSounds[High(CustomSounds)].Stream := Stream; - Result := High(CustomSounds); -end; - -//Plays a Custom Sound -procedure PlaySound(const Index: cardinal); -begin - if (Index <= High(CustomSounds)) then - AudioPlayback.PlaySound(CustomSounds[Index].Stream); -end; - -end. - diff --git a/cmake/src/screens/UScreenSong.pas b/cmake/src/screens/UScreenSong.pas index fa3c836e..6b83d522 100644 --- a/cmake/src/screens/UScreenSong.pas +++ b/cmake/src/screens/UScreenSong.pas @@ -38,6 +38,7 @@ uses SDL, UCommon, UDisplay, + UPath, UFiles, UIni, ULanguage, @@ -56,6 +57,11 @@ type private Equalizer: Tms_Equalizer; + PreviewOpened: Integer; // interaction of the Song that is loaded for preview music + // -1 if nothing is opened + + isScrolling: boolean; // true if song flow is about to move + procedure StartMusicPreview(); procedure StopMusicPreview(); public @@ -75,7 +81,6 @@ type HighSpeed: boolean; CoverFull: boolean; CoverTime: real; - MusicPreviewTimer: PSDL_TimerID; CoverX: integer; CoverY: integer; @@ -118,19 +123,19 @@ type procedure SetScroll4; procedure SetScroll5; procedure SetScroll6; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; function ParseMouse(MouseButton: integer; BtnDown: boolean; X, Y: integer): boolean; override; function Draw: boolean; override; procedure GenerateThumbnails(); - procedure onShow; override; - procedure onHide; override; + procedure OnShow; override; + procedure OnHide; override; procedure SelectNext; procedure SelectPrev; procedure SkipTo(Target: cardinal); procedure FixSelected; //Show Wrong Song when Tabs on Fix procedure FixSelected2; //Show Wrong Song when Tabs on Fix procedure ShowCatTL(Cat: integer);// Show Cat in Top left - procedure ShowCatTLCustom(Caption: string);// Show Custom Text in Top left + procedure ShowCatTLCustom(Caption: UTF8String);// Show Custom Text in Top left procedure HideCatTL;// Show Cat in Tob left procedure Refresh; //Refresh Song Sorting procedure ChangeMusic; @@ -141,9 +146,12 @@ type //procedures for Menu procedure StartSong; procedure OpenEditor; - procedure DoJoker(Team: byte); + procedure DoJoker(Team: integer); procedure SelectPlayers; + procedure OnSongSelect; // called when song flows movement stops at a song + procedure OnSongDeSelect; // called before current song is deselected + procedure UnloadDetailedCover; //Extensions @@ -156,7 +164,6 @@ uses Math, gl, UCovers, - UDLLManager, UGraphic, UMain, UMenuButton, @@ -164,7 +171,8 @@ uses UParty, UPlaylist, UScreenSongMenu, - USkins; + USkins, + UUnicodeUtils; // ***** Public methods ****** // @@ -211,11 +219,11 @@ begin end; //Show Wrong Song when Tabs on Fix End -procedure TScreenSong.ShowCatTLCustom(Caption: string);// Show Custom Text in Top left +procedure TScreenSong.ShowCatTLCustom(Caption: UTF8String);// Show Custom Text in Top left begin Text[TextCat].Text := Caption; Text[TextCat].Visible := true; - Static[StaticCat].Visible := false; + Statics[StaticCat].Visible := false; end; //Show Cat in Top Left Mod @@ -223,18 +231,18 @@ procedure TScreenSong.ShowCatTL(Cat: integer); begin //Change Text[TextCat].Text := CatSongs.Song[Cat].Artist; - Static[StaticCat].Texture := Texture.GetTexture(Button[Cat].Texture.Name, TEXTURE_TYPE_PLAIN, true); + //Statics[StaticCat].Texture := Texture.GetTexture(Button[Cat].Texture.Name, TEXTURE_TYPE_PLAIN, true); //Show Text[TextCat].Visible := true; - Static[StaticCat].Visible := true; + Statics[StaticCat].Visible := true; end; procedure TScreenSong.HideCatTL; begin //Hide //Text[TextCat].Visible := false; - Static[StaticCat].Visible := false; + Statics[StaticCat].Visible := false; //New -> Show Text specified in Theme Text[TextCat].Visible := true; Text[TextCat].Text := Theme.Song.TextCat.Text; @@ -243,12 +251,13 @@ end; // Method for input parsing. If false is returned, GetNextWindow // should be checked to know the next window to load; -function TScreenSong.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenSong.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; var I: integer; I2: integer; SDL_ModState: word; - Letter: WideChar; + UpperLetter: UCS4Char; + TempStr: UTF8String; begin Result := true; @@ -273,9 +282,10 @@ begin //Jump to Artist/Titel if ((SDL_ModState and KMOD_LALT <> 0) and (Mode = smNormal)) then begin - if (WideCharUpperCase(CharCode)[1] in ([WideChar('A')..WideChar('Z'), WideChar('0') .. WideChar('9')]) ) then + UpperLetter := UCS4UpperCase(CharCode); + + if (UpperLetter in ([Ord('A')..Ord('Z'), Ord('0') .. Ord('9')]) ) then begin - Letter := WideCharUpperCase(CharCode)[1]; I2 := Length(CatSongs.Song); //Jump To Titel @@ -283,18 +293,20 @@ begin begin for I := 1 to High(CatSongs.Song) do begin - if (CatSongs.Song[(I + Interaction) mod I2].Visible) and - (Length(CatSongs.Song[(I + Interaction) mod I2].Title)>0) and - (WideStringUpperCase(CatSongs.Song[(I + Interaction) mod I2].Title)[1] = Letter) then + if (CatSongs.Song[(I + Interaction) mod I2].Visible) then begin - SkipTo(CatSongs.VisibleIndex((I + Interaction) mod I2)); + TempStr := CatSongs.Song[(I + Interaction) mod I2].Title; + if (Length(TempStr) > 0) and + (UCS4UpperCase(UTF8ToUCS4String(TempStr)[0]) = UpperLetter) then + begin + SkipTo(CatSongs.VisibleIndex((I + Interaction) mod I2)); - AudioPlayback.PlaySound(SoundLib.Change); + AudioPlayback.PlaySound(SoundLib.Change); - ChangeMusic; - SetScroll4; - //Break and Exit - Exit; + SetScroll4; + //Break and Exit + Exit; + end; end; end; end @@ -303,19 +315,21 @@ begin begin for I := 1 to High(CatSongs.Song) do begin - if (CatSongs.Song[(I + Interaction) mod I2].Visible) and - (Length(CatSongs.Song[(I + Interaction) mod I2].Artist)>0) and - (WideStringUpperCase(CatSongs.Song[(I + Interaction) mod I2].Artist)[1] = Letter) then + if (CatSongs.Song[(I + Interaction) mod I2].Visible) then begin - SkipTo(CatSongs.VisibleIndex((I + Interaction) mod I2)); + TempStr := CatSongs.Song[(I + Interaction) mod I2].Artist; + if (Length(TempStr) > 0) and + (UCS4UpperCase(UTF8ToUCS4String(TempStr)[0]) = UpperLetter) then + begin + SkipTo(CatSongs.VisibleIndex((I + Interaction) mod I2)); - AudioPlayback.PlaySound(SoundLib.Change); + AudioPlayback.PlaySound(SoundLib.Change); - ChangeMusic; - SetScroll4; + SetScroll4; - //Break and Exit - Exit; + //Break and Exit + Exit; + end; end; end; end; @@ -324,15 +338,22 @@ begin Exit; end; + // ********************** + // * workaround for LCTRL+R: it should be changed when we have a solution for the + // * CTRL+'A'..'Z' problem + if (SDL_ModState = KMOD_LCTRL) and (PressedKey = SDLK_R) then + CharCode := UCS4Char('R'); + // ********************** + // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; end; - 'M': //Show SongMenu + Ord('M'): //Show SongMenu begin if (Songs.SongList.Count > 0) then begin @@ -342,41 +363,41 @@ begin begin if CatSongs.CatNumShow = -3 then begin - ScreenSongMenu.onShow; + ScreenSongMenu.OnShow; ScreenSongMenu.MenuShow(SM_Playlist); end else begin - ScreenSongMenu.onShow; + ScreenSongMenu.OnShow; ScreenSongMenu.MenuShow(SM_Main); end; end else begin - ScreenSongMenu.onShow; + ScreenSongMenu.OnShow; ScreenSongMenu.MenuShow(SM_Playlist_Load); end; end //Party Mode -> Show Party Menu else begin - ScreenSongMenu.onShow; + ScreenSongMenu.OnShow; ScreenSongMenu.MenuShow(SM_Party_Main); end; end; Exit; end; - 'P': //Show Playlist Menu + Ord('P'): //Show Playlist Menu begin if (Songs.SongList.Count > 0) and (Mode = smNormal) then begin - ScreenSongMenu.onShow; + ScreenSongMenu.OnShow; ScreenSongMenu.MenuShow(SM_Playlist_Load); end; Exit; end; - 'J': //Show Jumpto Menu + Ord('J'): //Show Jumpto Menu begin if (Songs.SongList.Count > 0) and (Mode = smNormal) then begin @@ -385,13 +406,13 @@ begin Exit; end; - 'E': + Ord('E'): begin OpenEditor; Exit; end; - 'R': + Ord('R'): begin if (Songs.SongList.Count > 0) and (Mode = smNormal) then @@ -464,7 +485,6 @@ begin end; AudioPlayback.PlaySound(SoundLib.Change); - ChangeMusic; SetScroll4; end; Exit; @@ -505,7 +525,7 @@ begin //Show Wrong Song when Tabs on Fix SelectNext; FixSelected; - //SelectPrev; + //SelectPrev(true); //CatSongs.Song[0].Visible := false; end else @@ -515,7 +535,7 @@ begin if (CatSongs.CatNumShow < -1) then begin //Atm: Set Empty Filter - CatSongs.SetFilter('', 0); + CatSongs.SetFilter('', fltAll); //Show Cat in Top Left Mod HideCatTL; @@ -524,8 +544,6 @@ begin //Show Wrong Song when Tabs on Fix SelectNext; FixSelected; - - ChangeMusic; end else begin @@ -564,9 +582,6 @@ begin //Show Wrong Song when Tabs on Fix SelectNext; FixSelected; - - //Play Music: - ChangeMusic; end else begin // clicked on song @@ -589,7 +604,7 @@ begin if (Ini.PartyPopup = 1) then ScreenSongMenu.MenuShow(SM_Party_Main) else - ScreenSong.StartSong; + Party.CallAfterSongSelect; end; end; end; @@ -627,8 +642,6 @@ begin //Play Music: AudioPlayback.PlaySound(SoundLib.Change); - ChangeMusic; - end; // @@ -671,7 +684,6 @@ begin //Play Music: AudioPlayback.PlaySound(SoundLib.Change); - ChangeMusic; end; end; //Cat Change Hack End} @@ -684,9 +696,6 @@ begin begin AudioPlayback.PlaySound(SoundLib.Change); SelectNext; - //InteractNext; - //SongTarget := Interaction; - ChangeMusic; SetScroll4; end; end; @@ -697,65 +706,116 @@ begin begin AudioPlayback.PlaySound(SoundLib.Change); SelectPrev; - ChangeMusic; SetScroll4; end; end; SDLK_1: begin //Joker - if (Mode = smPartyMode) and (PartySession.Teams.NumTeams >= 1) and (PartySession.Teams.Teaminfo[0].Joker > 0) then - begin - //Use Joker - Dec(PartySession.Teams.Teaminfo[0].Joker); - SelectRandomSong; - SetJoker; - end; + DoJoker(0); end; SDLK_2: begin //Joker - if (Mode = smPartyMode) and (PartySession.Teams.NumTeams >= 2) and (PartySession.Teams.Teaminfo[1].Joker > 0) then - begin - //Use Joker - Dec(PartySession.Teams.Teaminfo[1].Joker); - SelectRandomSong; - SetJoker; - end; + DoJoker(1); end; SDLK_3: begin //Joker - if (Mode = smPartyMode) and (PartySession.Teams.NumTeams >= 3) and (PartySession.Teams.Teaminfo[2].Joker > 0) then - begin - //Use Joker - Dec(PartySession.Teams.Teaminfo[2].Joker); - SelectRandomSong; - SetJoker; - end; + DoJoker(2); end; end; end; // if (PressedDown) end; function TScreenSong.ParseMouse(MouseButton: integer; BtnDown: boolean; X, Y: integer): boolean; + var + I, J: Integer; + Btn: Integer; begin Result := true; - if RightMbESC and (MouseButton = SDL_BUTTON_RIGHT) and BtnDown then - //if RightMbESC is set, send ESC keypress - Result:=ParseInput(SDLK_ESCAPE, #0, true); + if (ScreenSongMenu.Visible) then + begin + Result := ScreenSongMenu.ParseMouse(MouseButton, BtnDown, X, Y); + exit; + end + else if (ScreenSongJumpTo.Visible) then + begin + Result := ScreenSongJumpTo.ParseMouse(MouseButton, BtnDown, X, Y); + exit; + end + else // no extension visible + begin + if (BtnDown) then + begin + //if RightMbESC is set, send ESC keypress + if RightMbESC and (MouseButton = SDL_BUTTON_RIGHT) then + Result:=ParseInput(SDLK_ESCAPE, 0, true) + + //song scrolling with mousewheel + else if (MouseButton = SDL_BUTTON_WHEELDOWN) then + ParseInput(SDLK_RIGHT, 0, true) - //song scrolling with mousewheel - if (MouseButton = SDL_BUTTON_WHEELDOWN) and BtnDown then - ParseInput(SDLK_RIGHT, #0, true); + else if (MouseButton = SDL_BUTTON_WHEELUP) then + ParseInput(SDLK_LEFT, 0, true) - if (MouseButton = SDL_BUTTON_WHEELUP) and BtnDown then - ParseInput(SDLK_LEFT, #0, true); + //LMB anywhere starts + else if (MouseButton = SDL_BUTTON_LEFT) then + begin + if (CatSongs.VisibleSongs > 4) then + begin + // select the second visible button left from selected + I := 0; + Btn := Interaction; + while (I < 2) do + begin + Dec(Btn); + if (Btn < 0) then + Btn := High(CatSongs.Song); - //LMB anywhere starts - if (MouseButton = SDL_BUTTON_LEFT) and BtnDown then - ParseInput(SDLK_RETURN, #0, true); + if (CatSongs.Song[Btn].Visible) then + Inc(I); + end; + + // test the 5 front buttons for click + for I := 0 to 4 do + begin + if InRegion(X, Y, Button[Btn].GetMouseOverArea) then + begin + // song cover clicked + if (I = 2) then + begin // Selected Song clicked -> start singing + ParseInput(SDLK_RETURN, 0, true); + end + else + begin // one of the other 4 covers in the front clicked -> select it + J := I - 2; + while (J < 0) do + begin + ParseInput(SDLK_LEFT, 0, true); + Inc(J); + end; + + while (J > 0) do + begin + ParseInput(SDLK_RIGHT, 0, true); + Dec(J); + end; + end; + Break; + end; + + Btn := CatSongs.FindNextVisible(Btn); + if (Btn = -1) then + Break; + end; + end + else + ParseInput(SDLK_RETURN, 0, true); + end; + end; + end; end; constructor TScreenSong.Create; @@ -824,8 +884,8 @@ begin Equalizer := Tms_Equalizer.Create(AudioPlayback, Theme.Song.Equalizer); - if (Length(CatSongs.Song) > 0) then - Interaction := 0; + PreviewOpened := -1; + isScrolling := false; end; procedure TScreenSong.GenerateThumbnails(); @@ -833,9 +893,9 @@ var I: integer; CoverButtonIndex: integer; CoverButton: TButton; - CoverName: string; CoverTexture: TTexture; Cover: TCover; + CoverFile: IPath; Song: TSong; begin if (Length(CatSongs.Song) <= 0) then @@ -850,7 +910,7 @@ begin CoverButton := nil; // create a clickable cover - CoverButtonIndex := AddButton(300 + I*250, 140, 200, 200, '', TEXTURE_TYPE_PLAIN, Theme.Song.Cover.Reflections); + CoverButtonIndex := AddButton(300 + I*250, 140, 200, 200, PATH_NONE, TEXTURE_TYPE_PLAIN, Theme.Song.Cover.Reflections); if (CoverButtonIndex > -1) then CoverButton := Button[CoverButtonIndex]; if (CoverButton = nil) then @@ -858,19 +918,17 @@ begin Song := CatSongs.Song[I]; - // if cover-image is not found then show 'no cover' - if (not FileExists(Song.Path + Song.Cover)) then - Song.Cover := ''; + CoverFile := Song.Path.Append(Song.Cover); + if (not CoverFile.IsFile()) then + Song.Cover := PATH_NONE; - if (Song.Cover = '') then - CoverName := Skin.GetTextureFileName('SongCover') - else - CoverName := Song.Path + Song.Cover; + if (Song.Cover.IsUnset) then + CoverFile := Skin.GetTextureFileName('SongCover'); // load cover and cache its texture - Cover := Covers.FindCover(CoverName); + Cover := Covers.FindCover(CoverFile); if (Cover = nil) then - Cover := Covers.AddCover(CoverName); + Cover := Covers.AddCover(CoverFile); // use the cached texture // TODO: this is a workaround until the new song-loading works. @@ -883,10 +941,39 @@ begin CoverTexture := Cover.GetPreviewTexture(); Texture.AddTexture(CoverTexture, TEXTURE_TYPE_PLAIN, true); CoverButton.Texture := CoverTexture; + + // set selected to false -> the right texture will be displayed + CoverButton.Selected := False; end; Cover.Free; end; + + // reset selection + if (Length(CatSongs.Song) > 0) then + Interaction := 0; +end; + +{ called when song flows movement stops at a song } +procedure TScreenSong.OnSongSelect; +begin + if (Ini.PreviewVolume <> 0) then + begin + StartMusicPreview; + end; + + // fade in detailed cover + CoverTime := 0; +end; + +{ called before current song is deselected } +procedure TScreenSong.OnSongDeSelect; +begin + CoverTime := 10; + UnLoadDetailedCover; + + StopMusicPreview(); + PreviewOpened := -1; end; procedure TScreenSong.SetScroll; @@ -899,18 +986,13 @@ begin // Set Positions case Theme.Song.Cover.Style of 3: SetScroll3; - 5:begin - if VS > 5 then - SetScroll5 - else - SetScroll4; - end; + 5: SetScroll5; 6: SetScroll6; else SetScroll4; end; // Set visibility of video icon - Static[VideoIcon].Visible := (CatSongs.Song[Interaction].Video <> ''); + Statics[VideoIcon].Visible := CatSongs.Song[Interaction].Video.IsSet; // Set texts Text[TextArtist].Text := CatSongs.Song[Interaction].Artist; @@ -944,8 +1026,6 @@ end; procedure TScreenSong.SetScroll1; var B: integer; // button - //BMin: integer; // button min // Auto Removed, Unused Variable - //BMax: integer; // button max // Auto Removed, Unused Variable Src: integer; //Dst: integer; Count: integer; // Dst is not used. Count is used. @@ -1097,7 +1177,7 @@ begin end; if Length(Button) > 0 then - Static[1].Texture.Y := Button[Interaction].Y - 5; // selection texture + Statics[1].Texture.Y := Button[Interaction].Y - 5; // selection texture end; procedure TScreenSong.SetScroll2; @@ -1251,7 +1331,7 @@ begin // Use an alternate position for the five front covers. if (Abs(Pos) < 2.5) then begin - Angle := Pi * (Pos / 5); // Range: (-1/4*Pi .. +1/4*Pi) + Angle := Pi * (Pos / Min(VS, 5)); // Range: (-1/4*Pi .. +1/4*Pi) Button[B].H := Abs(Theme.Song.Cover.H * cos(Angle*0.8)); Button[B].W := Button[B].H; @@ -1265,14 +1345,25 @@ begin Button[B].X := Theme.Song.Cover.X + Theme.Song.Cover.W * X - Padding; Button[B].Y := (Theme.Song.Cover.Y + (Theme.Song.Cover.H - Abs(Theme.Song.Cover.H * cos(Angle))) * 0.5); Button[B].Z := 0.95 - Abs(Pos) * 0.01; + + if VS < 5 then + Button[B].Texture.Alpha := 1 - Abs(Pos) / VS * 2 + else + Button[B].Texture.Alpha := 1; end - else + { only draw 3 visible covers in the background + (the 3 that are on the opposite of the front covers} + else if (VS > 7) and (Abs(Pos) > floor(VS/2) - 1.5) then begin - // Transform Pos to range [-1..-1/2, +1/2..+1] + // Transform Pos to range [-1..-3/4, +3/4..+1] + { the 3 covers at the back will show up in the gap between the + front cover and its neighbors + one cover will be hiddenbehind the front cover, + but this will not be a lack of performance ;) } if Pos < 0 then - Pos := Pos/VS - 0.5 + Pos := (Pos - 2 + ceil(VS/2))/8 - 0.75 else - Pos := Pos/VS + 0.5; + Pos := (Pos + 2 - floor(VS/2))/8 + 0.75; // angle in radians [-2Pi..-Pi, +Pi..+2Pi] Angle := 2*Pi * Pos; @@ -1286,9 +1377,14 @@ begin Button[B].Y := Theme.Song.Cover.Y - (Button[B].H - Theme.Song.Cover.H)*0.75; Button[B].Z := (0.4 - Abs(Pos/4)) -0.00001; //z < 0.49999 is behind the cover 1 is in front of the covers + Button[B].Texture.Alpha := 1; + //Button[B].Reflectionspacing := 15 * Button[B].H/Theme.Song.Cover.H; Button[B].DeSelectReflectionspacing := 15 * Button[B].H/Theme.Song.Cover.H; - end; + end + { all other covers are not visible } + else + Button[B].Visible := false; end; end; end; @@ -1399,7 +1495,7 @@ begin end; end; -procedure TScreenSong.onShow; +procedure TScreenSong.OnShow; begin inherited; {** @@ -1408,6 +1504,7 @@ begin SoundLib.PauseBgMusic; AudioPlayback.Stop; + PreviewOpened := -1; if Ini.Players <= 3 then PlayersPlay := Ini.Players + 1; if Ini.Players = 4 then PlayersPlay := 6; @@ -1423,10 +1520,6 @@ begin if Length(CatSongs.Song) > 0 then begin - //Load Music only when Song Preview is activated - if ( Ini.PreviewVolume <> 0 ) then - StartMusicPreview(); - SetScroll; end; @@ -1437,7 +1530,6 @@ begin if (CatSongs.CatNumShow = -3) then begin SelectNext; - ChangeMusic; end; end //Party Mode @@ -1452,25 +1544,18 @@ begin end; end; + isScrolling := true; SetJoker; SetStatics; end; -procedure TScreenSong.onHide; +procedure TScreenSong.OnHide; begin // turn music volume to 100% AudioPlayback.SetVolume(1.0); - // if preview is deactivated: load musicfile now - if (IPreviewVolumeVals[Ini.PreviewVolume] = 0) then - AudioPlayback.Open(CatSongs.Song[Interaction].Path + CatSongs.Song[Interaction].Mp3); - - // if hide then stop music (for party mode popup on exit) - if (Display.NextScreen <> @ScreenSing) and - (Display.NextScreen <> @ScreenSingModi) then - begin - StopMusicPreview(); - end; + // stop preview + StopMusicPreview(); end; procedure TScreenSong.DrawExtensions; @@ -1492,13 +1577,23 @@ var dt: real; I: integer; begin - dx := SongTarget-SongCurrent; - dt := TimeSkip * 7; + if isScrolling then + begin + dx := SongTarget-SongCurrent; + dt := TimeSkip * 7; - if dt > 1 then - dt := 1; - - SongCurrent := SongCurrent + dx*dt; + if dt > 1 then + dt := 1; + + SongCurrent := SongCurrent + dx*dt; + + if SameValue(SongCurrent, SongTarget, 0.002) and (CatSongs.VisibleSongs > 0) then + begin + isScrolling := false; + SongCurrent := SongTarget; + OnSongSelect; + end; + end; { if SongCurrent > Catsongs.VisibleSongs then @@ -1552,8 +1647,8 @@ begin Button[I].Draw; // Statics - for I := 0 to Length(Static) - 1 do - Static[I].Draw; + for I := 0 to Length(Statics) - 1 do + Statics[I].Draw; // and texts for I := 0 to Length(Text) - 1 do @@ -1575,7 +1670,11 @@ begin if VS > 0 then begin - UnLoadDetailedCover; + if (not isScrolling) and (VS > 0) then + begin + isScrolling := true; + OnSongDeselect; + end; Skip := 1; @@ -1610,7 +1709,11 @@ begin if VS > 0 then begin - UnLoadDetailedCover; + if (not isScrolling) and (VS > 0) then + begin + isScrolling := true; + OnSongDeselect; + end; Skip := 1; @@ -1638,12 +1741,21 @@ var begin AudioPlayback.Close(); + if CatSongs.VisibleSongs = 0 then + Exit; + Song := CatSongs.Song[Interaction]; if not assigned(Song) then Exit; - if AudioPlayback.Open(Song.Path + Song.Mp3) then + //fix: if main cat than there is nothing to play + if Song.main then + Exit; + + if AudioPlayback.Open(Song.Path.Append(Song.Mp3)) then begin + PreviewOpened := Interaction; + AudioPlayback.Position := AudioPlayback.Length / 4; // set preview volume if (Ini.PreviewFading = 0) then @@ -1663,51 +1775,22 @@ end; procedure TScreenSong.StopMusicPreview(); begin - // Cancel pending preview requests - SDL_RemoveTimer(MusicPreviewTimer); - // Stop preview of previous song AudioPlayback.Stop; end; -procedure StartMusicPreview(data: Pointer); -var - ScreenSong: TScreenSong; -begin - ScreenSong := TScreenSong(data); - if (ScreenSong <> nil) then - ScreenSong.StartMusicPreview(); -end; - -function MusicPreviewTimerCallback(interval: UInt32; param: Pointer): UInt32; cdecl; -begin - // delegate execution to main-thread - MainThreadExec(@StartMusicPreview, param); - // stop timer - Result := 0; -end; - // Changes previewed song procedure TScreenSong.ChangeMusic; begin StopMusicPreview(); - - // Preview song if activated and current selection is not a category cover - if (CatSongs.VisibleSongs > 0) and - (not CatSongs.Song[Interaction].Main) and - (Ini.PreviewVolume <> 0) then - begin - // Delay song fading to prevent the song from being played while scrolling - MusicPreviewTimer := SDL_AddTimer(200, MusicPreviewTimerCallback, Self); - end; + PreviewOpened := -1; + StartMusicPreview(); end; procedure TScreenSong.SkipTo(Target: cardinal); var i: integer; begin - UnLoadDetailedCover; - Interaction := High(CatSongs.Song); SongTarget := 0; @@ -1776,7 +1859,6 @@ begin end; AudioPlayback.PlaySound(SoundLib.Change); - ChangeMusic; SetScroll; end; @@ -1785,76 +1867,76 @@ begin // If Party Mode if Mode = smPartyMode then //Show Joker that are available begin - if (PartySession.Teams.NumTeams >= 1) then + if (Length(Party.Teams) >= 1) then begin - Static[StaticTeam1Joker1].Visible := (PartySession.Teams.Teaminfo[0].Joker >= 1); - Static[StaticTeam1Joker2].Visible := (PartySession.Teams.Teaminfo[0].Joker >= 2); - Static[StaticTeam1Joker3].Visible := (PartySession.Teams.Teaminfo[0].Joker >= 3); - Static[StaticTeam1Joker4].Visible := (PartySession.Teams.Teaminfo[0].Joker >= 4); - Static[StaticTeam1Joker5].Visible := (PartySession.Teams.Teaminfo[0].Joker >= 5); + Statics[StaticTeam1Joker1].Visible := (Party.Teams[0].JokersLeft >= 1); + Statics[StaticTeam1Joker2].Visible := (Party.Teams[0].JokersLeft >= 2); + Statics[StaticTeam1Joker3].Visible := (Party.Teams[0].JokersLeft >= 3); + Statics[StaticTeam1Joker4].Visible := (Party.Teams[0].JokersLeft >= 4); + Statics[StaticTeam1Joker5].Visible := (Party.Teams[0].JokersLeft >= 5); end else begin - Static[StaticTeam1Joker1].Visible := false; - Static[StaticTeam1Joker2].Visible := false; - Static[StaticTeam1Joker3].Visible := false; - Static[StaticTeam1Joker4].Visible := false; - Static[StaticTeam1Joker5].Visible := false; + Statics[StaticTeam1Joker1].Visible := false; + Statics[StaticTeam1Joker2].Visible := false; + Statics[StaticTeam1Joker3].Visible := false; + Statics[StaticTeam1Joker4].Visible := false; + Statics[StaticTeam1Joker5].Visible := false; end; - if (PartySession.Teams.NumTeams >= 2) then + if (Length(Party.Teams) >= 2) then begin - Static[StaticTeam2Joker1].Visible := (PartySession.Teams.Teaminfo[1].Joker >= 1); - Static[StaticTeam2Joker2].Visible := (PartySession.Teams.Teaminfo[1].Joker >= 2); - Static[StaticTeam2Joker3].Visible := (PartySession.Teams.Teaminfo[1].Joker >= 3); - Static[StaticTeam2Joker4].Visible := (PartySession.Teams.Teaminfo[1].Joker >= 4); - Static[StaticTeam2Joker5].Visible := (PartySession.Teams.Teaminfo[1].Joker >= 5); + Statics[StaticTeam2Joker1].Visible := (Party.Teams[1].JokersLeft >= 1); + Statics[StaticTeam2Joker2].Visible := (Party.Teams[1].JokersLeft >= 2); + Statics[StaticTeam2Joker3].Visible := (Party.Teams[1].JokersLeft >= 3); + Statics[StaticTeam2Joker4].Visible := (Party.Teams[1].JokersLeft >= 4); + Statics[StaticTeam2Joker5].Visible := (Party.Teams[1].JokersLeft >= 5); end else begin - Static[StaticTeam2Joker1].Visible := false; - Static[StaticTeam2Joker2].Visible := false; - Static[StaticTeam2Joker3].Visible := false; - Static[StaticTeam2Joker4].Visible := false; - Static[StaticTeam2Joker5].Visible := false; + Statics[StaticTeam2Joker1].Visible := false; + Statics[StaticTeam2Joker2].Visible := false; + Statics[StaticTeam2Joker3].Visible := false; + Statics[StaticTeam2Joker4].Visible := false; + Statics[StaticTeam2Joker5].Visible := false; end; - if (PartySession.Teams.NumTeams >= 3) then + if (Length(Party.Teams) >= 3) then begin - Static[StaticTeam3Joker1].Visible := (PartySession.Teams.Teaminfo[2].Joker >= 1); - Static[StaticTeam3Joker2].Visible := (PartySession.Teams.Teaminfo[2].Joker >= 2); - Static[StaticTeam3Joker3].Visible := (PartySession.Teams.Teaminfo[2].Joker >= 3); - Static[StaticTeam3Joker4].Visible := (PartySession.Teams.Teaminfo[2].Joker >= 4); - Static[StaticTeam3Joker5].Visible := (PartySession.Teams.Teaminfo[2].Joker >= 5); + Statics[StaticTeam3Joker1].Visible := (Party.Teams[2].JokersLeft >= 1); + Statics[StaticTeam3Joker2].Visible := (Party.Teams[2].JokersLeft >= 2); + Statics[StaticTeam3Joker3].Visible := (Party.Teams[2].JokersLeft >= 3); + Statics[StaticTeam3Joker4].Visible := (Party.Teams[2].JokersLeft >= 4); + Statics[StaticTeam3Joker5].Visible := (Party.Teams[2].JokersLeft >= 5); end else begin - Static[StaticTeam3Joker1].Visible := false; - Static[StaticTeam3Joker2].Visible := false; - Static[StaticTeam3Joker3].Visible := false; - Static[StaticTeam3Joker4].Visible := false; - Static[StaticTeam3Joker5].Visible := false; + Statics[StaticTeam3Joker1].Visible := false; + Statics[StaticTeam3Joker2].Visible := false; + Statics[StaticTeam3Joker3].Visible := false; + Statics[StaticTeam3Joker4].Visible := false; + Statics[StaticTeam3Joker5].Visible := false; end; end else begin //Hide all - Static[StaticTeam1Joker1].Visible := false; - Static[StaticTeam1Joker2].Visible := false; - Static[StaticTeam1Joker3].Visible := false; - Static[StaticTeam1Joker4].Visible := false; - Static[StaticTeam1Joker5].Visible := false; - - Static[StaticTeam2Joker1].Visible := false; - Static[StaticTeam2Joker2].Visible := false; - Static[StaticTeam2Joker3].Visible := false; - Static[StaticTeam2Joker4].Visible := false; - Static[StaticTeam2Joker5].Visible := false; - - Static[StaticTeam3Joker1].Visible := false; - Static[StaticTeam3Joker2].Visible := false; - Static[StaticTeam3Joker3].Visible := false; - Static[StaticTeam3Joker4].Visible := false; - Static[StaticTeam3Joker5].Visible := false; + Statics[StaticTeam1Joker1].Visible := false; + Statics[StaticTeam1Joker2].Visible := false; + Statics[StaticTeam1Joker3].Visible := false; + Statics[StaticTeam1Joker4].Visible := false; + Statics[StaticTeam1Joker5].Visible := false; + + Statics[StaticTeam2Joker1].Visible := false; + Statics[StaticTeam2Joker2].Visible := false; + Statics[StaticTeam2Joker3].Visible := false; + Statics[StaticTeam2Joker4].Visible := false; + Statics[StaticTeam2Joker5].Visible := false; + + Statics[StaticTeam3Joker1].Visible := false; + Statics[StaticTeam3Joker2].Visible := false; + Statics[StaticTeam3Joker3].Visible := false; + Statics[StaticTeam3Joker4].Visible := false; + Statics[StaticTeam3Joker5].Visible := false; end; end; @@ -1867,7 +1949,7 @@ begin Visible := (Mode = smPartyMode); for I := 0 to High(StaticParty) do - Static[StaticParty[I]].Visible := Visible; + Statics[StaticParty[I]].Visible := Visible; for I := 0 to High(TextParty) do Text[TextParty[I]].Visible := Visible; @@ -1876,7 +1958,7 @@ begin Visible := not Visible; for I := 0 to High(StaticNonParty) do - Static[StaticNonParty[I]].Visible := Visible; + Statics[StaticNonParty[I]].Visible := Visible; for I := 0 to High(TextNonParty) do Text[TextNonParty[I]].Visible := Visible; @@ -1892,7 +1974,7 @@ begin //Party Mode if (Mode = smPartyMode) then begin - FadeTo(@ScreenSingModi); + FadeTo(@ScreenSing); end else begin @@ -1923,14 +2005,14 @@ begin end; //Team No of Team (0-5) -procedure TScreenSong.DoJoker (Team: byte); +procedure TScreenSong.DoJoker (Team: integer); begin if (Mode = smPartyMode) and - (PartySession.Teams.NumTeams >= Team + 1) and - (PartySession.Teams.Teaminfo[Team].Joker > 0) then + (High(Party.Teams) >= Team) and + (Party.Teams[Team].JokersLeft > 0) then begin //Use Joker - Dec(PartySession.Teams.Teaminfo[Team].Joker); + Dec(Party.Teams[Team].JokersLeft); SelectRandomSong; SetJoker; end; @@ -1939,8 +2021,6 @@ end; //Detailed Cover Unloading. Unloads the Detailed, uncached Cover of the cur. Song procedure TScreenSong.UnloadDetailedCover; begin - CoverTime := 0; - // show cached texture Button[Interaction].Texture := Texture.GetTexture(Button[Interaction].Texture.Name, TEXTURE_TYPE_PLAIN, true); Button[Interaction].Texture2.Alpha := 0; @@ -1955,7 +2035,7 @@ begin CatSongs.Refresh; CatSongs.ShowCategoryList; Interaction := 0; - SelectNext; + SelectNext(true); FixSelected; } end; diff --git a/cmake/src/screens/UScreenSongJumpto.pas b/cmake/src/screens/UScreenSongJumpto.pas index e55a6276..b3d48679 100644 --- a/cmake/src/screens/UScreenSongJumpto.pas +++ b/cmake/src/screens/UScreenSongJumpto.pas @@ -34,42 +34,39 @@ interface {$I switches.inc} uses - UMenu, SDL, + SysUtils, + UMenu, UDisplay, UMusic, UFiles, - SysUtils, + USongs, UThemes; type TScreenSongJumpto = class(TMenu) private //For ChangeMusic - LastPlayed: integer; - VisibleBool: boolean; - public - VisSongs: integer; + fLastPlayed: integer; + fVisible: boolean; + fSelectType: TSongFilter; + fVisSongs: integer; - constructor Create; override; + procedure SetTextFound(Count: Cardinal); //Visible //Whether the Menu should be Drawn //Whether the Menu should be Drawn procedure SetVisible(Value: boolean); - property Visible: boolean read VisibleBool write SetVisible; + public + constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; function Draw: boolean; override; - procedure SetTextFound(const Count: cardinal); + property Visible: boolean read fVisible write SetVisible; end; -var - IType: array [0..2] of string; - SelectType: integer; - - implementation uses @@ -79,26 +76,24 @@ uses UTexture, ULanguage, UParty, - USongs, UScreenSong, - ULog; + ULog, + UUnicodeUtils; -function TScreenSongJumpto.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenSongJumpto.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case CharCode of - '0'..'9', 'a'..'z', 'A'..'Z', ' ', '-', '_', '!', ',', '<', '/', '*', '?', '''', '"', - '[', '{', ';', ':': - begin - if Interaction = 0 then - begin - Button[0].Text[0].Text := Button[0].Text[0].Text + CharCode; - SetTextFound(CatSongs.SetFilter(Button[0].Text[0].Text, SelectType)); - end; - end; + if (IsAlphaNumericChar(CharCode) or + IsPunctuationChar(CharCode)) then + begin + if (Interaction = 0) then + begin + Button[0].Text[0].Text := Button[0].Text[0].Text + UCS4ToUTF8String(CharCode); + SetTextFound(CatSongs.SetFilter(Button[0].Text[0].Text, fSelectType)); + end; end; // check special keys @@ -107,8 +102,8 @@ begin begin if (Interaction = 0) and (Length(Button[0].Text[0].Text) > 0) then begin - Button[0].Text[0].DeleteLastL; - SetTextFound(CatSongs.SetFilter(Button[0].Text[0].Text, SelectType)); + Button[0].Text[0].DeleteLastLetter(); + SetTextFound(CatSongs.SetFilter(Button[0].Text[0].Text, fSelectType)); end; end; @@ -117,18 +112,15 @@ begin begin Visible := false; AudioPlayback.PlaySound(SoundLib.Back); - if (VisSongs = 0) and (Length(Button[0].Text[0].Text) > 0) then + if (fVisSongs = 0) and (Length(Button[0].Text[0].Text) > 0) then begin ScreenSong.UnLoadDetailedCover; Button[0].Text[0].Text := ''; - CatSongs.SetFilter('', 0); + CatSongs.SetFilter('', fltAll); SetTextFound(0); end; end; - // Up and Down could be done at the same time, - // but I don't want to declare variables inside - // functions like this one, called so many times SDLK_DOWN: begin {SelectNext; @@ -146,7 +138,7 @@ begin Interaction := 1; InteractInc; if (Length(Button[0].Text[0].Text) > 0) then - SetTextFound(CatSongs.SetFilter(Button[0].Text[0].Text, SelectType)); + SetTextFound(CatSongs.SetFilter(Button[0].Text[0].Text, fSelectType)); Interaction := 0; end; SDLK_LEFT: @@ -154,7 +146,7 @@ begin Interaction := 1; InteractDec; if (Length(Button[0].Text[0].Text) > 0) then - SetTextFound(CatSongs.SetFilter(Button[0].Text[0].Text, SelectType)); + SetTextFound(CatSongs.SetFilter(Button[0].Text[0].Text, fSelectType)); Interaction := 0; end; end; @@ -162,8 +154,6 @@ begin end; constructor TScreenSongJumpto.Create; -//var -// I: integer; // Auto Removed, Unused Variable begin inherited Create; @@ -175,23 +165,23 @@ begin if (Length(Button[0].Text) = 0) then AddButtonText(14, 20, ''); - SelectType := 0; - AddSelectSlide(Theme.SongJumpto.SelectSlideType, SelectType, Theme.SongJumpto.IType); + fSelectType := fltAll; + AddSelectSlide(Theme.SongJumpto.SelectSlideType, PInteger(@fSelectType)^, Theme.SongJumpto.IType); Interaction := 0; - LastPlayed := 0; + fLastPlayed := 0; end; procedure TScreenSongJumpto.SetVisible(Value: boolean); begin -//If change from unvisible to Visible then OnShow - if (VisibleBool = false) and (Value = true) then +//If change from invisible to Visible then OnShow + if (fVisible = false) and (Value = true) then OnShow; - VisibleBool := Value; + fVisible := Value; end; -procedure TScreenSongJumpto.onShow; +procedure TScreenSongJumpto.OnShow; begin inherited; @@ -208,7 +198,7 @@ begin Interaction := 0; Button[0].Text[0].Selected := true; - LastPlayed := ScreenSong.Interaction; + fLastPlayed := ScreenSong.Interaction; end; function TScreenSongJumpto.Draw: boolean; @@ -216,7 +206,7 @@ begin Result := inherited Draw; end; -procedure TScreenSongJumpto.SetTextFound(const Count: cardinal); +procedure TScreenSongJumpto.SetTextFound(Count: cardinal); begin if (Count = 0) then begin @@ -235,7 +225,7 @@ begin end; //Set visSongs - VisSongs := Count; + fVisSongs := Count; //Fix SongSelection ScreenSong.Interaction := high(CatSongs.Song); @@ -243,9 +233,12 @@ begin ScreenSong.FixSelected; //Play Correct Music - if (ScreenSong.Interaction <> LastPlayed) then + if (ScreenSong.Interaction <> fLastPlayed) or (CatSongs.VisibleSongs = 0) then begin - LastPlayed := ScreenSong.Interaction; + if (CatSongs.VisibleSongs > 0) then + fLastPlayed := ScreenSong.Interaction + else + fLastPlayed := -1; ScreenSong.ChangeMusic; end; diff --git a/cmake/src/screens/UScreenSongMenu.pas b/cmake/src/screens/UScreenSongMenu.pas index 0af94a8f..173ac2c8 100644 --- a/cmake/src/screens/UScreenSongMenu.pas +++ b/cmake/src/screens/UScreenSongMenu.pas @@ -50,8 +50,8 @@ type Visible: boolean; // whether the menu should be drawn constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; function Draw: boolean; override; procedure MenuShow(sMenu: byte); procedure HandleReturn; @@ -73,7 +73,7 @@ const SM_Party_Joker = 128 or 2; var - ISelections: array of string; + ISelections: array of UTF8String; SelectValue: integer; implementation @@ -86,9 +86,10 @@ uses ULanguage, UParty, UPlaylist, - USongs; + USongs, + UUnicodeUtils; -function TScreenSongMenu.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenSongMenu.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then @@ -96,27 +97,29 @@ begin if (CurMenu = SM_Playlist_New) and (Interaction=0) then begin // check normal keys - case WideCharUpperCase(CharCode)[1] of - '0'..'9', 'A'..'Z', ' ', '-', '_', '!', ',', '<', '/', '*', '?', '''', '"': - begin - Button[Interaction].Text[0].Text := Button[Interaction].Text[0].Text + CharCode; - exit; - end; + if IsAlphaNumericChar(CharCode) or + (CharCode in [Ord(' '), Ord('-'), Ord('_'), Ord('!'), + Ord(','), Ord('<'), Ord('/'), Ord('*'), + Ord('?'), Ord(''''), Ord('"')]) then + begin + Button[Interaction].Text[0].Text := Button[Interaction].Text[0].Text + + UCS4ToUTF8String(CharCode); + exit; end; // check special keys case PressedKey of SDLK_BACKSPACE: begin - Button[Interaction].Text[0].DeleteLastL; + Button[Interaction].Text[0].DeleteLastLetter; exit; end; end; end; // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -223,7 +226,7 @@ begin Result := inherited Draw; end; -procedure TScreenSongMenu.onShow; +procedure TScreenSongMenu.OnShow; begin inherited; end; @@ -398,16 +401,19 @@ begin begin CurMenu := sMenu; Text[0].Text := Language.Translate('SONG_MENU_NAME_PARTY_JOKER'); - - Button[0].Visible := (PartySession.Teams.NumTeams >= 1) and (PartySession.Teams.Teaminfo[0].Joker > 0); - Button[1].Visible := (PartySession.Teams.NumTeams >= 2) and (PartySession.Teams.Teaminfo[1].Joker > 0); - Button[2].Visible := (PartySession.Teams.NumTeams >= 3) and (PartySession.Teams.Teaminfo[2].Joker > 0); - Button[3].Visible := true; - SelectsS[0].Visible := false; - - Button[0].Text[0].Text := string(PartySession.Teams.Teaminfo[0].Name); - Button[1].Text[0].Text := string(PartySession.Teams.Teaminfo[1].Name); - Button[2].Text[0].Text := string(PartySession.Teams.Teaminfo[2].Name); + // to-do : Party + Button[0].Visible := (Length(Party.Teams) >= 1) AND (Party.Teams[0].JokersLeft > 0); + Button[1].Visible := (Length(Party.Teams) >= 2) AND (Party.Teams[1].JokersLeft > 0); + Button[2].Visible := (Length(Party.Teams) >= 3) AND (Party.Teams[2].JokersLeft > 0); + Button[3].Visible := True; + SelectsS[0].Visible := False; + + if (Button[0].Visible) then + Button[0].Text[0].Text := UTF8String(Party.Teams[0].Name); + if (Button[1].Visible) then + Button[1].Text[0].Text := UTF8String(Party.Teams[1].Name); + if (Button[2].Visible) then + Button[2].Text[0].Text := UTF8String(Party.Teams[2].Name); Button[3].Text[0].Text := Language.Translate('SONG_MENU_CANCEL'); // set right interaction @@ -611,7 +617,7 @@ begin 0: // button 1 begin // start singing - ScreenSong.StartSong; + Party.CallAfterSongSelect; Visible := false; end; diff --git a/cmake/src/screens/UScreenStatDetail.pas b/cmake/src/screens/UScreenStatDetail.pas index bbbb4a1b..1638cd85 100644 --- a/cmake/src/screens/UScreenStatDetail.pas +++ b/cmake/src/screens/UScreenStatDetail.pas @@ -55,8 +55,8 @@ type TotPages: cardinal; constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; procedure SetAnimationProgress(Progress: real); override; procedure SetTitle; @@ -66,20 +66,21 @@ type implementation uses - UGraphic, - ULanguage, Math, Classes, - ULog; + UGraphic, + ULanguage, + ULog, + UUnicodeUtils; -function TScreenStatDetail.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; +function TScreenStatDetail.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -178,7 +179,7 @@ begin Typ := TStatType(0); end; -procedure TScreenStatDetail.onShow; +procedure TScreenStatDetail.OnShow; begin inherited; @@ -233,7 +234,7 @@ begin if (Score > 0) then begin Text[I].Text := Format(FormatStr, - [Singer, Score, Theme.ILevel[Difficulty], SongArtist, SongTitle]); + [Singer, Score, Theme.ILevel[Difficulty], SongArtist, SongTitle, Date]); end; end; end; diff --git a/cmake/src/screens/UScreenStatMain.pas b/cmake/src/screens/UScreenStatMain.pas index 2fd91288..204f40cd 100644 --- a/cmake/src/screens/UScreenStatMain.pas +++ b/cmake/src/screens/UScreenStatMain.pas @@ -47,14 +47,14 @@ type private //Some Stat Value that don't need to be calculated 2 times SongsWithVid: cardinal; - function FormatOverviewIntro(FormatStr: string): string; - function FormatSongOverview(FormatStr: string): string; - function FormatPlayerOverview(FormatStr: string): string; + function FormatOverviewIntro(FormatStr: UTF8String): UTF8String; + function FormatSongOverview(FormatStr: UTF8String): UTF8String; + function FormatPlayerOverview(FormatStr: UTF8String): UTF8String; public TextOverview: integer; constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - procedure onShow; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; + procedure OnShow; override; procedure SetAnimationProgress(Progress: real); override; procedure SetOverview; @@ -70,21 +70,17 @@ uses ULanguage, UCommon, Classes, - {$IFDEF win32} - windows, - {$ELSE} - sysconst, - {$ENDIF} - ULog; - -function TScreenStatMain.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; + ULog, + UUnicodeUtils; + +function TScreenStatMain.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if (PressedDown) then begin // Key Down // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -170,11 +166,11 @@ begin //Set Songs with Vid SongsWithVid := 0; for I := 0 to Songs.SongList.Count -1 do - if (TSong(Songs.SongList[I]).Video <> '') then + if (TSong(Songs.SongList[I]).Video.IsSet) then Inc(SongsWithVid); end; -procedure TScreenStatMain.onShow; +procedure TScreenStatMain.OnShow; begin inherited; @@ -182,7 +178,7 @@ begin SetOverview; end; -function TScreenStatMain.FormatOverviewIntro(FormatStr: string): string; +function TScreenStatMain.FormatOverviewIntro(FormatStr: UTF8String): UTF8String; var Year, Month, Day: word; begin @@ -203,10 +199,10 @@ begin end; end; -function TScreenStatMain.FormatSongOverview(FormatStr: string): string; +function TScreenStatMain.FormatSongOverview(FormatStr: UTF8String): UTF8String; var CntSongs, CntSungSongs, CntVidSongs: integer; - MostPopSongArtist, MostPopSongTitle: string; + MostPopSongArtist, MostPopSongTitle: UTF8String; StatList: TList; MostSungSong: TStatResultMostSungSong; begin @@ -247,12 +243,12 @@ begin end; end; -function TScreenStatMain.FormatPlayerOverview(FormatStr: string): string; +function TScreenStatMain.FormatPlayerOverview(FormatStr: UTF8String): UTF8String; var CntPlayers: integer; BestScoreStat: TStatResultBestScores; BestSingerStat: TStatResultBestSingers; - BestPlayer, BestScorePlayer: string; + BestPlayer, BestScorePlayer: UTF8String; BestPlayerScore, BestScore: integer; SingerStats, ScoreStats: TList; begin @@ -307,7 +303,7 @@ end; procedure TScreenStatMain.SetOverview; var - Overview: string; + Overview: UTF8String; begin // Format overview Overview := FormatOverviewIntro(Language.Translate('STAT_OVERVIEW_INTRO')) + '\n \n' + diff --git a/cmake/src/screens/UScreenTop5.pas b/cmake/src/screens/UScreenTop5.pas index 1013a9b5..705d1e35 100644 --- a/cmake/src/screens/UScreenTop5.pas +++ b/cmake/src/screens/UScreenTop5.pas @@ -47,18 +47,21 @@ type public TextLevel: integer; TextArtistTitle: integer; + DifficultyShow: integer; StaticNumber: array[1..5] of integer; TextNumber: array[1..5] of integer; TextName: array[1..5] of integer; TextScore: array[1..5] of integer; + TextDate: array[1..5] of integer; Fadeout: boolean; constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; + function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; function ParseMouse(MouseButton: integer; BtnDown: boolean; X, Y: integer): boolean; override; - procedure onShow; override; + procedure OnShow; override; + procedure DrawScores(difficulty: integer); function Draw: boolean; override; end; @@ -67,19 +70,19 @@ implementation uses UDataBase, UGraphic, + UMain, UIni, - UNote; + UNote, + UUnicodeUtils; -function TScreenTop5.ParseInput(PressedKey: cardinal; - CharCode: WideChar; - PressedDown: boolean): boolean; +function TScreenTop5.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; begin Result := true; if PressedDown then begin // check normal keys - case WideCharUpperCase(CharCode)[1] of - 'Q': + case UCS4UpperCase(CharCode) of + Ord('Q'): begin Result := false; Exit; @@ -98,6 +101,34 @@ begin Fadeout := true; end; end; + SDLK_RIGHT: + begin + inc(DifficultyShow); + if (DifficultyShow>2) then + DifficultyShow:=0; + DrawScores(DifficultyShow); + end; + SDLK_LEFT: + begin + dec(DifficultyShow); + if (DifficultyShow<0) then + DifficultyShow:=2; + DrawScores(DifficultyShow); + end; + SDLK_UP: + begin + inc(DifficultyShow); + if (DifficultyShow>2) then + DifficultyShow:=0; + DrawScores(DifficultyShow); + end; + SDLK_DOWN: + begin + dec(DifficultyShow); + if (DifficultyShow<0) then + DifficultyShow:=2; + DrawScores(DifficultyShow); + end; SDLK_SYSREQ: begin Display.SaveScreenShot; @@ -113,7 +144,7 @@ begin Result := true; if (MouseButton = SDL_BUTTON_LEFT) and BtnDown then //left-click anywhere sends return - ParseInput(SDLK_RETURN, #0, true); + ParseInput(SDLK_RETURN, 0, true); end; constructor TScreenTop5.Create; @@ -133,18 +164,22 @@ begin TextNumber[I+1] := AddText (Theme.Top5.TextNumber[I]); TextName[I+1] := AddText (Theme.Top5.TextName[I]); TextScore[I+1] := AddText (Theme.Top5.TextScore[I]); + TextDate[I+1] := AddText (Theme.Top5.TextDate[I]); end; end; -procedure TScreenTop5.onShow; +procedure TScreenTop5.OnShow; var I: integer; PMax: integer; + sung: boolean; //score added? otherwise in wasn't sung! begin inherited; + sung := false; Fadeout := false; + DifficultyShow := Ini.Difficulty; //ReadScore(CurrentSong); @@ -152,35 +187,74 @@ begin if PMax = 4 then PMax := 5; for I := 0 to PMax do - DataBase.AddScore(CurrentSong, Ini.Difficulty, Ini.Name[I], Round(Player[I].ScoreTotalInt)); + begin + if (Round(Player[I].ScoreTotalInt) > 0) and (ScreenSing.SungToEnd) then + begin + DataBase.AddScore(CurrentSong, Ini.Difficulty, Ini.Name[I], Round(Player[I].ScoreTotalInt)); + sung:=true; + end; + end; - DataBase.WriteScore(CurrentSong); + if sung then + DataBase.WriteScore(CurrentSong); DataBase.ReadScore(CurrentSong); Text[TextArtistTitle].Text := CurrentSong.Artist + ' - ' + CurrentSong.Title; for I := 1 to Length(CurrentSong.Score[Ini.Difficulty]) do begin - Static[StaticNumber[I]].Visible := true; + Statics[StaticNumber[I]].Visible := true; Text[TextNumber[I]].Visible := true; Text[TextName[I]].Visible := true; Text[TextScore[I]].Visible := true; + Text[TextDate[I]].Visible := true; Text[TextName[I]].Text := CurrentSong.Score[Ini.Difficulty, I-1].Name; Text[TextScore[I]].Text := IntToStr(CurrentSong.Score[Ini.Difficulty, I-1].Score); + Text[TextDate[I]].Text := CurrentSong.Score[Ini.Difficulty, I-1].Date; end; for I := Length(CurrentSong.Score[Ini.Difficulty]) + 1 to 5 do begin - Static[StaticNumber[I]].Visible := false; + Statics[StaticNumber[I]].Visible := false; Text[TextNumber[I]].Visible := false; Text[TextName[I]].Visible := false; Text[TextScore[I]].Visible := false; + Text[TextDate[I]].Visible := false; end; Text[TextLevel].Text := IDifficulty[Ini.Difficulty]; end; +procedure TScreenTop5.DrawScores(difficulty: integer); +var + I: integer; +begin + for I := 1 to Length(CurrentSong.Score[difficulty]) do + begin + Statics[StaticNumber[I]].Visible := true; + Text[TextNumber[I]].Visible := true; + Text[TextName[I]].Visible := true; + Text[TextScore[I]].Visible := true; + Text[TextDate[I]].Visible := true; + + Text[TextName[I]].Text := CurrentSong.Score[difficulty, I-1].Name; + Text[TextScore[I]].Text := IntToStr(CurrentSong.Score[difficulty, I-1].Score); + Text[TextDate[I]].Text := CurrentSong.Score[difficulty, I-1].Date; + end; + + for I := Length(CurrentSong.Score[difficulty]) + 1 to 5 do + begin + Statics[StaticNumber[I]].Visible := false; + Text[TextNumber[I]].Visible := false; + Text[TextName[I]].Visible := false; + Text[TextScore[I]].Visible := false; + Text[TextDate[I]].Visible := false; + end; + + Text[TextLevel].Text := IDifficulty[difficulty]; +end; + function TScreenTop5.Draw: boolean; //var { @@ -208,18 +282,18 @@ begin if ScreenAct = 1 then begin LoadColor( - Static[StaticBoxLightest[Item]].Texture.ColR, - Static[StaticBoxLightest[Item]].Texture.ColG, - Static[StaticBoxLightest[Item]].Texture.ColB, + Statics[StaticBoxLightest[Item]].Texture.ColR, + Statics[StaticBoxLightest[Item]].Texture.ColG, + Statics[StaticBoxLightest[Item]].Texture.ColB, 'P1Dark'); end; if ScreenAct = 2 then begin LoadColor( - Static[StaticBoxLightest[Item]].Texture.ColR, - Static[StaticBoxLightest[Item]].Texture.ColG, - Static[StaticBoxLightest[Item]].Texture.ColB, + Statics[StaticBoxLightest[Item]].Texture.ColR, + Statics[StaticBoxLightest[Item]].Texture.ColG, + Statics[StaticBoxLightest[Item]].Texture.ColB, 'P4Dark'); end; } diff --git a/cmake/src/screens/UScreenWelcome.pas b/cmake/src/screens/UScreenWelcome.pas deleted file mode 100644 index a00a84e2..00000000 --- a/cmake/src/screens/UScreenWelcome.pas +++ /dev/null @@ -1,164 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenWelcome; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - SysUtils, - UThemes; - -type - TScreenWelcome = class(TMenu) - public - Animation: real; - Fadeout: boolean; - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; override; - function Draw: boolean; override; - procedure onShow; override; - end; - -implementation - -uses - UGraphic, - UTime, - USkins, - UTexture; - -function TScreenWelcome.ParseInput(PressedKey: cardinal; CharCode: WideChar; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - Result := false; - end; - SDLK_RETURN: - begin - FadeTo(@ScreenMain); - Fadeout := true; - end; - end; - end; -end; - -constructor TScreenWelcome.Create; -begin - inherited Create; - AddStatic(-10, -10, 0, 0, 1, 1, 1, Skin.GetTextureFileName('ButtonAlt'), TEXTURE_TYPE_TRANSPARENT); - AddStatic(-500, 440, 200, 5, 0, 0, 0, Skin.GetTextureFileName('Rectangle'), TEXTURE_TYPE_COLORIZED); - AddStatic(-500, 472, 200, 5, 0, 0, 0, Skin.GetTextureFileName('Rectangle'), TEXTURE_TYPE_COLORIZED); - AddStatic(-500, 504, 200, 5, 0, 0, 0, Skin.GetTextureFileName('Rectangle'), TEXTURE_TYPE_COLORIZED); - AddStatic(-500, 536, 200, 5, 0, 0, 0, Skin.GetTextureFileName('Rectangle'), TEXTURE_TYPE_COLORIZED); - AddStatic(-500, 568, 200, 5, 0, 0, 0, Skin.GetTextureFileName('Rectangle'), TEXTURE_TYPE_COLORIZED); - Animation := 0; - Fadeout := false; -end; - -procedure TScreenWelcome.onShow; -begin - inherited; - - CountSkipTimeSet; -end; - -function TScreenWelcome.Draw: boolean; -var - Min: real; - Max: real; - Factor: real; - Count: integer; -begin - // star animation - Animation := Animation + TimeSkip*1000; - - // draw nothing - Min := 0; Max := 1000; - if (Animation >= Min) and (Animation < Max) then - begin - end; - - // popup - Min := 1000; Max := 1120; - if (Animation >= Min) and (Animation < Max) then - begin - Factor := (Animation - Min) / (Max - Min); - Static[0].Texture.X := 600; - Static[0].Texture.Y := 600 - Factor * 230; - Static[0].Texture.W := 200; - Static[0].Texture.H := Factor * 230; - end; - - // bounce - Min := 1120; Max := 1200; - if (Animation >= Min) and (Animation < Max) then - begin - Factor := (Animation - Min) / (Max - Min); - Static[0].Texture.Y := 370 + Factor * 50; - Static[0].Texture.H := 230 - Factor * 50; - end; - - // run - Min := 1500; Max := 3500; - if (Animation >= Min) and (Animation < Max) then - begin - Factor := (Animation - Min) / (Max - Min); - - Static[0].Texture.X := 600 - Factor * 1400; - Static[0].Texture.H := 180; - - for Count := 1 to 5 do - begin - Static[Count].Texture.X := 770 - Factor * 1400; - Static[Count].Texture.W := 150 + Factor * 200; - Static[Count].Texture.Alpha := Factor * 0.5; - end; - end; - - Min := 3500; - if (Animation >= Min) and (not Fadeout) then - begin - FadeTo(@ScreenMain); - Fadeout := true; - end; - - Result := inherited Draw; -end; - -end. diff --git a/cmake/src/switches.inc b/cmake/src/switches.inc index 17ebd1b8..b9fcd2d6 100644 --- a/cmake/src/switches.inc +++ b/cmake/src/switches.inc @@ -9,14 +9,28 @@ {$ELSE} {$DEFINE Delphi} - // Delphi version numbers (ignore versions released before Delphi 6 as they miss the $IF directive): - // Delphi 6 (VER140), Delphi 7 (VER150), Delphi 8 (VER160) - // Delphi 9/2005 (VER170), Delphi 10/2006 (VER180) + // Delphi version numbers (ignore Delphi < 7 and Delphi 8 (VER160)) + + {$IF Defined(VER180)} // Delphi 2006 (=10) + {$DEFINE DELPHI_10} + {$DEFINE DELPHI_7_UP} + {$DEFINE DELPHI_9_UP} + {$DEFINE DELPHI_10_UP} + {$ELSEIF Defined(VER170)} // Delphi 2005 (=9) + {$DEFINE DELPHI_9} + {$DEFINE DELPHI_7_UP} + {$DEFINE DELPHI_9_UP} + {$ELSEIF Defined(VER150)} + {$DEFINE DELPHI_7} + {$DEFINE DELPHI_7_UP} + {$ELSE} // unsupported + {$WARN ERROR 'Unsupported compiler version'} + {$IFEND} - // the inline-procedure directive was introduced with Delphi 2005 - {$IF not (Defined(VER140) or Defined(VER150) or Defined(VER160))} + // inline directive introduced with Delphi 2005 + {$IFDEF DELPHI_9_UP} {$DEFINE HasInline} - {$IFEND} + {$ENDIF} {$ENDIF} @@ -59,8 +73,6 @@ {$DEFINE CONSOLE} {$IFEND} -{.$DEFINE UseFreetype} - // audio config {$IF Defined(HaveBASS)} {$DEFINE UseBASSPlayback} diff --git a/cmake/src/ultrastardx.dpr b/cmake/src/ultrastardx.dpr index 11796cfa..f6c9558c 100644 --- a/cmake/src/ultrastardx.dpr +++ b/cmake/src/ultrastardx.dpr @@ -26,7 +26,7 @@ program ultrastardx; {$IFDEF MSWINDOWS} - {$R '..\icons\ultrastardx-icon.res' '..\icons\ultrastardx-icon.rc'} + {$R '..\res\ultrastardx.res' '..\res\ultrastardx.rc'} {$ENDIF} {$IFDEF FPC} @@ -50,11 +50,7 @@ uses {$IFDEF Unix} cthreads, // THIS MUST be the first used unit in FPC if Threads are used!! // (see http://wiki.lazarus.freepascal.org/Multithreaded_Application_Tutorial) - // cwstring crashes in FPC 2.2.2 so do not use the cwstring stuff - {.$IFNDEF DARWIN} - {$IFDEF NOIGNORE} - cwstring, // Enable Unicode support. MacOSX misses some references to iconv. - {$ENDIF} + cwstring, // Enable Unicode support {$ENDIF} {$IFNDEF FPC} @@ -71,16 +67,12 @@ uses sdl in 'lib\JEDI-SDL\SDL\Pas\sdl.pas', sdl_image in 'lib\JEDI-SDL\SDL_Image\Pas\sdl_image.pas', sdlutils in 'lib\JEDI-SDL\SDL\Pas\sdlutils.pas', + sdlstreams in 'lib\JEDI-SDL\SDL\Pas\sdlstreams.pas', UMediaCore_SDL in 'media\UMediaCore_SDL.pas', zlib in 'lib\zlib\zlib.pas', png in 'lib\libpng\png.pas', - - {$IFDEF UseFreetype} freetype in 'lib\freetype\freetype.pas', - UFont in 'base\UFont.pas', - UTextEncoding in 'base\UTextEncoding.pas', - {$ENDIF} {$IFDEF UseBass} bass in 'lib\bass\delphi\bass.pas', @@ -136,10 +128,39 @@ uses {$IFDEF DARWIN} PseudoThread in 'macosx\PseudoThread.pas', {$ENDIF} - + SQLiteTable3 in 'lib\SQLite\SQLiteTable3.pas', SQLite3 in 'lib\SQLite\SQLite3.pas', + pcre in 'lib\pcre\pcre.pas', + + {$IFDEF MSWINDOWS} + // TntUnicodeControls + TntSystem in 'lib\TntUnicodeControls\TntSystem.pas', + TntSysUtils in 'lib\TntUnicodeControls\TntSysUtils.pas', + TntWindows in 'lib\TntUnicodeControls\TntWindows.pas', + TntWideStrUtils in 'lib\TntUnicodeControls\TntWideStrUtils.pas', + TntClasses in 'lib\TntUnicodeControls\TntClasses.pas', + TntFormatStrUtils in 'lib\TntUnicodeControls\TntFormatStrUtils.pas', + {$IFNDEF DELPHI_10_UP} // WideStrings for FPC and Delphi < 2006 + TntWideStrings in 'lib\TntUnicodeControls\TntWideStrings.pas', + {$ENDIF} + {$ENDIF} + + //------------------------------ + //Includes - Lua Support + //------------------------------ + ULua in 'lib\Lua\ULua.pas', + ULuaUtils in 'lua\ULuaUtils.pas', + ULuaGl in 'lua\ULuaGl.pas', + ULuaLog in 'lua\ULuaLog.pas', + ULuaTextGL in 'lua\ULuaTextGL.pas', + ULuaTexture in 'lua\ULuaTexture.pas', + UHookableEvent in 'lua\UHookableEvent.pas', + ULuaCore in 'lua\ULuaCore.pas', + ULuaUsdx in 'lua\ULuaUsdx.pas', + ULuaParty in 'lua\ULuaParty.pas', + ULuaScreenSing in 'lua\ULuaScreenSing.pas', //------------------------------ //Includes - Menu System @@ -175,7 +196,6 @@ uses UDraw in 'base\UDraw.pas', URecord in 'base\URecord.pas', UTime in 'base\UTime.pas', - TextGL in 'base\TextGL.pas', USong in 'base\USong.pas', UXMLSong in 'base\UXMLSong.pas', USongs in 'base\USongs.pas', @@ -192,16 +212,23 @@ uses UCatCovers in 'base\UCatCovers.pas', UFiles in 'base\UFiles.pas', UGraphicClasses in 'base\UGraphicClasses.pas', - UDLLManager in 'base\UDLLManager.pas', UPlaylist in 'base\UPlaylist.pas', UCommandLine in 'base\UCommandLine.pas', URingBuffer in 'base\URingBuffer.pas', USingScores in 'base\USingScores.pas', USingNotes in 'base\USingNotes.pas', - UPath in 'base\UPath.pas', + UPathUtils in 'base\UPathUtils.pas', UNote in 'base\UNote.pas', UBeatTimer in 'base\UBeatTimer.pas', + TextGL in 'base\TextGL.pas', + UUnicodeUtils in 'base\UUnicodeUtils.pas', + UFont in 'base\UFont.pas', + UTextEncoding in 'base\UTextEncoding.pas', + + UPath in 'base\UPath.pas', + UFilesystem in 'base\UFilesystem.pas', + //------------------------------ //Includes - Plugin Support //------------------------------ @@ -275,7 +302,6 @@ uses //Includes - Screens //------------------------------ UScreenLoading in 'screens\UScreenLoading.pas', - UScreenWelcome in 'screens\UScreenWelcome.pas', UScreenMain in 'screens\UScreenMain.pas', UScreenName in 'screens\UScreenName.pas', UScreenLevel in 'screens\UScreenLevel.pas', @@ -304,19 +330,13 @@ uses UScreenPopup in 'screens\UScreenPopup.pas', //Includes - Screens PartyMode - UScreenSingModi in 'screens\UScreenSingModi.pas', UScreenPartyNewRound in 'screens\UScreenPartyNewRound.pas', UScreenPartyScore in 'screens\UScreenPartyScore.pas', UScreenPartyPlayer in 'screens\UScreenPartyPlayer.pas', UScreenPartyOptions in 'screens\UScreenPartyOptions.pas', + UScreenPartyRounds in 'screens\UScreenPartyRounds.pas', UScreenPartyWin in 'screens\UScreenPartyWin.pas', - - //------------------------------ - //Includes - Modi SDK - //------------------------------ - ModiSDK in '..\plugins\SDK\ModiSDK.pas', //Old SDK, will be deleted soon - SysUtils; begin |