64bit patch for USDX, thanks to escaped and tronikku. Patch for SDL will be applied soon.

git-svn-id: svn://svn.code.sf.net/p/ultrastardx/svn/trunk@1048 b956fd51-792f-4845-bead-9b4dfca2ff2c

2 files changed, 897 insertions, 855 deletions

diff --git a/Game/Code/Classes/TextGL.pas b/Game/Code/Classes/TextGL.pas
index f078169f..5b37228e 100644
--- a/Game/Code/Classes/TextGL.pas
+++ b/Game/Code/Classes/TextGL.pas
@@ -1,525 +1,541 @@
-unit TextGL;
-
-interface
-
-{$IFDEF FPC}
-  {$MODE Delphi}
-{$ENDIF}
-
-{$I switches.inc}
-
-
-uses
-  OpenGL12,
-  SDL,
-  UTexture,
-  Classes,
-  SDL_ttf,
-  ULog;
-
-procedure BuildFont;			                // Build Our Bitmap Font
-procedure KillFont;     		                // Delete The Font
-function  glTextWidth(text: pchar): real;     // Returns Text Width
-procedure glPrintDone(text: pchar; Done: real; ColR, ColG, ColB: real);
-procedure glPrintLetter(letter: char);
-procedure glPrintLetterCut(letter: char; Start, Finish: real);
-procedure glPrint(text: pchar);	                  // Custom GL "Print" Routine
-procedure glPrintCut(text: pchar);
-procedure SetFontPos(X, Y: real);                     // Sets X And Y
-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);
-
-// Start of SDL_ttf
-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;
-procedure printrandomtext();
-// End of SDL_ttf
-
-type
-  TTextGL = record
-    X:        real;
-    Y:        real;
-    Text:     string;
-    Size:     real;
-    ColR:     real;
-    ColG:     real;
-    ColB:     real;
-  end;
-
-  TFont = record
-    Tex:      TTexture;
-    Width:    array[0..255] of byte;
-    AspectW:  real;
-    Centered: boolean;
-    Done:     real;
-    Outline:  real;
-    Italic:   boolean;
-  end;
-
-
-var
-  base:       GLuint;			                // Base Display List For The Font Set
-  Fonts:      array of TFont;
-  ActFont:    integer;
-  PColR:      real;  // temps for glPrintDone
-  PColG:      real;
-  PColB:      real;
-
-implementation
-
-uses
-  UMain,
-  UCommon,
-  SysUtils,
-  {$IFDEF DARWIN}
-  MacResources,
-  {$ENDIF}
-  UGraphic;
-
-procedure BuildFont;			                // Build Our Bitmap Font
-
-  procedure loadfont(aID : integer; const aType, aResourceName: string);
-  var
-    stream:  TStream;
-  begin
-    stream := GetResourceStream(aResourceName, aType);
-    if (not assigned(stream)) then
-    begin
-      Log.LogError('Unknown font['+ inttostr(aID) +': '+aType+']', 'loadfont');
-      Exit;
-    end;
-    try
-      stream.Read(Fonts[ aID ].Width, 256);
-    except
-      Log.LogError('Error while reading font['+ inttostr(aID) +': '+aType+']', 'loadfont');
-    end;
-    stream.Free;
-  end;
-
-var
-  Count:      integer;
-begin
-  ActFont := 0;
-
-  //Log.LogStatus( '' , '---------------------------');
-
-  //Log.LogStatus( 'Font' , '---------------------------');
-  SetLength(Fonts, 5);
-  Fonts[0].Tex := Texture.LoadTexture(true, 'Font', TEXTURE_TYPE_TRANSPARENT, 0);
-  Fonts[0].Tex.H := 30;
-  Fonts[0].AspectW := 0.9;
-  Fonts[0].Done := -1;
-  Fonts[0].Outline := 0;
-
-  //Log.LogStatus( 'FontB' , '---------------------------');
-
-  Fonts[1].Tex := Texture.LoadTexture(true, 'FontB', TEXTURE_TYPE_TRANSPARENT, 0);
-  Fonts[1].Tex.H := 30;
-  Fonts[1].AspectW := 1;
-  Fonts[1].Done := -1;
-  Fonts[1].Outline := 0;
-
-  //Log.LogStatus( 'FontO' , '---------------------------');
-  Fonts[2].Tex := Texture.LoadTexture(true, 'FontO', TEXTURE_TYPE_TRANSPARENT, 0);
-  Fonts[2].Tex.H := 30;
-  Fonts[2].AspectW := 0.95;
-  Fonts[2].Done := -1;
-  Fonts[2].Outline := 5;
-
-  //Log.LogStatus( 'FontO2' , '---------------------------');
-  Fonts[3].Tex := Texture.LoadTexture(true, 'FontO2', TEXTURE_TYPE_TRANSPARENT, 0);
-  Fonts[3].Tex.H := 30;
-  Fonts[3].AspectW := 0.95;
-  Fonts[3].Done := -1;
-  Fonts[3].Outline := 4;
-
-{  Fonts[4].Tex := Texture.LoadTexture('FontO', TEXTURE_TYPE_TRANSPARENT, 0); // for score screen
-  Fonts[4].Tex.H := 30;
-  Fonts[4].AspectW := 0.95;
-  Fonts[4].Done := -1;
-  Fonts[4].Outline := 5;}
-
-
-
-  loadfont( 0, 'FNT', 'Font'   );
-  loadfont( 1, 'FNT', 'FontB'  );
-  loadfont( 2, 'FNT', 'FontO'  );
-  loadfont( 3, 'FNT', 'FontO2' );
-
-{  Reg := TResourceStream.Create(HInstance, 'FontO', 'FNT');
-  Reg.Read(Fonts[4].Width, 256);
-  Reg.Free;}
-
-  for Count := 0 to 255 do
-    Fonts[1].Width[Count] := Fonts[1].Width[Count] div 2;
-
-  for Count := 0 to 255 do
-    Fonts[2].Width[Count] := Fonts[2].Width[Count] div 2 + 2;
-
-  for Count := 0 to 255 do
-    Fonts[3].Width[Count] := Fonts[3].Width[Count] + 1;
-
-{  for Count := 0 to 255 do
-    Fonts[4].Width[Count] := Fonts[4].Width[Count] div 2 + 2;}
-
-end;
-
-procedure KillFont;     		                // Delete The Font
-begin
-//  glDeleteLists(base, 256); 		                // Delete All 96 Characters
-end;
-
-function glTextWidth(text: pchar): real;
-var
-  Letter: char;
-  i: integer;
-begin
-//  Log.LogStatus(Text, 'glTextWidth');
-  Result := 0;
-  for i := 0 to Length(text) -1 do  //  Patched by AlexanderS : bug with wrong sliced text lines
-  begin
-    Letter := Text[i];
-    // Bugfix: does not work with FPC, probably because a part of text is assigned to itself
-    //text := pchar(Copy(text, 2, Length(text)-1));
-    Result := Result + Fonts[ActFont].Width[Ord(Letter)] * Fonts[ActFont].Tex.H / 30 * Fonts[ActFont].AspectW;
-  end;
-end;
-
-procedure glPrintDone(text: pchar; Done: real; ColR, ColG, ColB: real);
-begin
-  Fonts[ActFont].Done := Done;
-  PColR := ColR;
-  PColG := ColG;
-  PColB := ColB;
-  glPrintCut(text);
-  Fonts[ActFont].Done := -1;
-end;
-
-procedure glPrintLetter(Letter: char);
-var
-  TexX, TexY:   real;
-  TexR, TexB:   real;
-  FWidth:       real;
-  PL, PT:       real;
-  PR, PB:       real;
-  XItal:        real; // X shift for italic type letter
-begin
-  with Fonts[ActFont].Tex do
-  begin
-    FWidth := Fonts[ActFont].Width[Ord(Letter)];
-
-    W := FWidth * (H/30) * Fonts[ActFont].AspectW;
-  //  H := 30;
-
-    // set texture positions
-    TexX := (ord(Letter) mod 16) * 1/16 + 1/32 - FWidth/1024 - Fonts[ActFont].Outline/1024;
-    TexY := (ord(Letter) div 16) * 1/16 + 2/1024; // 2/1024
-    TexR := (ord(Letter) mod 16) * 1/16 + 1/32 + FWidth/1024 + Fonts[ActFont].Outline/1024;
-    TexB := (1 + ord(Letter) div 16) * 1/16 - 2/1024;
-
-    // set vector positions
-    PL := X - Fonts[ActFont].Outline * (H/30) * Fonts[ActFont].AspectW /2;
-    PT := Y;
-    PR := PL + W + Fonts[ActFont].Outline * (H/30) * Fonts[ActFont].AspectW;
-    PB := PT + H;
-
-    if Fonts[ActFont].Italic = false then
-      XItal := 0
-    else
-      XItal := 12;
-
-    glEnable(GL_TEXTURE_2D);
-    glEnable(GL_BLEND);
-    glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
-    glBindTexture(GL_TEXTURE_2D, TexNum);
-
-    glBegin(GL_QUADS);
-    try
-      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);
-    finally
-      glEnd;
-    end;
-
-    X := X + W;
-    glDisable(GL_BLEND);
-    glDisable(GL_TEXTURE_2D);
-  end; // with
-end;
-
-procedure glPrintLetterCut(letter: char; Start, Finish: real);
-var
-  TexX, TexY:   real;
-  TexR, TexB:   real;
-  TexTemp:      real;
-  FWidth:       real;
-  PL, PT:       real;
-  PR, PB:       real;
-  OutTemp:      real;
-  XItal:        real;
-begin
-  with Fonts[ActFont].Tex do begin
-  FWidth := Fonts[ActFont].Width[Ord(Letter)];
-
-  W := FWidth * (H/30) * Fonts[ActFont].AspectW;
-//  H := 30;
-  OutTemp := Fonts[ActFont].Outline * (H/30) * Fonts[ActFont].AspectW;
-
-  // set texture positions
-  TexX := (ord(Letter) mod 16) * 1/16 + 1/32 - FWidth/1024 - Fonts[ActFont].Outline/1024;
-  TexY := (ord(Letter) div 16) * 1/16 + 2/1024; // 2/1024
-  TexR := (ord(Letter) mod 16) * 1/16 + 1/32 + FWidth/1024 + Fonts[ActFont].Outline/1024;
-  TexB := (1 + ord(Letter) div 16) * 1/16 - 2/1024;
-
-  TexTemp := TexX + Start * (TexR - TexX);
-  TexR := TexX + Finish * (TexR - TexX);
-  TexX := TexTemp;
-
-  // set vector positions
-  PL := X - OutTemp / 2 + OutTemp * Start;
-  PT := Y;
-  PR := PL + (W + OutTemp) * (Finish - Start);
-  PB := PT + H;
-  if Fonts[ActFont].Italic = false then
-    XItal := 0
-  else
-    XItal := 12;
-
-  glEnable(GL_TEXTURE_2D);
-  glEnable(GL_BLEND);
-  glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
-  glBindTexture(GL_TEXTURE_2D, 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); // not tested with XItal
-  glEnd;
-  X := X + W * (Finish - Start);
-  glDisable(GL_BLEND);
-  glDisable(GL_TEXTURE_2D);
-  end; // with
-
-end;
-
-procedure glPrint(text: pchar);	                // Custom GL "Print" Routine
-var
-//  Letter :       char;
-  iPos   : Integer;
-
-begin
-  if (Text = '') then     // If There's No Text
-    Exit;					        // Do Nothing
-
-(*
-  while (length(text) > 0) do
-  begin
-    // cut
-    Letter := Text[0];
-    Text   := pchar(Copy(Text, 2, Length(Text)-1));
-
-    // print
-    glPrintLetter(Letter);
-  end; // while
-*)
-
-  // This code is better, because doing a Copy of for every
-  // letter in a string is a waste of CPU & Memory resources.
-  // Copy operations are quite memory intensive, and this simple
-  // code achieves the same result.
-  for iPos := 0 to length( text ) - 1 do
-  begin
-    glPrintLetter( Text[iPos] );
-  end;
-
-end;
-
-function NextPowerOfTwo(Value: Integer): Integer;
-// tyty to Asphyre
-begin
- Result:= 1;
- asm
-  xor ecx, ecx
-  bsr ecx, Value
-  inc ecx
-  shl Result, cl
- end;
-end;
-
-function LoadFont(FileName: PAnsiChar; PointSize: integer):PTTF_Font;
-begin
- if (FileExists(FileName)) then
-   begin
-     Result := TTF_OpenFont( FileName, PointSize );
-   end
- else
-   begin
-     Log.LogStatus('ERROR Could not find font in ' + FileName , '');
-     ShowMessage(  'ERROR Could not find font in ' + FileName );
-     Result := nil;
-   end;
-end;
-
-function RenderText(font: PTTF_Font; Text:PAnsiChar; Color: Cardinal): PSDL_Surface;
-var
-  clr : TSDL_color;
-begin
-  clr.r  := ((Color and $ff0000) shr 16  ) div 255;
-  clr.g  := ((Color and $ff00  ) shr 8   ) div 255;
-  clr.b  := ( Color and $ff    ) div 255 ;
-
-  result := TTF_RenderText_Blended( font, text, cLr);
-end;
-
-procedure printrandomtext();
-var
-  stext,intermediary : PSDL_surface;
-  clrFg, clrBG       : TSDL_color;
-  texture            : Gluint;
-  font               : PTTF_Font;
-  w,h                : integer;
-begin
-
-font := LoadFont('fonts\comicbd.ttf', 42);
-
-clrFg.r := 255;
-clrFg.g := 255;
-clrFg.b := 255;
-clrFg.unused := 255;
-
-clrBg.r := 255;
-clrbg.g := 0;
-clrbg.b := 255;
-clrbg.unused := 0;
-
-  sText := RenderText(font, 'katzeeeeeee', $fe198e);
-//sText :=  TTF_RenderText_Blended( font, 'huuuuuuuuuund', clrFG);
-
-  // Convert the rendered text to a known format
-  w :=  nextpoweroftwo(sText.w);
-  h :=  nextpoweroftwo(sText.h);
-
-intermediary := SDL_CreateRGBSurface(0, w, h, 32,
-			$000000ff, $0000ff00, $00ff0000, $ff000000);
-
- SDL_SetAlpha(intermediary, 0, 255);
- SDL_SetAlpha(sText, 0, 255);
- SDL_BlitSurface(sText, nil, intermediary, nil);
-
- glGenTextures(1, @texture);
-
-  glBindTexture(GL_TEXTURE_2D, texture);
-
-  glTexImage2D(GL_TEXTURE_2D, 0, 4, w, h, 0, GL_RGBA, GL_UNSIGNED_BYTE, intermediary.pixels);
-
-  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
-  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
-
-
-
-
-      glEnable(GL_TEXTURE_2D);
-      glBlendFunc(GL_SRC_ALPHA,GL_ONE_MINUS_SRC_ALPHA);
-      glEnable(GL_BLEND);
-        glBindTexture(GL_TEXTURE_2D, texture);
-        glColor4f(1, 0, 1, 1);
-
-      glbegin(gl_quads);
-        glTexCoord2f(0,0); glVertex2f(200,     300);
-        glTexCoord2f(0,sText.h/h); glVertex2f(200    , 300 + sText.h);
-        glTexCoord2f(sText.w/w,sText.h/h); glVertex2f(200 + sText.w, 300 + sText.h);
-        glTexCoord2f(sText.w/w,0); glVertex2f(200 + sText.w, 300);
-      glEnd;
-      glfinish();
-      glDisable(GL_BLEND);
-      gldisable(gl_texture_2d);
-
-
-
-
-SDL_FreeSurface( sText );
-SDL_FreeSurface( intermediary );
-glDeleteTextures(1, @texture);
-TTF_CloseFont( font );
-
-end;
-
-procedure glPrintCut(text: pchar);
-var
-  Letter:       char;
-  PToDo:        real;
-  PTotWidth:    real;
-  PDoingNow:    real;
-  S:            string;
-begin
-  if (Text = '') then   			        // If There's No Text
-                Exit;					        // Do Nothing
-
-  PTotWidth := glTextWidth(Text);
-  PToDo := Fonts[ActFont].Done;
-
-  while (length(text) > 0) do begin
-    // cut
-    Letter := Text[0];
-    Text := pchar(Copy(Text, 2, Length(Text)-1));
-
-    // analyze
-    S := Letter;
-    PDoingNow := glTextWidth(pchar(S)) / PTotWidth;
-
-    // drawing
-    if (PToDo > 0) and (PDoingNow <= PToDo) then
-      glPrintLetter(Letter);
-
-    if (PToDo > 0) and (PDoingNow > PToDo) then begin
-      glPrintLetterCut(Letter, 0, PToDo / PDoingNow);
-      glColor3f(PColR, PColG,  PColB);
-      glPrintLetterCut(Letter, PToDo / PDoingNow, 1);
-    end;
-
-    if (PToDo <= 0) then
-      glPrintLetter(Letter);
-
-    PToDo := PToDo - PDoingNow;
-
-  end; // while
-end;
-
-
-procedure SetFontPos(X, Y: real);
-begin
-  Fonts[ActFont].Tex.X := X;
-  Fonts[ActFont].Tex.Y := Y;
-end;
-
-procedure SetFontSize(Size: real);
-begin
-  Fonts[ActFont].Tex.H := 30 * (Size/10);
-end;
-
-procedure SetFontStyle(Style: integer);
-begin
-  ActFont := Style;
-end;
-
-procedure SetFontItalic(Enable: boolean);
-begin
-  Fonts[ActFont].Italic := Enable;
-end;
-
-procedure SetFontAspectW(Aspect: real);
-begin
-  Fonts[ActFont].AspectW := Aspect;
-end;
-
-end.
-
-
+unit TextGL;

