(******************************************************************************

______________________________________________________________________________

YTD v1.00                                                    (c) 2009-12 Pepak
http://www.pepak.net/ytd                                  http://www.pepak.net
______________________________________________________________________________


Copyright (c) 2009-12 Pepak (http://www.pepak.net)
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.
    * Redistributions in binary form must reproduce the above copyright
      notice, this list of conditions and the following disclaimer in the
      documentation and/or other materials provided with the distribution.
    * Neither the name of Pepak nor the
      names of his contributors may be used to endorse or promote products
      derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL PEPAK BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

******************************************************************************)

unit uFiles;
{$INCLUDE 'pepak.inc'}

interface
{$DEFINE TEXTSTREAMS}
{$DEFINE TEXTFUNCTIONS}

uses
  SysUtils, Classes, Windows,
  uCompatibility;

type
  TFileEncoding = (feAuto, feANSI, feOEM, feUTF16, feUTF8);

function LoadFileIntoMemory(const FileName: string): TMemoryStream;
procedure SaveMemoryToFile(const FileName: string; Data: Pointer; DataLength: integer);
procedure AppendMemoryToFile(const FileName: string; Data: Pointer; DataLength: integer);

{$IFDEF TEXTFUNCTIONS}
function GuessFileEncoding(Data: Pointer; DataLength: Integer; out BomLength: integer): TFileEncoding;
function LoadFileIntoMemoryW(const FileName: string; Encoding: TFileEncoding; out FoundEncoding: TFileEncoding): TMemoryStream; overload;
function LoadFileIntoMemoryW(const FileName: string; Encoding: TFileEncoding): TMemoryStream; overload;
function LoadFileIntoMemoryA(const FileName: string; Encoding: TFileEncoding; out FoundEncoding: TFileEncoding): TMemoryStream; overload;
function LoadFileIntoMemoryA(const FileName: string; Encoding: TFileEncoding): TMemoryStream; overload;
function LoadFileIntoStringW(const FileName: string; Encoding: TFileEncoding; out FoundEncoding: TFileEncoding): WideString; overload;
function LoadFileIntoStringW(const FileName: string; Encoding: TFileEncoding): WideString; overload;
function LoadFileIntoStringA(const FileName: string; Encoding: TFileEncoding; out FoundEncoding: TFileEncoding): AnsiString; overload;
function LoadFileIntoStringA(const FileName: string; Encoding: TFileEncoding): AnsiString; overload;
function LoadFileIntoString(const FileName: string; Encoding: TFileEncoding; out FoundEncoding: TFileEncoding): string; overload;
function LoadFileIntoString(const FileName: string; Encoding: TFileEncoding): string; overload;
procedure SaveMemoryToFileW(const FileName: string; Data: Pointer; DataLength: integer; Encoding: TFileEncoding; BOM: boolean = False; Append: boolean = False);
procedure SaveStringToFileW(const FileName: string; const Data: WideString; Encoding: TFileEncoding = feAuto; BOM: boolean = False; Append: boolean = False);
procedure SaveStringToFile(const FileName: string; const Data: string; Encoding: TFileEncoding = feAuto; BOM: boolean = False; Append: boolean = False);
{$ENDIF}

function FileGetSize(const FileName: string): int64;
function FileGetDateTime(const FileName: string): TDateTime;

{$IFDEF TEXTSTREAMS}
type
  TBufferedStream = class(TStream)
    private
      FStream: TStream;
      FOwnsStream: boolean;
      FBuffer: PAnsiChar;
      FBufferSize: integer;
      FBufferPosition: int64;
      FBufferFill: integer;
      FBufferDirty: boolean;
      FPosition: int64;
    protected
      procedure Init; virtual;
      procedure SetSize(NewSize: Longint); override;
      {$IFDEF DELPHI2007_UP}
      procedure SetSize(const NewSize: Int64); override;
      {$ENDIF}
      function InternalSeek(const Offset: Int64; Origin: TSeekOrigin): Int64; virtual;
      procedure ClearBuffer;
      procedure FillBuffer;
      property Stream: TStream read FStream;
      property OwnsStream: boolean read FOwnsStream;
      property Buffer: PAnsiChar read FBuffer;
      property BufferSize: integer read FBufferSize;
      property BufferPosition: int64 read FBufferPosition;
      property BufferFill: integer read FBufferFill;
      property BufferDirty: boolean read FBufferDirty;
      property Position: int64 read FPosition write FPosition;
    public
      constructor Create(AStream: TStream; ABufferSize: integer; AOwnsStream: boolean = False); overload;
      constructor Create(AStream: TStream; AOwnsStream: boolean = False); overload;
      destructor Destroy; override;
      procedure Flush; virtual;
      function Read(var OutBuffer; Count: Longint): Longint; override;
      function Write(const InBuffer; Count: Longint): Longint; override;
      function Seek(Offset: Longint; Origin: Word): Longint; override;
      {$IFDEF DELPHI2007_UP}
      function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
      {$ENDIF}
    end;

  TTextStream = class(TBufferedStream)
    private
      FDefaultEncoding: TFileEncoding;
      FEncoding: TFileEncoding;
      FBigEndian: boolean;
      FLineSeparator: string;
      {$IFDEF UNICODE}
      FSecondSurrogatePair: WideChar;
      {$ENDIF}
      procedure SetEncoding(const Value: TFileEncoding);
    protected
      procedure Init; override;
      procedure GuessEncoding;
      function InternalSeek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
      property BigEndian: boolean read FBigEndian;
    public
      class procedure AppendLine(const FileName, Msg: string; const Encoding: TFileEncoding = feAuto);
      constructor Create(AHandle: THandle); overload;
      constructor Create(const AFileName: string; const AMode: Word); overload;
      constructor Create(const AFileName: string; const AMode, AShareFlags: Word); overload;
      property Encoding: TFileEncoding read FEncoding write SetEncoding;
      property DefaultEncoding: TFileEncoding read FDefaultEncoding write FDefaultEncoding;
      property LineSeparator: string read FLineSeparator write FLineSeparator;
      function Eof: boolean;
      function ReadChar(out Ch: Char): boolean;
      function ReadLine(out Line: string): boolean;
      procedure WriteStr(const S: string);
      procedure WriteLine(const S: string);
      procedure Flush; override;
      function Write(const InBuffer; Count: Longint): Longint; override;
    end;
{$ENDIF}

implementation

uses
  uStrings;

{$IFDEF TEXTSTREAMS}
const
  DEFAULT_BUFFER_SIZE = 16384;
  BOM_UTF16: array[0..1] of byte = ($ff, $fe);
  BOM_UTF8: array[0..2] of byte = ($ef, $bb, $bf);
  MAX_SIZE_FOR_AUTODETECT = DEFAULT_BUFFER_SIZE;
{$ENDIF}

function LoadFileIntoMemory(const FileName: string): TMemoryStream;
var F: TFileStream;
begin
  F := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
  try
    Result := TMemoryStream.Create;
    try
      Result.CopyFrom(F, 0);
      Result.Position := 0;
    except
      FreeAndNil(Result);
      Raise;
      end;
  finally
    F.Free;
    end;
end;

procedure SaveMemoryToFile(const FileName: string; Data: Pointer; DataLength: integer);
begin
  with TFileStream.Create(FileName, fmCreate) do
    try
      if DataLength > 0 then
        WriteBuffer(Data^, DataLength);
    finally
      Free;
      end;
end;

procedure AppendMemoryToFile(const FileName: string; Data: Pointer; DataLength: integer);
begin
  with TFileStream.Create(FileName, fmOpenRead or fmOpenWrite) do
    try
      Position := Size;
      if DataLength > 0 then
        WriteBuffer(Data^, DataLength);
    finally
      Free;
      end;
end;

{$IFDEF TEXTFUNCTIONS}

function EncodingToCodePage(Encoding: TFileEncoding): integer;
begin
  case Encoding of
    feAuto:
      Raise EConvertError.Create('Invalid encoding specified.');
    feANSI:
      Result := CP_ACP;
    feOEM:
      Result := CP_OEMCP;
    feUTF8:
      Result := CP_UTF8;
    else
      Result := CP_ACP;
    end;
end;

function LoadFileIntoMemoryW(const FileName: string; Encoding: TFileEncoding; out FoundEncoding: TFileEncoding): TMemoryStream;
var Source: TMemoryStream;
    CodePage, Size, NewSize, BomLength: integer;
    Content: WideString;
    P: Pointer;
begin
  Source := LoadFileIntoMemory(FileName);
  try
    if Encoding = feAuto then
      Encoding := GuessFileEncoding(Source.Memory, Source.Size, BomLength);
    FoundEncoding := Encoding;
    if Source.Size = 0 then
      Result := Source
    else if Encoding = feUTF16 then
      if BomLength = 0 then
        Result := Source
      else
        begin
        Result := TMemoryStream.Create;
        try
          Source.Position := BomLength;
          Result.CopyFrom(Source, Source.Size - BomLength);
        except
          FreeAndNil(Result);
          Raise;
          end;
        end
    else
      begin
      if Source.Size = BomLength then
        begin
        Content := '';
        NewSize := 0;
        end
      else
        begin
        P := Pointer(NativeUInt(Source.Memory) + NativeUInt(BomLength));
        CodePage := EncodingToCodePage(Encoding);
        Size := MultiByteToWideChar(CodePage, 0 {MB_ERR_INVALID_CHARS}, P, Source.Size - BomLength, nil, 0);
        if Size = 0 then
          Raise EConvertError.CreateFmt('Invalid unicode characters encountered(%d)', [GetLastError]);
        Inc(Size);
        SetLength(Content, Size);
        NewSize := MultiByteToWideChar(CodePage, 0 {MB_ERR_INVALID_CHARS}, P, Source.Size - BomLength, @Content[1], Size);
        if NewSize = 0 then
          Raise EConvertError.CreateFmt('Invalid unicode characters encountered(%d)', [GetLastError]);
        end;
      Result := TMemoryStream.Create;
      try
        Result.WriteBuffer(Content[1], NewSize * Sizeof(WideChar));
        Result.Position := 0;
        FreeAndNil(Source);
      except
        FreeAndNil(Result);
        Raise;
        end;
      end;
  except
    FreeAndNil(Source);
    Raise;
    end;
end;

function LoadFileIntoMemoryW(const FileName: string; Encoding: TFileEncoding): TMemoryStream;
var
  FoundEncoding: TFileEncoding;
begin
  Result := LoadFileIntoMemoryW(FileName, Encoding, FoundEncoding);
end;

function LoadFileIntoMemoryA(const FileName: string; Encoding: TFileEncoding; out FoundEncoding: TFileEncoding): TMemoryStream;
var Source: TMemoryStream;
    CodePage, Size, NewSize, BomLength: integer;
    ContentA: AnsiString;
    ContentW: WideString;
    P: Pointer;
begin
  Source := LoadFileIntoMemory(FileName);
  try
    if Encoding = feAuto then
      Encoding := GuessFileEncoding(Source.Memory, Source.Size, BomLength);
    FoundEncoding := Encoding;
    if Source.Size = 0 then
      Result := Source
    else if Encoding = feAnsi then
      begin
      Result := TMemoryStream.Create;
      try
        Source.Position := 0;
        Result.CopyFrom(Source, Source.Size);
      except
        FreeAndNil(Result);
        Raise;
        end;
      end
    else
      begin
      P := Pointer(NativeUInt(Source.Memory) + NativeUInt(BomLength));
      if Encoding <> feUtf16 then
        begin
        CodePage := EncodingToCodePage(Encoding);
        Size := MultiByteToWideChar(CodePage, 0 {MB_ERR_INVALID_CHARS}, P, Source.Size - BomLength, nil, 0);
        if Size = 0 then
          Raise EConvertError.CreateFmt('Invalid unicode characters encountered(%d)', [GetLastError]);
        Inc(Size);
        SetLength(ContentW, Size);
        NewSize := MultiByteToWideChar(CodePage, 0 {MB_ERR_INVALID_CHARS}, P, Source.Size - BomLength, @ContentW[1], Size);
        if NewSize = 0 then
          Raise EConvertError.CreateFmt('Invalid unicode characters encountered(%d)', [GetLastError]);
        Source.Clear;
        Source.WriteBuffer(ContentW[1], NewSize * Sizeof(WideChar));
        Source.Position := 0;
        BomLength := 0;
        P := Source.Memory;
        end;
      Size := WideCharToMultiByte(CP_ACP, 0 {MB_ERR_INVALID_CHARS}, P, (Source.Size - BomLength) div Sizeof(WideChar), nil, 0, '?', nil);
      if Size = 0 then
        Raise EConvertError.CreateFmt('Invalid unicode characters encountered(%d)', [GetLastError]);
      Inc(Size);
      SetLength(ContentA, Size);
      NewSize := WideCharToMultiByte(CP_ACP, 0 {MB_ERR_INVALID_CHARS}, P, (Source.Size - BomLength) div Sizeof(WideChar), @ContentA[1], Size, '?', nil);
      if NewSize = 0 then
        Raise EConvertError.CreateFmt('Invalid unicode characters encountered(%d)', [GetLastError]);
      Result := TMemoryStream.Create;
      try
        Result.WriteBuffer(ContentA[1], NewSize * Sizeof(AnsiChar));
        Result.Position := 0;
        FreeAndNil(Source);
      except
        FreeAndNil(Result);
        Raise;
        end;
      end;
  except
    FreeAndNil(Source);
    Raise;
    end;
end;

function LoadFileIntoMemoryA(const FileName: string; Encoding: TFileEncoding): TMemoryStream;
var
  FoundEncoding: TFileEncoding;
begin
  Result := LoadFileIntoMemoryA(FileName, Encoding, FoundEncoding);
end;

function LoadFileIntoStringW(const FileName: string; Encoding: TFileEncoding; out FoundEncoding: TFileEncoding): WideString;
var MS: TMemoryStream;
begin
  MS := LoadFileIntoMemoryW(FileName, Encoding, FoundEncoding);
  if MS = nil then
    Result := ''
  else
    try
      if MS.Size = 0 then
        Result := ''
      else
        begin
        SetLength(Result, MS.Size div Sizeof(WideChar));
        Move(MS.Memory^, Result[1], MS.Size);
        end;
    finally
      FreeAndNil(MS);
      end;
end;

function LoadFileIntoStringW(const FileName: string; Encoding: TFileEncoding): WideString;
var
  FoundEncoding: TFileEncoding;
begin
  Result := LoadFileIntoStringW(FileName, Encoding, FoundEncoding);
end;

function LoadFileIntoStringA(const FileName: string; Encoding: TFileEncoding; out FoundEncoding: TFileEncoding): AnsiString;
var MS: TMemoryStream;
begin
  MS := LoadFileIntoMemoryA(FileName, Encoding, FoundEncoding);
  if MS = nil then
    Result := ''
  else
    try
      if MS.Size = 0 then
        Result := ''
      else
        begin
        SetLength(Result, MS.Size);
        Move(MS.Memory^, Result[1], MS.Size);
        end;
    finally
      FreeAndNil(MS);
      end;
end;

function LoadFileIntoStringA(const FileName: string; Encoding: TFileEncoding): AnsiString;
var
  FoundEncoding: TFileEncoding;
begin
  Result := LoadFileIntoStringA(FileName, Encoding, FoundEncoding);
end;

function LoadFileIntoString(const FileName: string; Encoding: TFileEncoding; out FoundEncoding: TFileEncoding): string;
begin
  {$IFDEF UNICODE}
  Result := string(LoadFileIntoStringW(FileName, Encoding, FoundEncoding));
  {$ELSE}
  Result := LoadFileIntoStringA(FileName, Encoding, FoundEncoding);
  {$ENDIF}
end;

function LoadFileIntoString(const FileName: string; Encoding: TFileEncoding): string;
var
  FoundEncoding: TFileEncoding;
begin
  Result := LoadFileIntoString(FileName, Encoding, FoundEncoding);
end;

procedure SaveMemoryToFileW(const FileName: string; Data: Pointer; DataLength: integer; Encoding: TFileEncoding; BOM: boolean; Append: boolean);
var Stream: TMemoryStream;
    CodePage, Size, NewSize: integer;
    SavedOK, IsNewFile: boolean;
begin
  SavedOK := False;
  if Encoding = feAuto then
    Encoding := feUTF8;
  if DataLength > 0 then
    if Encoding <> feUTF16 then
      begin
      CodePage := EncodingToCodePage(Encoding);
      Size := WideCharToMultiByte(CodePage, 0 {MB_ERR_INVALID_CHARS}, Data, DataLength div Sizeof(WideChar), nil, 0, nil, nil);
      if Size = 0 then
        Raise EConvertError.CreateFmt('Invalid unicode characters encountered(%d)', [GetLastError]);
      Stream := TMemoryStream.Create;
      try
        Inc(Size);
        Stream.Size := Size;
        NewSize := WideCharToMultiByte(CodePage, 0 {MB_ERR_INVALID_CHARS}, Data, DataLength div Sizeof(WideChar), Stream.Memory, Size, nil, nil);
        if NewSize = 0 then
          Raise EConvertError.CreateFmt('Invalid unicode characters encountered(%d)', [GetLastError]);
        Stream.Size := NewSize;
        IsNewFile := not FileExists(FileName);
        if BOM and (Encoding in [feUTF16, feUTF8]) and (IsNewFile or (not Append)) then
          begin
          case Encoding of
            feUTF16:
              SaveMemoryToFile(FileName, @BOM_UTF16[0], Length(BOM_UTF16));
            feUtf8:
              SaveMemoryToFile(FileName, @BOM_UTF8[0], Length(BOM_UTF8));
            else
              SaveMemoryToFile(FileName, nil, 0);
            end;
          AppendMemoryToFile(FileName, Stream.Memory, Stream.Size);
          end
        else
          if Append and (not IsNewFile) then
            AppendMemoryToFile(FileName, Stream.Memory, Stream.Size)
          else
            SaveMemoryToFile(FileName, Stream.Memory, Stream.Size);
        SavedOK := True;
      finally
        Stream.Free;
        end;
      end;
  if not SavedOK then
    SaveMemoryToFile(FileName, Data, DataLength)
end;

procedure SaveStringToFileW(const FileName: string; const Data: WideString; Encoding: TFileEncoding; BOM: boolean; Append: boolean);
var
  n: integer;
begin
  n := Length(Data);
  if n > 0 then
    SaveMemoryToFileW(FileName, @Data[1], n*Sizeof(WideChar), Encoding, BOM, Append);
end;

procedure SaveStringToFile(const FileName: string; const Data: string; Encoding: TFileEncoding; BOM: boolean; Append: boolean);
begin
  SaveStringToFileW(FileName, WideString(Data), Encoding, BOM, Append);
end;

function GuessFileEncoding(Data: Pointer; DataLength: Integer; out BomLength: integer): TFileEncoding;

  procedure SwitchByteOrder;
    var i: integer;
        b: byte;
    begin
      i := 0;
      while i < DataLength do
        begin
        b := PByteArray(Data)^[i];
        PByteArray(Data)^[i] := PByteArray(Data)^[Succ(i)];
        PByteArray(Data)^[Succ(i)] := b;
        Inc(i, 2);
        end;
    end;

var i: integer;
    OddZeroCount, EvenZeroCount: integer;
begin
  BomLength := 0;
  // Unicode must have at least two bytes
  if DataLength <= 1 then
    begin
    Result := feANSI;
    Exit;
    end;
  // Check BOM
  if (DataLength >= 2) and ((DataLength mod 2) = 0) then
    if (PWordArray(Data)^[0] = $feff) or (PWordArray(Data)^[0] = $fffe) then
      begin
      Result := feUTF16;
      BomLength := 2;
      // If it is big-endian, convert it to little-endian
      if PWordArray(Data)^[0] = $fffe then
        SwitchByteOrder;
      Exit;
      end;
  if (DataLength >= 3) then
    if (PByteArray(Data)^[0] = $ef) and (PByteArray(Data)^[1] = $bb) and (PByteArray(Data)^[2] = $bf) then
      begin
      Result := feUtf8;
      BomLength := 3;
      Exit;
      end;
  // Try to convert the string as UTF8. If it succeeds, assume UTF8
  if MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, Data, DataLength, nil, 0) <> 0 then
    begin
    Result := feUtf8;
    Exit;
    end;
  // I need to decide between Unicode and ANSI.
  // Assumption: ANSI doesn't use binary zero very often, except maybe separating words or lines
  // or as a filler. Unicode will have binary zero in all 7-bit ASCII characters, which will presumably
  // be present in the text (at least, they will be present in HTML/XML tags).
  OddZeroCount := 0;
  EvenZeroCount := 0;
  for i := 0 to Pred(DataLength) do
    if PByteArray(Data)^[i] = 0 then
      if (i mod 2) = 0 then
        Inc(EvenZeroCount)
      else
        Inc(OddZeroCount);
  if (OddZeroCount > 30) and (OddZeroCount > 100*EvenZeroCount) then
    begin
    Result := feUTF16;
    Exit;
    end;
  if (EvenZeroCount > 30) and (EvenZeroCount > 100*OddZeroCount) then
    begin
    Result := feUTF16;
    SwitchByteOrder;
    Exit;
    end;
  // Otherwise it is ANSI
  Result := feAnsi;
