RandomClear

Adapter for TStream to Pascal files

Mar 6th, 2020
62
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. unit StreamText;
  2.  
  3. interface
  4.  
  5. uses
  6.   System.SysUtils, System.Classes;
  7.  
  8. type
  9.   TBOMMode = (bomNone, bomPresent);
  10.  
  11. procedure AssignStream(out AText: TextFile; const AStream: TStream; const ABufferSize: Integer = SizeOf(TTextBuf); const AMode: Integer = fmClosed; const ABOMMode: TBOMMode = bomPresent);
  12. function DetectEncoding(const AStream: TStream): TEncoding;
  13.  
  14. implementation
  15.  
  16. const
  17.   CP_ACP  = 0;
  18.   CP_UTF8 = 65001;
  19.  
  20. function StreamNOPProc(var Rec: TTextRec): Integer;
  21. begin
  22.   // Does nothing
  23.   Result := 0;
  24. end;
  25.  
  26. function StreamIn(var Rec: TTextRec): Integer;
  27. begin
  28.   Rec.BufEnd := 0;
  29.   Rec.BufPos := 0;
  30.   Rec.BufEnd := TStream(Rec.Handle).Read(Rec.BufPtr^, Rec.BufSize);
  31.   Result := 0;
  32. end;
  33.  
  34. function StreamOut(var Rec: TTextRec): Integer;
  35. begin
  36.   if Rec.BufPos <> 0 then
  37.   begin
  38.     TStream(Rec.Handle).WriteBuffer(Rec.BufPtr^, Rec.BufPos);
  39.     Rec.BufPos := 0;
  40.   end;
  41.   Result := 0;
  42. end;
  43.  
  44. function StreamFlush(var Rec: TTextRec): Integer;
  45. begin
  46.   Result := StreamOut(Rec);
  47. end;
  48.  
  49. type
  50.   TUTF8EncoderStream = class(TStream)
  51.   strict private
  52.     FStream: TStream;
  53.     FEncoding: TEncoding;
  54.     FOriginalPosition: Int64;
  55.     FFixedMultiplier: Integer;
  56.     function CountToRawCount(const ACount, APos: Int64): Int64;
  57.     function RawCountToCount(const ARAWCount, APos: Int64): Int64;
  58.   protected
  59.     function GetSize: Int64; override;
  60.     procedure SetSize(NewSize: Longint); overload; override;
  61.     procedure SetSize(const NewSize: Int64); overload; override;
  62.   public
  63.     function Read(var Buffer; Count: Longint): Longint; override;
  64.     function Write(const Buffer; Count: Longint): Longint; override;
  65.     function Seek(Offset: Longint; Origin: Word): Longint; overload; override;
  66.     function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; overload; override;
  67.   public
  68.     constructor Create(const AStream: TStream; const AEncoding: TEncoding);
  69.     property Stream: TStream read FStream;
  70.   end;
  71.  
  72. procedure FreeBuffer(var Rec: TTextRec);
  73. begin
  74.   if Assigned(PPointer(@Rec.UserData[2])^) then
  75.   begin
  76.     FreeMem(PPointer(@Rec.UserData[2])^);
  77.     PPointer(@Rec.UserData[2])^ := nil;
  78.   end;
  79. end;
  80.  
  81. function StreamClose(var Rec: TTextRec): Integer;
  82. var
  83.   Obj: TObject;
  84. begin
  85.   if TStream(Rec.Handle) is TUTF8EncoderStream then
  86.   begin
  87.     Obj := TObject(Rec.Handle);
  88.     TStream(Rec.Handle) := TUTF8EncoderStream(Rec.Handle).Stream;
  89.     FreeAndNil(Obj);
  90.   end;
  91.   FreeBuffer(Rec);
  92.  
  93.   Rec.Mode := fmClosed;
  94.   Result := 0;
  95. end;
  96.  
  97. function DetectEncoding(const AStream: TStream): TEncoding;
  98. var
  99.   Buf: TBytes;
  100.   Sz: Integer;
  101. begin
  102.   AStream.Position := 0;
  103.   SetLength(Buf, 256);
  104.   Sz := AStream.Read(Pointer(Buf)^, Length(Buf));
  105.   SetLength(Buf, Sz);
  106.   if Length(Buf) > 0 then
  107.   begin
  108.     TEncoding.GetBufferEncoding(Buf, Result, TEncoding.Default);
  109.     AStream.Position := Length(Result.GetPreamble);
  110.   end
  111.   else
  112.   begin
  113.     AStream.Position := 0;
  114.     Result := TEncoding.Default;
  115.   end;
  116. end;
  117.  
  118. function StreamOpen(var Rec: TTextRec): Integer;
  119. const
  120.   BOM_UTF8: array[0..2] of Byte = ($EF, $BB, $BF);
  121. var
  122.   Encoding: TEncoding;
  123.   BOMMode: TBOMMode;
  124. begin
  125.   BOMMode := TBOMMode(Rec.UserData[1]);
  126.   Rec.BufPos := 0;
  127.   Rec.BufEnd := 0;
  128.   Rec.FlushFunc := @StreamNOPProc;
  129.   Rec.CloseFunc := @StreamClose;
  130.   Result := 0;
  131.  
  132.   case Rec.Mode of
  133.     fmInput: // called by Reset
  134.     begin
  135.       Encoding := DetectEncoding(TStream(Rec.Handle));
  136.       if not (Encoding is TUTF8Encoding) then
  137.         TStream(Rec.Handle) := TUTF8EncoderStream.Create(TStream(Rec.Handle), Encoding);
  138.       Rec.InOutFunc := @StreamIn;
  139.     end;
  140.     fmOutput: // called by Rewrite
  141.     begin
  142.       Rec.InOutFunc := @StreamOut;
  143.       Rec.FlushFunc := @StreamFlush;
  144.       if BOMMode <> bomNone then
  145.         TStream(Rec.Handle).WriteBuffer(BOM_UTF8, SizeOf(BOM_UTF8));
  146.     end;
  147.     fmInOut:  // called by Append
  148.     begin
  149.       Encoding := DetectEncoding(TStream(Rec.Handle));
  150.       if not (Encoding is TUTF8Encoding) then
  151.         TStream(Rec.Handle) := TUTF8EncoderStream.Create(TStream(Rec.Handle), Encoding);
  152.       Rec.InOutFunc := @StreamOut;
  153.       Rec.FlushFunc := @StreamFlush;
  154.     end;
  155.   else
  156.     Exit;
  157.   end;
  158.  
  159.   if Rec.BufSize <= SizeOf(Rec.Buffer) then
  160.     Rec.BufPtr := Rec.Buffer
  161.   else
  162.   begin
  163.     FreeBuffer(Rec);
  164.     Rec.BufPtr := AllocMem(Rec.BufSize);
  165.     PPointer(@Rec.UserData[2])^ := Rec.BufPtr;
  166.   end;
  167. end;
  168.  
  169. procedure AssignStream(out AText: TextFile; const AStream: TStream; const ABufferSize: Integer; const AMode: Integer; const ABOMMode: TBOMMode);
  170. type
  171.   PTextRec = ^TTextRec;
  172. var
  173.   Rec: PTextRec;
  174. begin
  175.   Rec := @AText;
  176.   FillChar(Rec^, SizeOf(TTextRec), 0);
  177.  
  178.   if ABOMMode <> bomNone then
  179.     AStream.Position := 0;
  180.  
  181.   TStream(Rec.Handle) := AStream;
  182.   Rec.CodePage := CP_UTF8;
  183.   Rec.Mode := AMode;
  184.   Rec.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle);
  185.   if ABufferSize <= SizeOf(Rec.Buffer) then
  186.   begin
  187.     Rec.BufPtr := Rec.Buffer;
  188.     Rec.BufSize := SizeOf(Rec.Buffer);
  189.   end
  190.   else
  191.   begin
  192.     Rec.BufPtr := nil;
  193.     Rec.BufSize := ABufferSize;
  194.   end;
  195.   Rec.OpenFunc := @StreamOpen;
  196.   Rec.UserData[1] := Ord(ABOMMode);
  197.  
  198.   StreamOpen(Rec^);
  199. end;
  200.  
  201. { TUTF8EncoderStream }
  202.  
  203. constructor TUTF8EncoderStream.Create(const AStream: TStream;
  204.   const AEncoding: TEncoding);
  205. begin
  206.   inherited Create;
  207.   FStream := AStream;
  208.   FEncoding := AEncoding;
  209.   FOriginalPosition := FStream.Position;
  210.  
  211.   if AEncoding.IsSingleByte then
  212.     FFixedMultiplier := 1
  213.   else
  214.   if (AEncoding.ClassType = TUnicodeEncoding) or
  215.      (AEncoding.ClassType = TBigEndianUnicodeEncoding) then
  216.     FFixedMultiplier := 2
  217.   else
  218.     Assert(False, 'Not supported');
  219. end;
  220.  
  221. function TUTF8EncoderStream.Read(var Buffer; Count: Integer): Longint;
  222. var
  223.   Buf: TBytes;
  224.   RAWCount: Integer;
  225.   Pos: Int64;
  226.   UTF8Buf: UTF8String;
  227. begin
  228.   Pos := FStream.Position;
  229.   RAWCount := CountToRawCount(Count, Pos);
  230.   SetLength(Buf, RAWCount);
  231.   RAWCount := FStream.Read(Pointer(Buf)^, RAWCount);
  232.   SetLength(Buf, RAWCount);
  233.  
  234.   UTF8Buf := UTF8String(FEncoding.GetString(Buf));
  235.   Move(Pointer(UTF8Buf)^, Buffer, Length(UTF8Buf));
  236.   Result := Length(UTF8Buf);
  237. end;
  238.  
  239. function TUTF8EncoderStream.Write(const Buffer; Count: Integer): Longint;
  240. var
  241.   UTF8Buf: UTF8String;
  242.   Buf: TBytes;
  243. begin
  244.   SetLength(UTF8Buf, Count);
  245.   Move(Buffer, Pointer(UTF8Buf)^, Length(UTF8Buf));
  246.   Buf := FEncoding.GetBytes(String(UTF8Buf));
  247.  
  248.   FStream.WriteBuffer(Pointer(Buf), Length(Buf));
  249.   Result := Length(Buf);
  250. end;
  251.  
  252. function TUTF8EncoderStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
  253. begin
  254.   case Origin of
  255.     soBeginning: FStream.Position := CountToRawCount(Offset, 0);
  256.     soCurrent: FStream.Position := FStream.Position + CountToRawCount(Offset, FStream.Position);
  257.     soEnd: FStream.Position := FStream.Size + CountToRawCount(Offset, FStream.Size);
  258.   end;
  259.   Result := RAWCountToCount(FStream.Position, 0);
  260. end;
  261.  
  262. function TUTF8EncoderStream.GetSize: Int64;
  263. var
  264.   RAWCount: Integer;
  265. begin
  266.   RAWCount := FStream.Size - FOriginalPosition;
  267.   Result := RAWCountToCount(RAWCount, FOriginalPosition);
  268. end;
  269.  
  270. procedure TUTF8EncoderStream.SetSize(const NewSize: Int64);
  271. begin
  272.   FStream.Size := CountToRawCount(NewSize, 0);
  273. end;
  274.  
  275. function TUTF8EncoderStream.Seek(Offset: Integer; Origin: Word): Longint;
  276. var
  277.   Offs: Int64;
  278.   Org: TSeekOrigin;
  279. begin
  280.   Offs := Offset;
  281.   Org := TSeekOrigin(Origin);
  282.   Result := Seek(Offs, Org);
  283. end;
  284.  
  285. procedure TUTF8EncoderStream.SetSize(NewSize: Integer);
  286. var
  287.   Sz: Int64;
  288. begin
  289.   Sz := NewSize;
  290.   SetSize(Sz);
  291. end;
  292.  
  293. function TUTF8EncoderStream.CountToRawCount(const ACount, APos: Int64): Int64;
  294. begin
  295.   if FFixedMultiplier <> 0 then
  296.   begin
  297.     Result := ACount * FFixedMultiplier;
  298.     Exit;
  299.   end;
  300.   Assert(False, 'Not supported');
  301.   Result := ACount;
  302. end;
  303.  
  304. function TUTF8EncoderStream.RawCountToCount(const ARAWCount, APos: Int64): Int64;
  305. begin
  306.   if FFixedMultiplier <> 0 then
  307.   begin
  308.     Result := ARAWCount div FFixedMultiplier;
  309.     Exit;
  310.   end;
  311.   Assert(False, 'Not supported');
  312.   Result := ARAWCount;
  313. end;
  314.  
  315. end.
RAW Paste Data