+

+interface

+

+{$IFDEF FPC}

+  {$MODE Delphi}

+{$ENDIF}

+

+{$I switches.inc}

+

+{$IFDEF FPC}

+  {$ASMMODE Intel}

+{$ENDIF}

+

+uses

+  OpenGL12,

+  SDL,

+  UTexture,

+  Classes,

+  SDL_ttf,

+  ULog;

+

+procedure BuildFont;			                // Build Our Bitmap Font

+procedure KillFont;     		                // Delete The Font

+function  glTextWidth(text: pchar): real;     // Returns Text Width

+procedure glPrintDone(text: pchar; Done: real; ColR, ColG, ColB: real);

+procedure glPrintLetter(letter: char);

+procedure glPrintLetterCut(letter: char; Start, Finish: real);

+procedure glPrint(text: pchar);	                  // Custom GL "Print" Routine

+procedure glPrintCut(text: pchar);

+procedure SetFontPos(X, Y: real);                     // Sets X And Y

+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);

+

+// Start of SDL_ttf

+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;

+procedure printrandomtext();

+// End of SDL_ttf

+

+type

+  TTextGL = record

+    X:        real;

+    Y:        real;

+    Text:     string;

+    Size:     real;

+    ColR:     real;

+    ColG:     real;

+    ColB:     real;

