src/engine/e_soundfile_xmp.pas

   1 (* Copyright (C)  Doom 2D: Forever Developers
   2  *
   3  * This program is free software: you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation, either version 3 of the License, or
   6  * (at your option) any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15  *)
  16 {$INCLUDE ../shared/a_modes.inc}
  17 unit e_soundfile_xmp;
  18
  19 interface
  20
  21 uses e_soundfile, XMP;
  22
  23 type
  24   // a module loader that uses libxmp-lite
  25
  26   TXMPLoader = class (TSoundLoader)
  27   public
  28     function Load(Data: Pointer; Len: LongWord; SStreaming: Boolean): Boolean; override; overload;
  29     function Load(FName: string; SStreaming: Boolean): Boolean; override; overload;
  30     function SetPosition(Pos: LongWord): Boolean; override;
  31     function FillBuffer(Buf: Pointer; Len: LongWord): LongWord; override;
  32     function GetAll(var OutPtr: Pointer): LongWord; override;
  33     procedure Free(); override;
  34   private
  35     FXMP: xmp_context;
  36     FLoaded: Boolean;
  37   end;
  38
  39   TXMPLoaderFactory = class (TSoundLoaderFactory)
  40   public
  41     function MatchHeader(Data: Pointer; Len: LongWord): Boolean; override;
  42     function MatchExtension(FName: string): Boolean; override;
  43     function GetLoader(): TSoundLoader; override;
  44   end;
  45
  46 implementation
  47
  48 uses sysutils, utils, e_sound, e_log;
  49
  50 (* TXMPLoaderFactory *)
  51
  52 function TXMPLoaderFactory.MatchHeader(Data: Pointer; Len: LongWord): Boolean;
  53 var
  54   Ctx: xmp_context;
  55   Err: LongInt;
  56 begin
  57   // HACK: these fine gentlemen didn't provide us with a xmp_test_module_from_memory()
  58   //       so just load the module and unload it
  59
  60   Result := False;
  61
  62   Ctx := xmp_create_context();
  63   Err := xmp_load_module_from_memory(Ctx, Data, Len);
  64
  65   if Err = 0 then
  66   begin
  67     xmp_release_module(Ctx);
  68     Result := True;
  69   end;
  70
  71   xmp_free_context(Ctx);
  72 end;
  73
  74 function TXMPLoaderFactory.MatchExtension(FName: string): Boolean;
  75 var
  76   Ext: string;
  77 begin
  78   Ext := GetFilenameExt(FName);
  79   Result := (Ext = '.it') or (Ext = '.xm') or (Ext = '.mod') or (Ext = '.s3m');
  80 end;
  81
  82 function TXMPLoaderFactory.GetLoader(): TSoundLoader;
  83 begin
  84   Result := TXMPLoader.Create();
  85 end;
  86
  87 (* TXMPLoader *)
  88
  89 function TXMPLoader.Load(Data: Pointer; Len: LongWord; SStreaming: Boolean): Boolean;
  90 var
  91   Err: LongInt;
  92 begin
  93   Result := False;
  94
  95   FLoaded := False;
  96   FXMP := xmp_create_context();
  97   if FXMP = nil then Exit;
  98
  99   try
 100     Err := xmp_load_module_from_memory(FXMP, Data, Len);
 101     if Err <> 0 then
 102       raise Exception.Create('xmp_load_module_from_memory failed');
 103
 104     if xmp_start_player(FXMP, 48000, 0) <> 0 then
 105       raise Exception.Create('xmp_start_player failed');
 106
 107     FFormat.SampleRate := 48000;
 108     FFormat.SampleBits := 16;
 109     FFormat.Channels := 2;
 110
 111     FStreaming := True; // modules are always streaming
 112     FLoaded := True;
 113     Result := True;
 114   except
 115     on E: Exception do
 116     begin
 117       e_LogWriteln('TXMPLoader.Load() error: ' + E.Message);
 118       if Err = 0 then xmp_release_module(FXMP);
 119       xmp_free_context(FXMP);
 120       FXMP := nil;
 121     end;
 122   end;
 123 end;
 124
 125 function TXMPLoader.Load(FName: string; SStreaming: Boolean): Boolean;
 126 var
 127   Err: LongInt;
 128 begin
 129   Result := False;
 130
 131   FLoaded := False;
 132   FXMP := xmp_create_context();
 133   if FXMP = nil then Exit;
 134
 135   try
 136     Err := xmp_load_module(FXMP, PChar(FName));
 137     if Err <> 0 then
 138       raise Exception.Create('xmp_load_module failed');
 139
 140     if xmp_start_player(FXMP, 48000, 0) <> 0 then
 141       raise Exception.Create('xmp_start_player failed');
 142
 143     FFormat.SampleRate := 48000;
 144     FFormat.SampleBits := 16;
 145     FFormat.Channels := 2;
 146
 147     FStreaming := True; // modules are always streaming
 148     FLoaded := True;
 149     Result := True;
 150   except
 151     on E: Exception do
 152     begin
 153       e_LogWritefln('TXMPLoader.Load(%s) error: %s', [FName, E.Message]);
 154       if Err = 0 then xmp_release_module(FXMP);
 155       xmp_free_context(FXMP);
 156       FXMP := nil;
 157     end;
 158   end;
 159 end;
 160
 161 function TXMPLoader.SetPosition(Pos: LongWord): Boolean;
 162 begin
 163   Result := False;
 164   if FXMP = nil then Exit;
 165   Result := xmp_set_position(FXMP, Pos) = 0;
 166 end;
 167
 168 function TXMPLoader.FillBuffer(Buf: Pointer; Len: LongWord): LongWord;
 169 var
 170   LoopN: LongInt;
 171 begin
 172   Result := 0;
 173   if FXMP = nil then Exit;
 174   if FLooping then
 175     LoopN := 0
 176   else
 177     LoopN := 1;
 178   if xmp_play_buffer(FXMP, Buf, Len, LoopN) = 0 then
 179     Result := Len;
 180 end;
 181
 182 function TXMPLoader.GetAll(var OutPtr: Pointer): LongWord;
 183 begin
 184   Result := 0; // modules are always streaming, so this don't make sense
 185 end;
 186
 187 procedure TXMPLoader.Free();
 188 begin
 189   if FXMP <> nil then
 190   begin
 191     if FLoaded then
 192     begin
 193       xmp_end_player(FXMP);
 194       xmp_release_module(FXMP);
 195     end;
 196     xmp_free_context(FXMP);
 197     FXMP := nil;
 198   end;
 199   FLoaded := False;
 200 end;
 201
 202 initialization
 203   e_AddSoundLoader(TXMPLoaderFactory.Create());
 204 end.