src/sfs/sfsMemFS.pas

   1 // Streaming R/O Virtual File System v0.2.0
   2 // Copyright (C) XL A.S. Ketmar.  All rights reserved
   3 // See the file aplicense.txt for conditions of use.
   4 //
   5 // "memory group". reads the whole pack in memory (and decompress it if
   6 // necessary). memory image has only one file named "<body>".
   7 //
   8 // now understands:
   9 //   slh!: DOS Allegro "slh!"
  10 //   mem : raw file (no processing, just read)
  11 //     as a side effect this gives us an opportunity to read enclosed packs
  12 //     from the packs which aren't supporting backseeking (such as zips).
  13 //
  14 {$MODE DELPHI}
  15 {.$R-}
  16 unit sfsMemFS;
  17
  18 interface
  19
  20 uses
  21   SysUtils, Classes, Contnrs, sfs;
  22
  23
  24 type
  25   TSFSMemVolumeType = (sfsmvNone, sfsmvRAW, sfsmvSLH);
  26
  27   TSFSMemoryVolume = class(TSFSVolume)
  28   protected
  29     fType: TSFSMemVolumeType;
  30     fMemStream: TMemoryStream;
  31
  32     procedure RAWRead ();
  33     procedure SLHRead ();
  34
  35     procedure ReadDirectory (); override;
  36
  37   public
  38     function OpenFileByIndex (const index: Integer): TStream; override;
  39   end;
  40
  41   TSFSMemoryVolumeFactory = class (TSFSVolumeFactory)
  42   public
  43     function IsMyVolumePrefix (const prefix: TSFSString): Boolean; override;
  44     function Produce (const prefix, fileName: TSFSString; st: TStream): TSFSVolume; override;
  45     procedure Recycle (vol: TSFSVolume); override;
  46   end;
  47
  48
  49
  50 implementation
  51
  52 uses
  53   xstreams;
  54
  55
  56 function SLHCheckMagic (st: TStream): Boolean;
  57 var
  58   sign: packed array [0..3] of Char;
  59 begin
  60   result := false;
  61   st.ReadBuffer(sign[0], 4);
  62   st.Seek(-4, soCurrent);
  63   if sign <> 'slh!' then exit;
  64   result := true;
  65 end;
  66
  67
  68 { TSFSMemoryVolume }
  69 procedure TSFSMemoryVolume.RAWRead ();
  70 var
  71   fi: TSFSFileInfo;
  72 begin
  73   fMemStream.CopyFrom(fFileStream, 0); // voila %-)
  74   fi := TSFSFileInfo.Create(self);
  75   fi.fName := '<body>';
  76   fi.fSize := fMemStream.Size;
  77 end;
  78
  79 procedure TSFSMemoryVolume.SLHRead ();
  80 // unpack LZSS-packed file
  81 var
  82   fi: TSFSFileInfo;
  83   bufi, bufo: packed array of Byte;
  84   iused, oused, rpos: Integer;
  85   dict: packed array of Byte;
  86   flags, dpos, pos, len: Word;
  87   c: Integer;
  88
  89   function ReadCh (): Integer;
  90   begin
  91     if rpos >= iused then
  92     begin
  93       // int64!
  94       if fFileStream.Size-fFileStream.Position > Length(bufi) then iused := Length(bufi)
  95       else iused := fFileStream.Size-fFileStream.Position;
  96       rpos := 0;
  97       if iused > 0 then fFileStream.ReadBuffer(bufi[0], iused);
  98     end;
  99
 100     if iused = 0 then result := -1
 101     else begin result := bufi[rpos]; Inc(rpos); end;
 102   end;
 103
 104   procedure WriteCh (c: Byte);
 105   begin
 106     if oused >= Length(bufo) then
 107     begin
 108       fMemStream.WriteBuffer(bufo[0], oused);
 109       oused := 0;
 110     end;
 111     bufo[oused] := c; Inc(oused);
 112     dict[dpos] := c; dpos := (dpos+1) and $FFF;
 113   end;
 114
 115 begin
 116   fFileStream.Seek(4, soCurrent); // skip signature
 117   SetLength(bufi, 65536); SetLength(bufo, 65536); SetLength(dict, 4096);
 118   rpos := 0; iused := 0; oused := 0;
 119   flags := 0; dpos := 4096-18;
 120   repeat
 121     if (flags and $FF00) = 0 then
 122     begin
 123       c := ReadCh(); if c = -1 then break;
 124       flags := c or $FF00;
 125     end;
 126
 127     if (flags and $01) <> 0 then
 128     begin
 129       // literal
 130       c := ReadCh(); if c = -1 then break;
 131       WriteCh(c);
 132     end
 133     else
 134     begin
 135       // "copy"
 136       c := ReadCh(); if c = -1 then break;
 137       pos := c;
 138       c := ReadCh(); if c = -1 then break;
 139       len := c;
 140       pos := (pos and $FF) or ((len and $F0) shl 4); len := (len and $0F)+3;
 141       while len > 0 do
 142       begin
 143         c := dict[pos]; pos := (pos+1) and $FFF; Dec(len);
 144         WriteCh(c);
 145       end;
 146     end;
 147     flags := flags shr 1;
 148   until false;
 149   if oused > 0 then fMemStream.WriteBuffer(bufo[0], oused);
 150
 151   fi := TSFSFileInfo.Create(self);
 152   fi.fName := '<body>';
 153   fi.fSize := fMemStream.Size;
 154 end;
 155
 156 procedure TSFSMemoryVolume.ReadDirectory ();
 157 begin
 158   if fMemStream = nil then fMemStream := TMemoryStream.Create()
 159   else
 160   begin
 161     fMemStream.Position := 0; fMemStream.Size := 0;
 162   end;
 163
 164   case fType of
 165     sfsmvSLH: SLHRead();
 166     sfsmvRAW: RAWRead();
 167     else raise ESFSError.Create('invalid memory SFS');
 168   end;
 169
 170   fMemStream.Position := 0;
 171 end;
 172
 173 function TSFSMemoryVolume.OpenFileByIndex (const index: Integer): TStream;
 174 var
 175   fs: TStream;
 176 begin
 177   result := nil; fs := nil;
 178   if fFiles = nil then exit;
 179   if (index < 0) or (index >= fFiles.Count) or (fFiles[index] = nil) then exit;
 180
 181   try
 182     fs := TSFSMemoryStreamRO.Create(fMemStream.Memory, fMemStream.Size);
 183     if fFiles.Count = 1 then
 184     begin
 185       result := fs;
 186     end
 187     else
 188     begin
 189       try
 190         result := TSFSPartialStream.Create(fs,
 191           TSFSFileInfo(fFiles[index]).fOfs,
 192           TSFSFileInfo(fFiles[index]).fSize, true);
 193       except
 194         FreeAndNil(fs);
 195         raise;
 196       end;
 197     end;
 198   except
 199     result := nil;
 200   end;
 201 end;
 202
 203
 204 { TSFSMemoryVolumeFactory }
 205 function TSFSMemoryVolumeFactory.IsMyVolumePrefix (const prefix: TSFSString): Boolean;
 206 begin
 207   result :=
 208     SFSStrEqu(prefix, 'mem') or
 209     SFSStrEqu(prefix, 'slh!');
 210 end;
 211
 212 procedure TSFSMemoryVolumeFactory.Recycle (vol: TSFSVolume);
 213 begin
 214   vol.Free();
 215 end;
 216
 217 function TSFSMemoryVolumeFactory.Produce (const prefix, fileName: TSFSString; st: TStream): TSFSVolume;
 218 var
 219   vt: TSFSMemVolumeType;
 220 begin
 221   if (prefix <> 'mem') and SLHCheckMagic(st) then vt := sfsmvSLH
 222   else if prefix <> '' then vt := sfsmvRAW
 223   else vt := sfsmvNone;
 224
 225   result := TSFSMemoryVolume.Create(fileName, st);
 226   TSFSMemoryVolume(result).fType := vt;
 227   try
 228     result.DoDirectoryRead();
 229   except
 230     FreeAndNil(result);
 231     raise;
 232   end;
 233 end;
 234
 235
 236 var
 237   memf: TSFSMemoryVolumeFactory;
 238 initialization
 239   memf := TSFSMemoryVolumeFactory.Create();
 240   SFSRegisterVolumeFactory(memf);
 241 finalization
 242   SFSUnregisterVolumeFactory(memf);
 243 end.