+  end;

+

+  TFont = record

+    Tex:      TTexture;

+    Width:    array[0..255] of byte;

+    AspectW:  real;

+    Centered: boolean;

+    Done:     real;

+    Outline:  real;

+    Italic:   boolean;

+  end;

+

+

+var

+  base:       GLuint;			                // Base Display List For The Font Set

+  Fonts:      array of TFont;

+  ActFont:    integer;

+  PColR:      real;  // temps for glPrintDone

+  PColG:      real;

+  PColB:      real;

+

+implementation

+

+uses

+  UMain,

+  UCommon,

+  SysUtils,

+  {$IFDEF DARWIN}

+  MacResources,

+  {$ENDIF}

+  UGraphic;

+

+procedure BuildFont;			                // Build Our Bitmap Font

+

+  procedure loadfont(aID : integer; const aType, aResourceName: string);

+  var

+    stream:  TStream;

+  begin

+    stream := GetResourceStream(aResourceName, aType);

+    if (not assigned(stream)) then

+    begin

+      Log.LogError('Unknown font['+ inttostr(aID) +': '+aType+']', 'loadfont');

+      Exit;

+    end;

+    try

+      stream.Read(Fonts[ aID ].Width, 256);

+    except

+      Log.LogError('Error while reading font['+ inttostr(aID) +': '+aType+']', 'loadfont');

+    end;

+    stream.Free;

+  end;

+

+var

+  Count:      integer;

+begin

+  ActFont := 0;

+

+  //Log.LogStatus( '' , '---------------------------');

+

+  //Log.LogStatus( 'Font' , '---------------------------');

+  SetLength(Fonts, 5);

+  Fonts[0].Tex := Texture.LoadTexture(true, 'Font', TEXTURE_TYPE_TRANSPARENT, 0);

+  Fonts[0].Tex.H := 30;

+  Fonts[0].AspectW := 0.9;

+  Fonts[0].Done := -1;

+  Fonts[0].Outline := 0;

+

+  //Log.LogStatus( 'FontB' , '---------------------------');

+

+  Fonts[1].Tex := Texture.LoadTexture(true, 'FontB', TEXTURE_TYPE_TRANSPARENT, 0);

+  Fonts[1].Tex.H := 30;

+  Fonts[1].AspectW := 1;

+  Fonts[1].Done := -1;

+  Fonts[1].Outline := 0;

+

+  //Log.LogStatus( 'FontO' , '---------------------------');

+  Fonts[2].Tex := Texture.LoadTexture(true, 'FontO', TEXTURE_TYPE_TRANSPARENT, 0);

