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     function OpenFileByIndex (const index: Integer): TStream; override;
  37   end;
  38
  39   TSFSMemoryVolumeFactory = class (TSFSVolumeFactory)
  40   public
  41     function IsMyVolumePrefix (const prefix: TSFSString): Boolean; override;
  42     function Produce (const prefix, fileName: TSFSString; st: TStream): TSFSVolume; override;
  43     procedure Recycle (vol: TSFSVolume); override;
  44   end;
  45
  46
  47
  48 implementation
  49
  50 uses
  51   xstreams;
  52
  53
  54 function SLHCheckMagic (st: TStream): Boolean;
  55 var
  56   sign: packed array [0..3] of Char;
  57 begin
  58   result := false;
  59   st.ReadBuffer(sign[0], 4);
  60   st.Seek(-4, soCurrent);
  61   if sign <> 'slh!' then exit;
  62   result := true;
  63 end;
  64
  65
  66 { TSFSMemoryVolume }
  67 procedure TSFSMemoryVolume.RAWRead ();
  68 var
  69   fi: TSFSFileInfo;
  70 begin
  71   fMemStream.CopyFrom(fFileStream, 0); // voila %-)
  72   fi := TSFSFileInfo.Create(self);
  73   fi.fName := '<body>';
  74   fi.fSize := fMemStream.Size;
  75 end;
  76
  77 procedure TSFSMemoryVolume.SLHRead ();
  78 // unpack LZSS-packed file
  79 var
  80   fi: TSFSFileInfo;
  81   bufi, bufo: packed array of Byte;
  82   iused, oused, rpos: Integer;
  83   dict: packed array of Byte;
  84   flags, dpos, pos, len: Word;
  85   c: Integer;
  86
  87   function ReadCh (): Integer;
  88   begin
  89     if rpos >= iused then
  90     begin
  91       // int64!
  92       if fFileStream.Size-fFileStream.Position > Length(bufi) then iused := Length(bufi)
  93       else iused := fFileStream.Size-fFileStream.Position;
  94       rpos := 0;
  95       if iused > 0 then fFileStream.ReadBuffer(bufi[0], iused);
  96     end;
  97
  98     if iused = 0 then result := -1
  99     else begin result := bufi[rpos]; Inc(rpos); end;
 100   end;
 101
 102   procedure WriteCh (c: Byte);
 103   begin
 104     if oused >= Length(bufo) then
 105     begin
 106       fMemStream.WriteBuffer(bufo[0], oused);
 107       oused := 0;
 108     end;
 109     bufo[oused] := c; Inc(oused);
 110     dict[dpos] := c; dpos := (dpos+1) and $FFF;
 111   end;
 112
 113 begin
 114   fFileStream.Seek(4, soCurrent); // skip signature
 115   SetLength(bufi, 65536); SetLength(bufo, 65536); SetLength(dict, 4096);
 116   rpos := 0; iused := 0; oused := 0;
 117   flags := 0; dpos := 4096-18;
 118   repeat
 119     if (flags and $FF00) = 0 then
 120     begin
 121       c := ReadCh(); if c = -1 then break;
 122       flags := c or $FF00;
 123     end;
 124
 125     if (flags and $01) <> 0 then
 126     begin
 127       // literal
 128       c := ReadCh(); if c = -1 then break;
 129       WriteCh(c);
 130     end
 131     else
 132     begin
 133       // "copy"
 134       c := ReadCh(); if c = -1 then break;
 135       pos := c;
 136       c := ReadCh(); if c = -1 then break;
 137       len := c;
 138       pos := (pos and $FF) or ((len and $F0) shl 4); len := (len and $0F)+3;
 139       while len > 0 do
 140       begin
 141         c := dict[pos]; pos := (pos+1) and $FFF; Dec(len);
 142         WriteCh(c);
 143       end;
 144     end;
 145     flags := flags shr 1;
 146   until false;
 147   if oused > 0 then fMemStream.WriteBuffer(bufo[0], oused);
 148
 149   fi := TSFSFileInfo.Create(self);
 150   fi.fName := '<body>';
 151   fi.fSize := fMemStream.Size;
 152 end;
 153
 154 procedure TSFSMemoryVolume.ReadDirectory ();
 155 begin
 156   if fMemStream = nil then fMemStream := TMemoryStream.Create()
 157   else
 158   begin
 159     fMemStream.Position := 0; fMemStream.Size := 0;
 160   end;
 161
 162   case fType of
 163     sfsmvSLH: SLHRead();
 164     sfsmvRAW: RAWRead();
 165     else raise ESFSError.Create('invalid memory SFS');
 166   end;
 167
 168   fMemStream.Position := 0;
 169 end;
 170
 171 function TSFSMemoryVolume.OpenFileByIndex (const index: Integer): TStream;
 172 var
 173   fs: TStream;
 174 begin
 175   result := nil; fs := nil;
 176   if fFiles = nil then exit;
 177   if (index < 0) or (index >= fFiles.Count) or (fFiles[index] = nil) then exit;
 178
 179   try
 180     fs := TSFSMemoryStreamRO.Create(fMemStream.Memory, fMemStream.Size);
 181     if fFiles.Count = 1 then
 182     begin
 183       result := fs;
 184     end
 185     else
 186     begin
 187       try
 188         result := TSFSPartialStream.Create(fs,
 189           TSFSFileInfo(fFiles[index]).fOfs,
 190           TSFSFileInfo(fFiles[index]).fSize, true);
 191       except
 192         FreeAndNil(fs);
 193         raise;
 194       end;
 195     end;
 196   except
 197     result := nil;
 198   end;
 199 end;
 200
 201
 202 { TSFSMemoryVolumeFactory }
 203 function TSFSMemoryVolumeFactory.IsMyVolumePrefix (const prefix: TSFSString): Boolean;
 204 begin
 205   result :=
 206     (SFSStrComp(prefix, 'mem') = 0) or
 207     (SFSStrComp(prefix, 'slh!') = 0);
 208 end;
 209
 210 procedure TSFSMemoryVolumeFactory.Recycle (vol: TSFSVolume);
 211 begin
 212   vol.Free();
 213 end;
 214
 215 function TSFSMemoryVolumeFactory.Produce (const prefix, fileName: TSFSString; st: TStream): TSFSVolume;
 216 var
 217   vt: TSFSMemVolumeType;
 218 begin
 219   if (prefix <> 'mem') and SLHCheckMagic(st) then vt := sfsmvSLH
 220   else if prefix <> '' then vt := sfsmvRAW
 221   else vt := sfsmvNone;
 222
 223   result := TSFSMemoryVolume.Create(fileName, st);
 224   TSFSMemoryVolume(result).fType := vt;
 225   try
 226     result.DoDirectoryRead();
 227   except
 228     FreeAndNil(result);
 229     raise;
 230   end;
 231 end;
 232
 233
 234 var
 235   memf: TSFSMemoryVolumeFactory;
 236 initialization
 237   memf := TSFSMemoryVolumeFactory.Create();
 238   SFSRegisterVolumeFactory(memf);
 239 finalization
 240   SFSUnregisterVolumeFactory(memf);
 241 end.