end;

{$ENDIF}

function FileGetSize(const FileName: string): int64;
var Handle: THandle;
    FileSizeHigh, FileSizeLow: DWORD;
begin
  Result := -1;
  Handle := CreateFile(PChar(FileName), 0, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  if Handle <> INVALID_HANDLE_VALUE then
    try
      FileSizeLow := GetFileSize(Handle, @FileSizeHigh);
      if (FileSizeLow <> $ffffffff) or (GetLastError = NO_ERROR) then
        Result := int64(FileSizeHigh) shl 32 + int64(FileSizeLow);
    finally
      CloseHandle(Handle);
      end;
end;

function FileGetDateTime(const FileName: string): TDateTime;
{$IFNDEF DELPHI2007_UP}
var DosTime: integer;
{$ENDIF}
begin
  {$IFDEF DELPHI2007_UP}
  if not FileAge(FileName, Result) then
    Result := 0;
  {$ELSE}
  DosTime := FileAge(FileName);
  if DosTime > 0 then
    Result := FileDateToDateTime(DosTime)
  else
    Result := 0;
  {$ENDIF}
end;

{$IFDEF TEXTSTREAMS}

{ TBufferedStream }

constructor TBufferedStream.Create(AStream: TStream; ABufferSize: integer; AOwnsStream: boolean);
begin
  inherited Create;
  FStream := AStream;
  FOwnsStream := AOwnsStream;
  FBufferSize := ABufferSize;
  GetMem(FBuffer, BufferSize);
  ClearBuffer;
  Init;
end;

constructor TBufferedStream.Create(AStream: TStream; AOwnsStream: boolean);
begin
  Create(AStream, DEFAULT_BUFFER_SIZE, AOwnsStream);
end;

destructor TBufferedStream.Destroy;
begin
  Flush;
  if FOwnsStream then
    FreeAndNil(FStream);
  FreeMem(FBuffer);
  FBuffer := nil;
  inherited;
end;

procedure TBufferedStream.Init;
begin
end;

procedure TBufferedStream.ClearBuffer;
begin
  FBufferPosition := 0;
  FBufferFill := 0;
  FBufferDirty := False;
end;

procedure TBufferedStream.FillBuffer;
begin
  if Stream.Position <> Position then
    Stream.Position := Position;
  FBufferPosition := Position;
  FBufferFill := Stream.Read(Buffer^, BufferSize);
  FBufferDirty := False;
end;

procedure TBufferedStream.Flush;
begin
  if FBufferDirty then
    begin
    if Stream.Position <> BufferPosition then
      Stream.Position := BufferPosition;
    Stream.WriteBuffer(Buffer^, BufferFill);
    FBufferDirty := False;
    end;
end;

procedure TBufferedStream.SetSize(NewSize: Longint);
begin
  {$IFDEF DELPHI2007_UP}
  SetSize(Int64(NewSize));
  {$ELSE}
  Flush;
  ClearBuffer;
  Stream.Size := NewSize;
  Position := Stream.Position;
  inherited;
  {$ENDIF}
end;

{$IFDEF DELPHI2007_UP}
procedure TBufferedStream.SetSize(const NewSize: Int64);
begin
  Flush;
  ClearBuffer;
  Stream.Size := NewSize;
  Position := Stream.Position;
  // Do not call inherited, as per comments in the TStream.SetSize implementation
end;
{$ENDIF}

function TBufferedStream.InternalSeek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
  case Origin of
    soBeginning:
      Position := Offset;
    soCurrent:
      Position := Position + Offset;
    soEnd:
      Position := Stream.Size + Offset;
  end;
  Result := Position;
end;

function TBufferedStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
  Result := InternalSeek(Offset, TSeekOrigin(Origin));
end;

{$IFDEF DELPHI2007_UP}
function TBufferedStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
  Result := InternalSeek(Offset, Origin);
end;
{$ENDIF}

function TBufferedStream.Read(var OutBuffer; Count: Longint): Longint;
var
  BufStart: int64;
  BufOfs, BufLen: integer;
  Buf: PAnsiChar;
  Dest: PAnsiChar;
begin
  Result := 0;
  Dest := @OutBuffer;
  if Count > 0 then
    begin
    // Read the rest of the buffer
    BufStart := Position - BufferPosition;
    if (BufStart >= 0) and (BufStart < BufferFill) then
      begin
      BufOfs := BufStart;
      BufLen := BufferFill - BufOfs;
      if BufLen > Count then
        BufLen := Count;
      Buf := Pointer(NativeUInt(Buffer) + NativeUInt(BufOfs));
      Move(Buf^, Dest^, BufLen);
      Position := Position + BufLen;
      Inc(Result, BufLen);
      Dec(Count, BufLen);
      Inc(Dest, BufLen);
      end;
    if Count > 0 then
      begin
      // Flush and clear the current buffer
      Flush;
      ClearBuffer;
      // If the remaining data is larger than the buffer, read it all at once
      if Count > BufferSize then
        begin
        if Stream.Position <> Position then
          Stream.Position := Position;
        Inc(Result, Stream.Read(Dest^, Count));
        Position := Stream.Position;
        end
      // Else fill the buffer from stream and read data from it
      else
        begin
        FillBuffer;
        if Count > BufferFill then
          Count := BufferFill;
        if Count > 0 then
          begin
          Move(Buffer^, Dest^, Count);
          Inc(Result, Count);
          Position := Position + Count;
          end;
        end;
      end;
    end;
end;

function TBufferedStream.Write(const InBuffer; Count: Longint): Longint;

  procedure UpdateBufferFill;
    var
      BufLen: integer;
    begin
      FBufferDirty := True;
      BufLen := Position - BufferPosition;
      if BufLen > BufferFill then
        begin
        FBufferDirty := True;
        FBufferFill := BufLen;
        end;
    end;

var
  BufStart: int64;
  BufOfs, BufLen: integer;
  Buf: PAnsiChar;
  Src: PAnsiChar;
begin
  Result := 0;
  Src := @InBuffer;
  if Count > 0 then
    begin
    // Write as much as I can into the buffer
    BufStart := Position - BufferPosition;
    if (BufStart >= 0) and (BufStart < BufferSize) then
      begin
      BufOfs := BufStart;
      BufLen := BufferSize - BufOfs;
      if BufLen > Count then
        BufLen := Count;
      Buf := Pointer(NativeUInt(Buffer) + NativeUInt(BufOfs));
      Move(Src^, Buf^, BufLen);
      Position := Position + BufLen;
      Inc(Result, BufLen);
      Dec(Count, BufLen);
      Inc(Src, BufLen);
      UpdateBufferFill;
      end;
    if Count > 0 then
      begin
      // Flush and clear the current buffer
      Flush;
      ClearBuffer;
      // If the remaining data is larger than the buffer, write it all at once
      if Count > BufferSize then
        begin
        if Stream.Position <> Position then
          Stream.Position := Position;
        Inc(Result, Stream.Write(Src^, Count));
        Position := Stream.Position;
        end
      // Else fill the buffer from stream and write data to it
      else
        begin
        FillBuffer;
        Move(Src^, Buffer^, Count);
        Inc(Result, Count);
        Position := Position + Count;
        UpdateBufferFill;
        end;
      end;
    end;
end;

{ TTextStream }

class procedure TTextStream.AppendLine(const FileName, Msg: string; const Encoding: TFileEncoding);
var
  Mode: Word;
  Stream: TTextStream;
begin
  if FileExists(FileName) then
    Mode := fmOpenReadWrite or fmShareDenyWrite
  else
    Mode := fmCreate;
  Stream := TTextStream.Create(FileName, Mode);
  try
    if Encoding <> feAuto then
      Stream.DefaultEncoding := Encoding;
    Stream.Position := Stream.Size;
    Stream.WriteLine(Msg);
  finally
    FreeAndNil(Stream);
    end;
end;

constructor TTextStream.Create(AHandle: THandle);
begin
  Create(THandleStream.Create(AHandle), True);
end;

constructor TTextStream.Create(const AFileName: string; const AMode: Word);
begin
  Create(TFileStream.Create(AFileName, AMode), True);
end;

constructor TTextStream.Create(const AFileName: string; const AMode, AShareFlags: Word);
var
  FS: TFileStream;
begin
  FS := TFileStream.Create(AFileName, AMode or AShareFlags);
  if ((AMode and fmCreate) = fmCreate) and (AShareFlags <> 0) and ((AShareFlags or fmCreate) = fmCreate) then
  begin
    FreeAndNil(FS);
    FS := TFileStream.Create(AFileName, fmOpenReadWrite or AShareFlags);
  end;
  Create(FS, True);
end;

procedure TTextStream.Init;
begin
  inherited;
  FDefaultEncoding := {$IFDEF UNICODE} feUtf8 {$ELSE} feAnsi {$ENDIF} ;
  FEncoding := feAuto;
  FBigEndian := False;
  FLineSeparator := #13#10;
  if Size <> 0 then
    GuessEncoding;
end;

function TTextStream.InternalSeek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
  {$IFDEF UNICODE}
  FSecondSurrogatePair := #0;
  {$ENDIF}
  Result := inherited InternalSeek(Offset, Origin);
end;

procedure TTextStream.SetEncoding(const Value: TFileEncoding);
begin
  if Position = 0 then
    case Value of
      feUtf16:
        begin
        WriteBuffer(BOM_UTF16[0], Length(BOM_UTF16));
        FBigEndian := False;
        end;
      feUtf8:
        WriteBuffer(BOM_UTF8[0], Length(BOM_UTF8));
      end;
  FEncoding := Value;
end;

procedure TTextStream.GuessEncoding;
var
  OldPos: int64;
  UTF16Buf: Word;
  StrBuf: RawByteString;
  StrBufSize, OddZeroCount, EvenZeroCount, i, n: integer;
  HighAsciiFound: boolean;
begin
  FEncoding := feAnsi;
  FBigEndian := False;
  OldPos := Position;
  try
    // Unicode must have at least two bytes
    if Size <= 1 then
      Exit;
    // Check for UTF16 via BOM
    if (Size >= 2) and ((Size mod 2) = 0) then
      begin
      Position := 0;
      if Read(UTF16Buf, Sizeof(UTF16Buf)) = Sizeof(UTF16Buf) then
        if UTF16Buf = $feff then
          begin
          FEncoding := feUTF16;
          OldPos := Position;
          Exit;
          end
        else if UTF16Buf = $fffe then
          begin
          FEncoding := feUTF16;
          FBigEndian := True;
          OldPos := Position;
          Exit;
          end
      end;
    // Check for UTF8 via BOM
    if (Size >= 3) then
      begin
      Position := 0;
      SetLength(StrBuf, 3);
      if Read(StrBuf[1], 3) = 3 then
        if (StrBuf[1] = #$ef) and (StrBuf[2] = #$bb) and (StrBuf[3] = #$bf) then
          begin
          FEncoding := feUTF8;
          OldPos := Position;
          Exit;
          end;
      end;
    // Read the first MAX_SIZE_FOR_AUTODETECT characters into a buffer
    Position := 0;
    StrBufSize := MAX_SIZE_FOR_AUTODETECT;
    if StrBufSize > Size then
      StrBufSize := Size;
    SetLength(StrBuf, StrBufSize);
    StrBufSize := Read(StrBuf[1], StrBufSize);
    SetLength(StrBuf, StrBufSize);
    // If no high-ASCII chars and no zeroes are present, assume ANSI
    HighAsciiFound := False;
    for i := 1 to Length(StrBuf) do
      if (StrBuf[i] >= #128) or (StrBuf[i] = #0) then
        begin
        HighAsciiFound := True;
        Break;
        end;
    if not HighAsciiFound then
      begin
      FEncoding := feANSI;
      Exit;
      end;
    // I need to decide between UTF16 and others.
    // Assumption: Non-UTF16 doesn't use binary zero very often, except maybe separating words or lines
    // or as a filler. Unicode will have binary zero in all 7-bit ASCII characters, which will presumably
    // be present in the text (at least, they will be present in HTML/XML tags).
    OddZeroCount := 0;
    EvenZeroCount := 0;
    for i := 1 to StrBufSize do
      if StrBuf[i] = #0 then
        if (i and 1) <> 0 then // <>, because I use a 1-based index, not 0-based
          Inc(EvenZeroCount)
        else
          Inc(OddZeroCount);
    if (OddZeroCount > 30) and (OddZeroCount > 100*EvenZeroCount) then
      begin
      FEncoding := feUTF16;
      Exit;
      end;
    if (EvenZeroCount > 30) and (EvenZeroCount > 100*OddZeroCount) then
      begin
      FEncoding := feUTF16;
      FBigEndian := True;
      Exit;
      end;
    // Try to parse the stream as UTF8. If it succeeds, assume UTF8
    if (StrBufSize <= MAX_SIZE_FOR_AUTODETECT) then
      begin
      n := StrBufSize;
      while (n > 0) and ByteBool(Byte(StrBuf[n]) and $80) do
        Dec(n);
      if n > 0 then
        begin
        if MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, PAnsiChar(StrBuf), n, nil, 0) <> 0 then
          begin
          FEncoding := feUtf8;
          Exit;
          end;
        end;
      end;
    // Otherwise it is ANSI
    FEncoding := feAnsi;
  finally
    Position := OldPos;
    end;
end;

function TTextStream.Eof: boolean;
begin
  Result := Position >= Size;
end;

procedure TTextStream.Flush;
begin
  {$IFDEF UNICODE}
  FSecondSurrogatePair := #0;
  {$ENDIF}
  inherited;
end;

function TTextStream.ReadChar(out Ch: Char): boolean;
var
  AChar: AnsiChar;
  WChar: WideChar;
  i, ExtraBytes: integer;
  UTF8: LongWord;
begin
  Result := False;
  if (Position = 0) and (Encoding = feAuto) then
    GuessEncoding;
  {$IFDEF UNICODE}
  if FSecondSurrogatePair <> #0 then
  begin
    Ch := FSecondSurrogatePair;
    FSecondSurrogatePair := #0;
    Result := True;
    Exit;
  end;
  {$ENDIF}
  case Encoding of
    feUTF16:
      begin
        Result := Read(WChar, Sizeof(WChar)) = Sizeof(WChar);
        if BigEndian then
          WChar := WideChar((Word(WChar) shr 8) or ((Word(WChar) and $ff) shl 8));
        Ch := {$IFNDEF UNICODE} WideToAnsi {$ENDIF} (WChar);
      end;
    feUTF8:
      begin
        if Read(AChar, Sizeof(AChar)) = Sizeof(AChar) then
          begin
          if (Byte(AChar) and $80) = $00 then
            begin
            UTF8 := Byte(AChar) and $7f;
            ExtraBytes := 0;
            end
          else if (Byte(AChar) and $e0) = $c0 then
            begin
            UTF8 := Byte(AChar) and $1f;
            ExtraBytes := 1;
            end
          else if (Byte(AChar) and $f0) = $e0 then
            begin
            UTF8 := Byte(AChar) and $0f;
            ExtraBytes := 2;
            end
          else if (Byte(AChar) and $f8) = $f0 then
            begin
            UTF8 := Byte(AChar) and $07;
            ExtraBytes := 3;
            end
          else if (Byte(AChar) and $fc) = $f8 then
            begin
            UTF8 := Byte(AChar) and $03;
            ExtraBytes := 4;
            end
          else if (Byte(AChar) and $fe) = $fc then
            begin
            UTF8 := Byte(AChar) and $01;
            ExtraBytes := 5;
            end
          else
            begin
            UTF8 := Byte(AChar);
            ExtraBytes := 0;
            end;
          for i := 1 to ExtraBytes do
            if Read(AChar, Sizeof(AChar)) = Sizeof(AChar) then
              if (Byte(AChar) and $c0) <> $80 then
                begin
                Position := Pred(Position);
                Break;
                end
              else
                UTF8 := (UTF8 shl 6) or (Byte(AChar) and $3f);
          Result := True;
          if UTF8 >= $1000000 then
            Ch := '?'
          else if UTF8 >= $10000 then
          begin
            {$IFDEF UNICODE}
            Dec(UTF8, $10000);
            Ch := WideChar((UTF8 shr 10) + $d800);
            FSecondSurrogatePair := WideChar((UTF8 and $3ff) + $dc00);
            {$ELSE}
            Ch := '?';
            {$ENDIF}
          end
          else
            Ch := {$IFNDEF UNICODE} WideToAnsi {$ENDIF} (WideChar(UTF8));
          end;
      end;
    else
      begin
        Result := Read(AChar, Sizeof(AChar)) = Sizeof(AChar);
        Ch := {$IFDEF UNICODE} AnsiToWide {$ENDIF} (AChar);
      end;
    end;
end;

function TTextStream.ReadLine(out Line: string): boolean;
var
  Ch: Char;
  CurPos: int64;
begin
  Result := not Eof;
  Line := '';
  if Result then
    while ReadChar(Ch) do
      if Ch = #13 then
        begin
        CurPos := Position;
        if ReadChar(Ch) then
          if Ch <> #10 then
            Position := CurPos;
        Break;
        end
      else if Ch = #10 then
        Break
      else
        Line := Line + Ch;
end;

procedure TTextStream.WriteStr(const S: string);
var
  Data: Pointer;
  Size: integer;
  AStr: RawByteString;
  WStr: WideString;
begin
  if s <> '' then
    begin
    if Encoding = feAuto then
      Encoding := DefaultEncoding;
    case Encoding of
      feUTF16:
        begin
          WStr := WideString(S);
          Data := @(WStr[1]);
          Size := Length(WStr) * Sizeof(WideChar);
        end;
      feUTF8,
      feAuto:
        begin
          WStr := WideString(S);
          AStr := WideToUTF8(WStr);
          Data := @(AStr[1]);
          Size := Length(AStr) * Sizeof(AnsiChar);
        end;
      feANSI:
        begin
          AStr := {$IFDEF UNICODE} AnsiString {$ENDIF} (S);
          Data := @(AStr[1]);
          Size := Length(AStr) * Sizeof(AnsiChar);
        end;
      feOEM:
        begin
          AStr := {$IFDEF UNICODE} AnsiString {$ENDIF} (S);
          AStr := AnsiToOEM(AStr);
          Data := @(AStr[1]);
          Size := Length(AStr) * Sizeof(AnsiChar);
        end;
      else
        Raise EWriteError.Create('Invalid encoding');
      end;
    WriteBuffer(Data^, Size);
    end;
end;

function TTextStream.Write(const InBuffer; Count: Longint): Longint;
begin
  {$IFDEF UNICODE}
  FSecondSurrogatePair := #0;
  {$ENDIF}
  Result := inherited Write(InBuffer, Count);
end;

procedure TTextStream.WriteLine(const S: string);
begin
  WriteStr(S);
  WriteStr(LineSeparator);
end;

{$ENDIF}

end.