+  Fonts[2].Tex.H := 30;

+  Fonts[2].AspectW := 0.95;

+  Fonts[2].Done := -1;

+  Fonts[2].Outline := 5;

+

+  //Log.LogStatus( 'FontO2' , '---------------------------');

+  Fonts[3].Tex := Texture.LoadTexture(true, 'FontO2', TEXTURE_TYPE_TRANSPARENT, 0);

+  Fonts[3].Tex.H := 30;

+  Fonts[3].AspectW := 0.95;

+  Fonts[3].Done := -1;

+  Fonts[3].Outline := 4;

+

+{  Fonts[4].Tex := Texture.LoadTexture('FontO', TEXTURE_TYPE_TRANSPARENT, 0); // for score screen

+  Fonts[4].Tex.H := 30;

+  Fonts[4].AspectW := 0.95;

+  Fonts[4].Done := -1;

+  Fonts[4].Outline := 5;}

+

+

+

+  loadfont( 0, 'FNT', 'Font'   );

+  loadfont( 1, 'FNT', 'FontB'  );

+  loadfont( 2, 'FNT', 'FontO'  );

+  loadfont( 3, 'FNT', 'FontO2' );

+

+{  Reg := TResourceStream.Create(HInstance, 'FontO', 'FNT');

+  Reg.Read(Fonts[4].Width, 256);

+  Reg.Free;}

+

+  for Count := 0 to 255 do

+    Fonts[1].Width[Count] := Fonts[1].Width[Count] div 2;

+

+  for Count := 0 to 255 do

+    Fonts[2].Width[Count] := Fonts[2].Width[Count] div 2 + 2;

+

+  for Count := 0 to 255 do

+    Fonts[3].Width[Count] := Fonts[3].Width[Count] + 1;

+

+{  for Count := 0 to 255 do

+    Fonts[4].Width[Count] := Fonts[4].Width[Count] div 2 + 2;}

+

+end;

+

+procedure KillFont;     		                // Delete The Font

+begin

+//  glDeleteLists(base, 256); 		                // Delete All 96 Characters

+end;

+

+function glTextWidth(text: pchar): real;

+var

+  Letter: char;

+  i: integer;

+begin

+//  Log.LogStatus(Text, 'glTextWidth');

+  Result := 0;

+  for i := 0 to Length(text) -1 do  //  Patched by AlexanderS : bug with wrong sliced text lines

+  begin

+    Letter := Text[i];

+    // Bugfix: does not work with FPC, probably because a part of text is assigned to itself

+    //text := pchar(Copy(text, 2, Length(text)-1));

+    Result := Result + Fonts[ActFont].Width[Ord(Letter)] * Fonts[ActFont].Tex.H / 30 * Fonts[ActFont].AspectW;

+  end;

+end;

+

+procedure glPrintDone(text: pchar; Done: real; ColR, ColG, ColB: real);

+begin

+  Fonts[ActFont].Done := Done;

+  PColR := ColR;

+  PColG := ColG;

+  PColB := ColB;

+  glPrintCut(text);

+  Fonts[ActFont].Done := -1;

+end;

+

+procedure glPrintLetter(Letter: char);

+var

+  TexX, TexY:   real;

+  TexR, TexB:   real;

+  FWidth:       real;

+  PL, PT:       real;

+  PR, PB:       real;

+  XItal:        real; // X shift for italic type letter

+begin

+  with Fonts[ActFont].Tex do

+  begin

+    FWidth := Fonts[ActFont].Width[Ord(Letter)];

+

+    W := FWidth * (H/30) * Fonts[ActFont].AspectW;

+  //  H := 30;

+

+    // set texture positions

+    TexX := (ord(Letter) mod 16) * 1/16 + 1/32 - FWidth/1024 - Fonts[ActFont].Outline/1024;

+    TexY := (ord(Letter) div 16) * 1/16 + 2/1024; // 2/1024

+    TexR := (ord(Letter) mod 16) * 1/16 + 1/32 + FWidth/1024 + Fonts[ActFont].Outline/1024;

+    TexB := (1 + ord(Letter) div 16) * 1/16 - 2/1024;

+

+    // set vector positions

+    PL := X - Fonts[ActFont].Outline * (H/30) * Fonts[ActFont].AspectW /2;

+    PT := Y;

+    PR := PL + W + Fonts[ActFont].Outline * (H/30) * Fonts[ActFont].AspectW;

+    PB := PT + H;

+

+    if Fonts[ActFont].Italic = false then

+      XItal := 0

+    else

+      XItal := 12;

+

+    glEnable(GL_TEXTURE_2D);

+    glEnable(GL_BLEND);

+    glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);

+    glBindTexture(GL_TEXTURE_2D, TexNum);

+

+    glBegin(GL_QUADS);

+    try

+      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);

+    finally

+      glEnd;

+    end;

+

+    X := X + W;

+    glDisable(GL_BLEND);

+    glDisable(GL_TEXTURE_2D);

+  end; // with

+end;

+

+procedure glPrintLetterCut(letter: char; Start, Finish: real);

+var

+  TexX, TexY:   real;

+  TexR, TexB:   real;

+  TexTemp:      real;

+  FWidth:       real;

+  PL, PT:       real;

+  PR, PB:       real;

+  OutTemp:      real;

+  XItal:        real;

+begin

+  with Fonts[ActFont].Tex do begin

+  FWidth := Fonts[ActFont].Width[Ord(Letter)];

+

+  W := FWidth * (H/30) * Fonts[ActFont].AspectW;

+//  H := 30;

+  OutTemp := Fonts[ActFont].Outline * (H/30) * Fonts[ActFont].AspectW;

+

+  // set texture positions

+  TexX := (ord(Letter) mod 16) * 1/16 + 1/32 - FWidth/1024 - Fonts[ActFont].Outline/1024;

+  TexY := (ord(Letter) div 16) * 1/16 + 2/1024; // 2/1024

+  TexR := (ord(Letter) mod 16) * 1/16 + 1/32 + FWidth/1024 + Fonts[ActFont].Outline/1024;

+  TexB := (1 + ord(Letter) div 16) * 1/16 - 2/1024;

+

+  TexTemp := TexX + Start * (TexR - TexX);

+  TexR := TexX + Finish * (TexR - TexX);

+  TexX := TexTemp;

+

+  // set vector positions

+  PL := X - OutTemp / 2 + OutTemp * Start;

+  PT := Y;

+  PR := PL + (W + OutTemp) * (Finish - Start);

+  PB := PT + H;

+  if Fonts[ActFont].Italic = false then

+    XItal := 0

+  else

+    XItal := 12;

+

+  glEnable(GL_TEXTURE_2D);

+  glEnable(GL_BLEND);

+  glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);

+  glBindTexture(GL_TEXTURE_2D, 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); // not tested with XItal

+  glEnd;

+  X := X + W * (Finish - Start);

+  glDisable(GL_BLEND);

+  glDisable(GL_TEXTURE_2D);

+  end; // with

+

+end;

+

+procedure glPrint(text: pchar);	                // Custom GL "Print" Routine

+var

+//  Letter :       char;

+  iPos   : Integer;

+

+begin

+  if (Text = '') then     // If There's No Text

+    Exit;					        // Do Nothing

+

