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     function MatchHeader(Data: Pointer; Len: LongWord): Boolean; override;
  41     function MatchExtension(FName: string): Boolean; override;
  42     function GetLoader(): TSoundLoader; override;
  43   end;
  44
  45 implementation
  46
  47 uses sysutils, utils, e_sound, e_log;
  48
  49 (* TXMPLoaderFactory *)
  50
  51 function TXMPLoaderFactory.MatchHeader(Data: Pointer; Len: LongWord): Boolean;
  52 var
  53   Ctx: xmp_context;
  54   Err: LongInt;
  55 begin
  56   // HACK: these fine gentlemen didn't provide us with a xmp_test_module_from_memory()
  57   //       so just load the module and unload it
  58
  59   Result := False;
  60
  61   Ctx := xmp_create_context();
  62   Err := xmp_load_module_from_memory(Ctx, Data, Len);
  63
  64   if Err = 0 then
  65   begin
  66     xmp_release_module(Ctx);
  67     Result := True;
  68   end;
  69
  70   xmp_free_context(Ctx);
  71 end;
  72
  73 function TXMPLoaderFactory.MatchExtension(FName: string): Boolean;
  74 var
  75   Ext: string;
  76 begin
  77   Ext := GetFilenameExt(FName);
  78   Result := (Ext = '.it') or (Ext = '.xm') or (Ext = '.mod') or (Ext = '.s3m');
  79 end;
  80
  81 function TXMPLoaderFactory.GetLoader(): TSoundLoader;
  82 begin
  83   Result := TXMPLoader.Create();
  84 end;
  85
  86 (* TXMPLoader *)
  87
  88 function TXMPLoader.Load(Data: Pointer; Len: LongWord; SStreaming: Boolean): Boolean;
  89 var
  90   Err: LongInt;
  91 begin
  92   Result := False;
  93
  94   FLoaded := False;
  95   FXMP := xmp_create_context();
  96   if FXMP = nil then Exit;
  97
  98   try
  99     Err := xmp_load_module_from_memory(FXMP, Data, Len);
 100     if Err <> 0 then
 101       raise Exception.Create('xmp_load_module_from_memory failed');
 102
 103     if xmp_start_player(FXMP, 48000, 0) <> 0 then
 104       raise Exception.Create('xmp_start_player failed');
 105
 106     FFormat.SampleRate := 48000;
 107     FFormat.SampleBits := 16;
 108     FFormat.Channels := 2;
 109
 110     FStreaming := True; // modules are always streaming
 111     FLoaded := True;
 112     Result := True;
 113   except
 114     on E: Exception do
 115     begin
 116       e_LogWriteln('TXMPLoader.Load() error: ' + E.Message);
 117       if Err = 0 then xmp_release_module(FXMP);
 118       xmp_free_context(FXMP);
 119       FXMP := nil;
 120     end;
 121   end;
 122 end;
 123
 124 function TXMPLoader.Load(FName: string; SStreaming: Boolean): Boolean;
 125 var
 126   Err: LongInt;
 127 begin
 128   Result := False;
 129
 130   FLoaded := False;
 131   FXMP := xmp_create_context();
 132   if FXMP = nil then Exit;
 133
 134   try
 135     Err := xmp_load_module(FXMP, PChar(FName));
 136     if Err <> 0 then
 137       raise Exception.Create('xmp_load_module failed');
 138
 139     if xmp_start_player(FXMP, 48000, 0) <> 0 then
 140       raise Exception.Create('xmp_start_player failed');
 141
 142     FFormat.SampleRate := 48000;
 143     FFormat.SampleBits := 16;
 144     FFormat.Channels := 2;
 145
 146     FStreaming := True; // modules are always streaming
 147     FLoaded := True;
 148     Result := True;
 149   except
 150     on E: Exception do
 151     begin
 152       e_LogWritefln('TXMPLoader.Load(%s) error: %s', [FName, E.Message]);
 153       if Err = 0 then xmp_release_module(FXMP);
 154       xmp_free_context(FXMP);
 155       FXMP := nil;
 156     end;
 157   end;
 158 end;
 159
 160 function TXMPLoader.SetPosition(Pos: LongWord): Boolean;
 161 begin
 162   Result := False;
 163   if FXMP = nil then Exit;
 164   Result := xmp_set_position(FXMP, Pos) = 0;
 165 end;
 166
 167 function TXMPLoader.FillBuffer(Buf: Pointer; Len: LongWord): LongWord;
 168 var
 169   LoopN: LongInt;
 170 begin
 171   Result := 0;
 172   if FXMP = nil then Exit;
 173   if FLooping then
 174     LoopN := 0
 175   else
 176     LoopN := 1;
 177   if xmp_play_buffer(FXMP, Buf, Len, LoopN) = 0 then
 178     Result := Len;
 179 end;
 180
 181 function TXMPLoader.GetAll(var OutPtr: Pointer): LongWord;
 182 begin
 183   Result := 0; // modules are always streaming, so this don't make sense
 184 end;
 185
 186 procedure TXMPLoader.Free();
 187 begin
 188   if FXMP <> nil then
 189   begin
 190     if FLoaded then
 191     begin
 192       xmp_end_player(FXMP);
 193       xmp_release_module(FXMP);
 194     end;
 195     xmp_free_context(FXMP);
 196     FXMP := nil;
 197   end;
 198   FLoaded := False;
 199 end;
 200
 201 initialization
 202   e_AddSoundLoader(TXMPLoaderFactory.Create());
 203 end.