+(*

+  while (length(text) > 0) do

+  begin

+    // cut

+    Letter := Text[0];

+    Text   := pchar(Copy(Text, 2, Length(Text)-1));

+

+    // print

+    glPrintLetter(Letter);

+  end; // while

+*)

+

+  // This code is better, because doing a Copy of for every

+  // letter in a string is a waste of CPU & Memory resources.

+  // Copy operations are quite memory intensive, and this simple

+  // code achieves the same result.

+  for iPos := 0 to length( text ) - 1 do

+  begin

+    glPrintLetter( Text[iPos] );

+  end;

+

+end;

+

+function NextPowerOfTwo(Value: Integer): Integer;

+// tyty to Asphyre

+// FIXME: check if the non-asm version is fast enough and use it by default if so

+begin

+  Result:= 1;

+{$IF Defined(CPUX86_64)}

+  asm

+    mov rcx, -1

+    bsr rcx, Value

+    inc rcx

+    shl Result, cl

+  end;

+{$ELSEIF Defined(CPU386) or Defined(CPUI386)}

+  asm

+    mov ecx, -1

+    bsr ecx, Value

+    inc ecx

+    shl Result, cl

+  end;

+{$ELSE}

+  while (Result <= Value) do

+    Result := 2 * Result;

+{$IFEND}

+end;

+

+function LoadFont(FileName: PAnsiChar; PointSize: integer):PTTF_Font;

+begin

+ if (FileExists(FileName)) then

+   begin

+     Result := TTF_OpenFont( FileName, PointSize );

+   end

+ else

+   begin

+     Log.LogStatus('ERROR Could not find font in ' + FileName , '');

+     ShowMessage(  'ERROR Could not find font in ' + FileName );

+     Result := nil;

+   end;

+end;

+

+function RenderText(font: PTTF_Font; Text:PAnsiChar; Color: Cardinal): PSDL_Surface;

+var

+  clr : TSDL_color;

+begin

+  clr.r  := ((Color and $ff0000) shr 16  ) div 255;

+  clr.g  := ((Color and $ff00  ) shr 8   ) div 255;

+  clr.b  := ( Color and $ff    ) div 255 ;

+

+  result := TTF_RenderText_Blended( font, text, cLr);

+end;

+

+procedure printrandomtext();

+var

+  stext,intermediary : PSDL_surface;

+  clrFg, clrBG       : TSDL_color;

+  texture            : Gluint;

+  font               : PTTF_Font;

+  w,h                : integer;

+begin

+

+font := LoadFont('fonts\comicbd.ttf', 42);

+

+clrFg.r := 255;

+clrFg.g := 255;

+clrFg.b := 255;

+clrFg.unused := 255;

+

+clrBg.r := 255;

+clrbg.g := 0;

+clrbg.b := 255;

+clrbg.unused := 0;

+

+  sText := RenderText(font, 'katzeeeeeee', $fe198e);

+//sText :=  TTF_RenderText_Blended( font, 'huuuuuuuuuund', clrFG);

+

+  // Convert the rendered text to a known format

+  w :=  nextpoweroftwo(sText.w);

+  h :=  nextpoweroftwo(sText.h);

+

+intermediary := SDL_CreateRGBSurface(0, w, h, 32,

+			$000000ff, $0000ff00, $00ff0000, $ff000000);

+

+ SDL_SetAlpha(intermediary, 0, 255);

+ SDL_SetAlpha(sText, 0, 255);

+ SDL_BlitSurface(sText, nil, intermediary, nil);

+

+ glGenTextures(1, @texture);

+

+  glBindTexture(GL_TEXTURE_2D, texture);

+

+  glTexImage2D(GL_TEXTURE_2D, 0, 4, w, h, 0, GL_RGBA, GL_UNSIGNED_BYTE, intermediary.pixels);

+

+  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);

+  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);

+

+

+

+

+      glEnable(GL_TEXTURE_2D);

+      glBlendFunc(GL_SRC_ALPHA,GL_ONE_MINUS_SRC_ALPHA);

+      glEnable(GL_BLEND);

+        glBindTexture(GL_TEXTURE_2D, texture);

+        glColor4f(1, 0, 1, 1);

+

+      glbegin(gl_quads);

+        glTexCoord2f(0,0); glVertex2f(200,     300);

+        glTexCoord2f(0,sText.h/h); glVertex2f(200    , 300 + sText.h);

+        glTexCoord2f(sText.w/w,sText.h/h); glVertex2f(200 + sText.w, 300 + sText.h);

+        glTexCoord2f(sText.w/w,0); glVertex2f(200 + sText.w, 300);

+      glEnd;

+      glfinish();

+      glDisable(GL_BLEND);

+      gldisable(gl_texture_2d);

+

+

+

+

+SDL_FreeSurface( sText );

+SDL_FreeSurface( intermediary );

+glDeleteTextures(1, @texture);

+TTF_CloseFont( font );

+

+end;

+

+procedure glPrintCut(text: pchar);

+var

+  Letter:       char;

+  PToDo:        real;

+  PTotWidth:    real;

+  PDoingNow:    real;

+  S:            string;

+begin

+  if (Text = '') then   			        // If There's No Text

+                Exit;					        // Do Nothing

+

+  PTotWidth := glTextWidth(Text);

+  PToDo := Fonts[ActFont].Done;

+

+  while (length(text) > 0) do begin

+    // cut

+    Letter := Text[0];

+    Text := pchar(Copy(Text, 2, Length(Text)-1));

+

+    // analyze

+    S := Letter;

+    PDoingNow := glTextWidth(pchar(S)) / PTotWidth;

+

+    // drawing

+    if (PToDo > 0) and (PDoingNow <= PToDo) then

+      glPrintLetter(Letter);

+

+    if (PToDo > 0) and (PDoingNow > PToDo) then begin

+      glPrintLetterCut(Letter, 0, PToDo / PDoingNow);

+      glColor3f(PColR, PColG,  PColB);

+      glPrintLetterCut(Letter, PToDo / PDoingNow, 1);

+    end;

+

+    if (PToDo <= 0) then

+      glPrintLetter(Letter);

+

+    PToDo := PToDo - PDoingNow;

+

+  end; // while

+end;

+

+

+procedure SetFontPos(X, Y: real);

+begin

+  Fonts[ActFont].Tex.X := X;

+  Fonts[ActFont].Tex.Y := Y;

+end;

+

+procedure SetFontSize(Size: real);

+begin

+  Fonts[ActFont].Tex.H := 30 * (Size/10);

+end;

+

+procedure SetFontStyle(Style: integer);

+begin

+  ActFont := Style;

+end;

+

+procedure SetFontItalic(Enable: boolean);

+begin

+  Fonts[ActFont].Italic := Enable;

+end;

+

+procedure SetFontAspectW(Aspect: real);

+begin

+  Fonts[ActFont].AspectW := Aspect;

+end;

+

+end.

+

+

diff --git a/Game/Code/Classes/UServices.pas b/Game/Code/Classes/UServices.pas
index 19561eeb..cb03248e 100644
--- a/Game/Code/Classes/UServices.pas
+++ b/Game/Code/Classes/UServices.pas
@@ -1,330 +1,356 @@
-unit UServices;
-
-interface
-
-{$IFDEF FPC}
-  {$MODE Delphi}
-{$ENDIF}
-
-{$I switches.inc}
-
-uses uPluginDefs,
-     SysUtils;
-{*********************
-  TServiceManager
-  Class for saving, managing and calling of Services.
-  Saves all Services and their Procs
-*********************}
-
-type
-  TServiceName = String[60];
-  PServiceInfo = ^TServiceInfo;
-  TServiceInfo = record
-    Self: THandle; //Handle of this Service
-    Hash: Integer; //4 Bit Hash of the Services Name
-    Name: TServiceName; //Name of this Service
-
-    Owner: Integer; //If < 0 [-(DLLMan Pluginindex + 1)]; 0 - undefined, On Error Full shutdown, If < 0 [ModuleIndex - 1]  
-    
-    Next: PServiceInfo; //Pointer to the Next Service in teh list
-
-    //Here is s/t tricky
-    //To avoid writing of Wrapping Functions to offer a Service from a Class
-    //We save a Normal Proc or a Method of a Class
-    Case isClass: boolean of
-      False: (Proc: TUS_Service); //Proc that will be called on Event
-      True:  (ProcOfClass: TUS_Service_of_Object);
-  end;
-
-  TServiceManager = class
-    private
-      //Managing Service List
-      FirstService: PServiceInfo;
-      LastService: PServiceInfo;
-
-      //Some Speed improvement by caching the last 4 called Services
-      //Most of the time a Service is called multiple times
-      ServiceCache: Array[0..3] of PServiceInfo;
-      NextCacheItem: Byte;
-
-      //Next Service added gets this Handle:
-      NextHandle: THandle;
-    public
-      Constructor Create;
-
-      Function AddService(const ServiceName: PChar; const Proc: TUS_Service = nil; const ProcofClass: TUS_Service_of_Object = nil): THandle;
-      Function DelService(const hService: THandle): integer;
-
-      Function CallService(const ServiceName: PChar; const wParam: TwParam; lParam: TlParam): integer;
-
-      Function NametoHash(const ServiceName: TServiceName): Integer;
-      Function ServiceExists(const ServiceName: PChar): Integer;
-  end;
-
-var
-  ServiceManager: TServiceManager; 
-
-implementation
-uses
-  ULog,
-  UCore;
-
-//------------
-// Create - Creates Class and Set Standard Values
-//------------
-Constructor TServiceManager.Create;
-begin
-  FirstService := nil;
-  LastService := nil;
-
-  ServiceCache[0] := nil;
-  ServiceCache[1] := nil;
-  ServiceCache[2] := nil;
-  ServiceCache[3] := nil;
-
-  NextCacheItem := 0;
-
-  NextHandle := 1;
-
-  {$IFDEF DEBUG}
-    debugWriteln('ServiceManager: Succesful created!');
-  {$ENDIF}
-end;
-
-//------------
-// Function Creates a new Service and Returns the Services Handle,
-// 0 on Failure. (Name already exists)
-//------------
-Function TServiceManager.AddService(const ServiceName: PChar;  const Proc: TUS_Service; const ProcofClass: TUS_Service_of_Object): THandle;
-var
-  Cur: PServiceInfo;
-begin
-  Result := 0;
-
-  If (@Proc <> nil) or (@ProcOfClass <> nil) then
-  begin
-    If (ServiceExists(ServiceName) = 0) then
-    begin //There is a Proc and the Service does not already exist
-      //Ok Add it!
-      
-      //Get Memory
-      GetMem(Cur, SizeOf(TServiceInfo));
-
-      //Fill it with Data
-      Cur.Next := nil;
-
-      If (@Proc = nil) then
-      begin //Use the ProcofClass Method
-        Cur.isClass := True;
-        Cur.ProcOfClass := ProcofClass;
-      end
-      else //Use the normal Proc
-      begin
-        Cur.isClass := False;
-        Cur.Proc := Proc;
-      end;
-
-      Cur.Self := NextHandle;
-      //Zero Name
-      Cur.Name := #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0;
-      Cur.Name := String(ServiceName);
-      Cur.Hash := NametoHash(Cur.Name);
-
-      //Add Owner to Service
-      Cur.Owner := Core.CurExecuted;
-
-      //Add Service to the List
-      If (FirstService = nil) then
-        FirstService := Cur;
-
-      If (LastService <> nil) then
-        LastService.Next := Cur;
-
-      LastService := Cur;
-
-      {$IFDEF DEBUG}
-      debugWriteln('ServiceManager: Service added: ''' + ServiceName + ''', Handle: ' + InttoStr(Cur.Self));
-      {$ENDIF}
-
-      //Inc Next Handle
-      Inc(NextHandle);
-    end
-    {$IFDEF DEBUG}
-    else debugWriteln('ServiceManager: Try to readd Service: ' + ServiceName);
-    {$ENDIF}
-  end;
-end;
-
-//------------
-// Function Destroys a Service, 0 on success, not 0 on Failure
-//------------
-Function TServiceManager.DelService(const hService: THandle): integer;
-var
-  Last, Cur: PServiceInfo;
-  I: Integer;
-begin
-  Result := -1;
-
-  Last := nil;
-  Cur := FirstService;
-
-  //Search for Service to Delete
-  While (Cur <> nil) do
-  begin
-    If (Cur.Self = hService) then
-    begin //Found Service => Delete it
-
-      //Delete from List
-      If (Last = nil) then //Found first Service
-        FirstService := Cur.Next
-      Else //Service behind the first
-        Last.Next := Cur.Next;
-
-      //IF this is the LastService, correct LastService
-      If (Cur = LastService) then
-        LastService := Last;
-
-      //Search for Service in Cache and delete it if found
-      For I := 0 to High(ServiceCache) do
-        If (ServiceCache[I] = Cur) then
-        begin
-          ServiceCache[I] := nil;
-        end;
-
-      {$IFDEF DEBUG}
-      debugWriteln('ServiceManager: Removed Service succesful: ' + Cur.Name);
-      {$ENDIF}
-
-      //Free Memory
-      Freemem(Cur, SizeOf(TServiceInfo));
-
-      //Break the Loop
-      Break;
-    end;
-
-    //Go to Next Service
-    Last := Cur;
-    Cur := Cur.Next;
-  end;
-end;
-
-//------------
-// Function Calls a Services Proc
-// Returns Services Return Value or SERVICE_NOT_FOUND on Failure
-//------------
-Function TServiceManager.CallService(const ServiceName: PChar; const wParam: TwParam; lParam: TlParam): integer;
-var
-  SExists: Integer;
-  Service: PServiceInfo;
-  CurExecutedBackup: Integer; //backup of Core.CurExecuted Attribute
-begin
-  Result := SERVICE_NOT_FOUND;
-  SExists := ServiceExists(ServiceName);
-  If (SExists <> 0) then
-  begin
-    //Backup CurExecuted
-    CurExecutedBackup := Core.CurExecuted;
-    
-    Service := Pointer(SExists);
-
-    If (Service.isClass) then
-      //Use Proc of Class
-      // FIXME: "function ... of object" does not fit into an integer (2x pointers: object + function-code -> 8byte on x86) 
-      Result := Service.ProcOfClass(wParam, lParam)
-    Else
-      //Use normal Proc
-      // FIXME: will not work with x64 CPUs, pointers will be 64bit there  
-      Result := Service.Proc(wParam, lParam);
-
-    //Restore CurExecuted
-    Core.CurExecuted := CurExecutedBackup;
-  end;
-
-  {$IFDEF DEBUG}
-  debugWriteln('ServiceManager: Service ''' + ServiceName + ''' called. Result: ' + InttoStr(Result));
-  {$ENDIF}
-end;
-
-//------------
-// Generates the Hash for the given Name
-//------------
-Function TServiceManager.NametoHash(const ServiceName: TServiceName): Integer;
-asm
-  { CL: Counter; EAX: Result; EDX: Current Memory Address }
-  Mov ECX, 14 {Init Counter, Fold 14 Times to get 4 Bytes out of 60}
-
-  Mov EDX, ServiceName {Save Address of String that should be "Hashed"}
-
-  Mov EAX, [EDX]
-
-  @FoldLoop: ADD EDX, 4 {jump 4 Byte(32 Bit) to the next tile }
-             ADD EAX, [EDX] {Add the Value of the next 4 Byte of the String to the Hash}
-
-  LOOP @FoldLoop {Fold again if there are Chars Left}
-end;
-
-
-//------------
-// Function Returns Non Zero if a Service with the given Name Exists, otherwise 0
-//------------
-Function TServiceManager.ServiceExists(const ServiceName: PChar): Integer;
-var
-  Name: TServiceName;
-  Hash: Integer;
-  Cur: PServiceInfo;
-  I: Byte;
-begin
-  Result := 0;
-  // to-do : Write a Metbod (in ASM) to Zero and Add in one turn  (faster then this dirty hack ;)
-  //Zero Name:
-  Name := #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0;
-  //Add Service Name
-  Name := String(ServiceName);
-  Hash := NametoHash(Name);
-
-  //First of all Look for the Service in Cache
-  For I := 0 to High(ServiceCache) do
-  begin
-    If (ServiceCache[I] <> nil) AND (ServiceCache[I].Hash = Hash) then
-    begin
-      If (ServiceCache[I].Name = Name) then
-      begin //Found Service in Cache
-        Result := Integer(ServiceCache[I]);
-
-        {$IFDEF DEBUG}
-        debugWriteln('ServiceManager: Found Service in Cache: ''' + ServiceName + '''');
-        {$ENDIF}
-
-        Break;
-      end;
-    end;
-  end;
-
-  If (Result = 0) then
-  begin
-    Cur := FirstService;
-    While (Cur <> nil) do
-    begin
-      If (Cur.Hash = Hash) then
-      begin
-        If (Cur.Name = Name) then
-        begin //Found the Service
-          Result := Integer(Cur);
-
-          {$IFDEF DEBUG}
-          debugWriteln('ServiceManager: Found Service in List: ''' + ServiceName + '''');
-          {$ENDIF}
-
-          //Add to Cache
-          ServiceCache[NextCacheItem] := Cur;
-          NextCacheItem := (NextCacheItem + 1) AND 3;
-          Break;
-        end;
-      end;
-
-      Cur := Cur.Next;
-    end;
-  end;
-end;
-
-end.
+unit UServices;

+

+interface

+

+{$IFDEF FPC}

+  {$MODE Delphi}

+{$ENDIF}

+

+{$I switches.inc}

+

+{$IFDEF FPC}

+  {$ASMMODE Intel}

+{$ENDIF}

+

+uses uPluginDefs,

+     SysUtils;

+{*********************

+  TServiceManager

+  Class for saving, managing and calling of Services.

+  Saves all Services and their Procs

+*********************}

+

+type

+  TServiceName = String[60];

+  PServiceInfo = ^TServiceInfo;

+  TServiceInfo = record

+    Self: THandle; //Handle of this Service

+    Hash: Integer; //4 Bit Hash of the Services Name

+    Name: TServiceName; //Name of this Service

+

+    Owner: Integer; //If < 0 [-(DLLMan Pluginindex + 1)]; 0 - undefined, On Error Full shutdown, If < 0 [ModuleIndex - 1]  

+    

+    Next: PServiceInfo; //Pointer to the Next Service in teh list

+

+    //Here is s/t tricky

+    //To avoid writing of Wrapping Functions to offer a Service from a Class

+    //We save a Normal Proc or a Method of a Class

+    Case isClass: boolean of

+      False: (Proc: TUS_Service); //Proc that will be called on Event

+      True:  (ProcOfClass: TUS_Service_of_Object);

+  end;

+

+  TServiceManager = class

+    private

+      //Managing Service List

+      FirstService: PServiceInfo;

+      LastService: PServiceInfo;

+

+      //Some Speed improvement by caching the last 4 called Services

+      //Most of the time a Service is called multiple times

+      ServiceCache: Array[0..3] of PServiceInfo;

+      NextCacheItem: Byte;

+

+      //Next Service added gets this Handle:

+      NextHandle: THandle;

+    public

+      Constructor Create;

+

+      Function AddService(const ServiceName: PChar; const Proc: TUS_Service = nil; const ProcofClass: TUS_Service_of_Object = nil): THandle;

+      Function DelService(const hService: THandle): integer;

+

+      Function CallService(const ServiceName: PChar; const wParam: TwParam; lParam: TlParam): integer;

+

+      Function NametoHash(const ServiceName: TServiceName): Integer;

+      Function ServiceExists(const ServiceName: PChar): Integer;

+  end;

+

+var

+  ServiceManager: TServiceManager; 

+

+implementation

+uses

+  ULog,

+  UCore;

+

+//------------

+// Create - Creates Class and Set Standard Values

+//------------

+Constructor TServiceManager.Create;

+begin

+  FirstService := nil;

+  LastService := nil;

+

+  ServiceCache[0] := nil;

+  ServiceCache[1] := nil;

+  ServiceCache[2] := nil;

+  ServiceCache[3] := nil;

+

+  NextCacheItem := 0;

+

+  NextHandle := 1;

+

+  {$IFDEF DEBUG}

+    debugWriteln('ServiceManager: Succesful created!');

+  {$ENDIF}

+end;

+

+//------------

+// Function Creates a new Service and Returns the Services Handle,

+// 0 on Failure. (Name already exists)

+//------------

+Function TServiceManager.AddService(const ServiceName: PChar;  const Proc: TUS_Service; const ProcofClass: TUS_Service_of_Object): THandle;

+var

+  Cur: PServiceInfo;

+begin

+  Result := 0;

+

+  If (@Proc <> nil) or (@ProcOfClass <> nil) then

+  begin

+    If (ServiceExists(ServiceName) = 0) then

+    begin //There is a Proc and the Service does not already exist

+      //Ok Add it!

+      

+      //Get Memory

+      GetMem(Cur, SizeOf(TServiceInfo));

+

+      //Fill it with Data

+      Cur.Next := nil;

+

+      If (@Proc = nil) then

+      begin //Use the ProcofClass Method

+        Cur.isClass := True;

+        Cur.ProcOfClass := ProcofClass;

+      end

+      else //Use the normal Proc

+      begin

+        Cur.isClass := False;

+        Cur.Proc := Proc;

+      end;

+

+      Cur.Self := NextHandle;

+      //Zero Name

+      Cur.Name := #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0;

+      Cur.Name := String(ServiceName);

+      Cur.Hash := NametoHash(Cur.Name);

+

+      //Add Owner to Service

+      Cur.Owner := Core.CurExecuted;

+

+      //Add Service to the List

+      If (FirstService = nil) then

+        FirstService := Cur;

+

+      If (LastService <> nil) then

+        LastService.Next := Cur;

+

+      LastService := Cur;

+

+      {$IFDEF DEBUG}

+      debugWriteln('ServiceManager: Service added: ''' + ServiceName + ''', Handle: ' + InttoStr(Cur.Self));

+      {$ENDIF}

+

+      //Inc Next Handle

+      Inc(NextHandle);

+    end

+    {$IFDEF DEBUG}

+    else debugWriteln('ServiceManager: Try to readd Service: ' + ServiceName);

+    {$ENDIF}

+  end;

+end;

+

+//------------

+// Function Destroys a Service, 0 on success, not 0 on Failure

+//------------

+Function TServiceManager.DelService(const hService: THandle): integer;

+var

+  Last, Cur: PServiceInfo;

+  I: Integer;

+begin

+  Result := -1;

+

+  Last := nil;

+  Cur := FirstService;

+

+  //Search for Service to Delete

+  While (Cur <> nil) do

+  begin

+    If (Cur.Self = hService) then

+    begin //Found Service => Delete it

+

+      //Delete from List

+      If (Last = nil) then //Found first Service

+        FirstService := Cur.Next

+      Else //Service behind the first

+        Last.Next := Cur.Next;

+

+      //IF this is the LastService, correct LastService

+      If (Cur = LastService) then

+        LastService := Last;

+

+      //Search for Service in Cache and delete it if found

+      For I := 0 to High(ServiceCache) do

+        If (ServiceCache[I] = Cur) then

+        begin

+          ServiceCache[I] := nil;

+        end;

+

+      {$IFDEF DEBUG}

+      debugWriteln('ServiceManager: Removed Service succesful: ' + Cur.Name);

+      {$ENDIF}

+

+      //Free Memory

+      Freemem(Cur, SizeOf(TServiceInfo));

+

+      //Break the Loop

+      Break;

+    end;

+

+    //Go to Next Service

+    Last := Cur;

+    Cur := Cur.Next;

+  end;

+end;

+

+//------------

+// Function Calls a Services Proc

+// Returns Services Return Value or SERVICE_NOT_FOUND on Failure

+//------------

+Function TServiceManager.CallService(const ServiceName: PChar; const wParam: TwParam; lParam: TlParam): integer;

+var

+  SExists: Integer;

+  Service: PServiceInfo;

+  CurExecutedBackup: Integer; //backup of Core.CurExecuted Attribute

+begin

+  Result := SERVICE_NOT_FOUND;

+  SExists := ServiceExists(ServiceName);

+  If (SExists <> 0) then

+  begin

+    //Backup CurExecuted

+    CurExecutedBackup := Core.CurExecuted;

+    

+    Service := Pointer(SExists);

+

+    If (Service.isClass) then

+      //Use Proc of Class

+      // FIXME: "function ... of object" does not fit into an integer (2x pointers: object + function-code -> 8byte on x86) 

+      Result := Service.ProcOfClass(wParam, lParam)

+    Else

+      //Use normal Proc

+      // FIXME: will not work with x64 CPUs, pointers will be 64bit there  

+      Result := Service.Proc(wParam, lParam);

+

+    //Restore CurExecuted

+    Core.CurExecuted := CurExecutedBackup;

+  end;

+

+  {$IFDEF DEBUG}

+  debugWriteln('ServiceManager: Service ''' + ServiceName + ''' called. Result: ' + InttoStr(Result));

+  {$ENDIF}

+end;

+

+//------------

+// Generates the Hash for the given Name

+//------------

+Function TServiceManager.NametoHash(const ServiceName: TServiceName): Integer;

+// FIXME: check if the non-asm version is fast enough and use it by default if so

+{$IF Defined(CPUX86_64)}

+asm

+  { CL: Counter; RAX: Result; RDX: Current Memory Address }

+  Mov RCX, 14

+  Mov RDX, ServiceName {Save Address of String that should be "Hashed"}

+  Mov RAX, [RDX]

+  @FoldLoop: ADD RDX, 4 {jump 4 Byte(32 Bit) to the next tile }

+             ADD RAX, [RDX] {Add the Value of the next 4 Byte of the String to the Hash}

+  LOOP @FoldLoop {Fold again if there are Chars Left}

+end;

+{$ELSEIF Defined(CPU386) or Defined(CPUI386)}

+asm

+  { CL: Counter; EAX: Result; EDX: Current Memory Address }

+  Mov ECX, 14 {Init Counter, Fold 14 Times to get 4 Bytes out of 60}

+  Mov EDX, ServiceName {Save Address of String that should be "Hashed"}

+  Mov EAX, [EDX]

+  @FoldLoop: ADD EDX, 4 {jump 4 Byte(32 Bit) to the next tile }

+             ADD EAX, [EDX] {Add the Value of the next 4 Byte of the String to the Hash}

+  LOOP @FoldLoop {Fold again if there are Chars Left}

+end;

+{$ELSE}

+var

+  i: integer;

+  ptr: ^integer;

+begin

+  ptr := @ServiceName;

+  Result := 0;

+  for i := 1 to 14 do

+  begin

+    Result := Result + ptr^;

+    Inc(ptr);

+  end;

+end;

+{$IFEND}

+

+

+//------------

+// Function Returns Non Zero if a Service with the given Name Exists, otherwise 0

+//------------

+Function TServiceManager.ServiceExists(const ServiceName: PChar): Integer;

+var

+  Name: TServiceName;

+  Hash: Integer;

+  Cur: PServiceInfo;

+  I: Byte;

+begin

+  Result := 0;

+  // to-do : Write a Metbod (in ASM) to Zero and Add in one turn  (faster then this dirty hack ;)

+  //Zero Name:

+  Name := #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0;

+  //Add Service Name

+  Name := String(ServiceName);

+  Hash := NametoHash(Name);

+

+  //First of all Look for the Service in Cache

+  For I := 0 to High(ServiceCache) do

+  begin

+    If (ServiceCache[I] <> nil) AND (ServiceCache[I].Hash = Hash) then

+    begin

+      If (ServiceCache[I].Name = Name) then

+      begin //Found Service in Cache

+        Result := Integer(ServiceCache[I]);

+

+        {$IFDEF DEBUG}

+        debugWriteln('ServiceManager: Found Service in Cache: ''' + ServiceName + '''');

+        {$ENDIF}

+

+        Break;

+      end;

+    end;

+  end;

+

+  If (Result = 0) then

+  begin

+    Cur := FirstService;

+    While (Cur <> nil) do

+    begin

+      If (Cur.Hash = Hash) then

+      begin

+        If (Cur.Name = Name) then

+        begin //Found the Service

+          Result := Integer(Cur);

+

+          {$IFDEF DEBUG}

+          debugWriteln('ServiceManager: Found Service in List: ''' + ServiceName + '''');

+          {$ENDIF}

+

+          //Add to Cache

+          ServiceCache[NextCacheItem] := Cur;

+          NextCacheItem := (NextCacheItem + 1) AND 3;

+          Break;

+        end;

+      end;

+

+      Cur := Cur.Next;

+    end;

+  end;

+end;

+

+end.