//////////////////////////////////////////////////////////
// Ideas and add-ons
//
// Format "S?YSIBSC(S)" = String
//                        Unknown
//                        Byte
//                        String
//                        Integer
//                        Boolean
//                        String
//                        CompressedBoolean
//                      () Read an integer and loop Value of That integer in according to block
// Format check to match settings as in
//
// FormatNodes as TStrings to explain the format to one self
//////////////////////////////////////////////////////////
//
// Name        : TlplStorage
// Version     : 1.09
// Author      : Christian Aaangel (C.Aaangel@Mailexcite.com)
// Groups      : Non-Visual, Memory management
// Purpose     : Binary file storing
// Last update : February 15 2002, Happy valentins day Julie
//
// Copyright © 2001 - 2002 by C. Aaangel
//////////////////////////////////////////////////////////
//
// What's new:
// 1.00 - initial Release
// 1.01 - Boolean Value Supported
// 1.02 - Added Custom File ID
// 1.03 - Added Compressed Boolean type
//        Enables storage of 8 booleans in one byte
// 1.04 - Added the ability to use a stream for instead
//        of creating files only to be used in one program
//        session.
// 1.05 - Added EndOfFile function
// 1.06 - Added CustomFileID as property
//        OpenArchive will now check for correct CustomFileID
//        If not found it will return false
// 1.07 - Added Property IsOpen, to check for an already open
//        Stream.
// 1.08 - You can now load a Storage file into memory
//        -> Set WriteTo to wtFile
//        -> OpenArchive
//        -> Set WriteTo to wtMemory
//        This will automaticly close the open file and
//        load it into the storage stream, Please notice that
//        the filemode must be read.
// 1.09 - Append option is now available, but only in Memory
//        loaded files, But then offcause you can use the save
//        to file option :)
//
//////////////////////////////////////////////////////////

unit lplStorage;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  TStateChange = procedure(Closed, Read, Write: Boolean) of object;
  TWriteTo = (wtFile, wtMemory);
  TCompressedBooleans = Array[0 .. 7] of Boolean;
  TValue = Record
   ValueType: Byte; // 0 = Byte; 1 = Integer; 2 = String; 3 = Unknown; 4 = Boolean; 5 = EndOfFile; 6 = CompressedBooleans
   ValueInByte: Byte;
   ValueInInteger: Integer;
   ValueInString: String;
   ValueInBoolean: Boolean;
   ValueInCompressedBooleans: TCompressedBooleans;
  End;
  TReadNext = Procedure(NewValue: TValue) of Object;
  ENotRead = Class(Exception);
  ENotWrite = Class(Exception);
  EAlreadyOpen = Class(Exception);
  EIncorrectFileType = Class(Exception);
  EFileNotFound = Class(Exception);
  EStructureError = Class(Exception);
  EEndOfFile = Class(Exception);
  TlplStorage = class(TComponent)
  private
   IOMode: Byte;
//   ValueBuffer: Array[0 .. 1048576] of byte;
   StorageFile: File;
   StorageStream: TMemoryStream;
   fCustomID: String;
   FFilename: TFilename;
   fWriteTo: TWriteTo;
   fStateChange: TStateChange;
   fReadNext: TReadNext;
   fOpen: Boolean;
   fFormat: string;
   Procedure BW(Var Buffer; Count: Integer);
   Procedure BR(Var Buffer; Count: Integer);
   Procedure SetClosed; // Private
   Procedure SetRead; // Private
   Procedure SetWrite; // Private
   Procedure SetFilename(Value: TFilename); // Private
   Procedure SetWriteTo(Value: TWriteTo); // Private
   Procedure SetCustomFileID(Value: String); // Private
   Function AddEntry_Private(Value: TValue): Boolean; // Private
   Function CompressBooleans(Value: TCompressedBooleans): Byte; // Private
   Function DeCompressBooleans(Value: Byte): TCompressedBooleans;
    procedure SetFormat(const Value: String); // Private
  public
   Constructor Create(aOwner: TComponent); override;
   Destructor Destroy; override;
   Function AddEntry(B: Byte): Boolean; Overload; // Shared
   Function AddEntry(Str: String): Boolean; Overload; // Shared
   Function AddEntry(Int: Integer): Boolean; Overload; // Shared
   Function AddEntry(Boolean: Boolean): Boolean; Overload; // Shared
   Function AddEntry(CompressedBooleans: TCompressedBooleans): Boolean; Overload; // Shared
   Function CreateNewArchive: Boolean; // Shared
   Function OpenArchive: Boolean; // Shared
   Function Readnext: TValue; // Shared
   Procedure CloseArchive; // Shared
   Procedure SaveArchive; // Shared
   Function EndOfFile: Boolean; // Shared;
   Function VerifyData: Boolean;
   Function Append: Boolean;
   Property IsOpen: Boolean Read fOpen;
  published
   Property Filename: TFilename Read FFilename Write SetFileName;
   Property WriteTo: TWriteTo read fWriteTo Write SetWriteTo default wtFile;
   Property Format: String read fFormat write SetFormat;
   Property CustomFileID: String Read fCustomID Write SetCustomFileID;
   Property OnStateChange: TStateChange Read fStateChange Write fStateChange;
   Property OnReadNext: TReadNext Read fReadNext write fReadNext;
  end;

procedure Register;

Const
 FileID: Array[1 .. 10] of byte = (76, 80, 76, 83, 116, 111, 114, 101, 48, 50); // ID id LPLStore02
 iomClosed = 0; // iom = I/O Mode
 iomRead = 1;
 iomWrite = 2;
 vtByte = 0; // vt := Value Type
 vtInteger = 1;
 vtString = 2;
 vtUnknown = 3;
 vtBoolean = 4;
 vtEndOfFile = 5;
 vtCompressedBooleans = 6;

implementation

procedure Register;
begin
  RegisterComponents('LPL Tools', [TlplStorage]);
end;

Constructor TlplStorage.Create(aOwner: TComponent);
Begin
 Inherited Create(aOwner);
 StorageStream := TMemoryStream.Create;
 IOMode := iomClosed;
End;

Destructor TlplStorage.Destroy;
Begin
 StorageStream.Free;
 Inherited Destroy;
End;


Function TlplStorage.CompressBooleans(Value: TCompressedBooleans): Byte;
Var
 Res: Byte;
Begin
 Res := 0;
 If Value[0] Then Res := Res or ord(#1);
 If Value[1] Then Res := Res or ord(#2);
 If Value[2] Then Res := Res or ord(#4);
 If Value[3] Then Res := Res or ord(#8);
 If Value[4] Then Res := Res or ord(#16);
 If Value[5] Then Res := Res or ord(#32);
 If Value[6] Then Res := Res or ord(#64);
 If Value[7] Then Res := Res or ord(#128);
 Result := Res;
End;

Function TlplStorage.DeCompressBooleans(Value: Byte): TCompressedBooleans;
Var
 Res: TCompressedBooleans;
 I: Integer;
Begin
 For I := 0 to 7 do
  Res[I] := False;
 If (Value And 1 = 1) Then Res[0] := True;
 If (Value And 2 = 2) Then Res[1] := True;
 If (Value And 4 = 4) Then Res[2] := True;
 If (Value And 8 = 8) Then Res[3] := True;
 If (Value And 16 = 16) Then Res[4] := True;
 If (Value And 32 = 32) Then Res[5] := True;
 If (Value And 64 = 64) Then Res[6] := True;
 If (Value And 128 = 128) Then Res[7] := True;
 Result := Res;
End;

Procedure TlplStorage.SetCustomFileID(Value: String);
Begin
 fCustomID := Value;
End;

Procedure TlplStorage.SetFilename(Value: TFilename);
Begin
 FFilename := Value;
End;

Procedure TlplStorage.SetWrite;
Begin
 If fWriteTo = wtFile Then Rewrite(StorageFile, 1);
 If fWriteTo = wtMemory Then StorageStream.Position := 0;
 IOMode := iomWrite;
 If Assigned(fStateChange) Then fStateChange(False, False, True);
 fOpen := True;
End;

Procedure TlplStorage.SetRead;
Begin
 If fWriteTo = wtFile Then Reset(StorageFile, 1);
 If fWriteTo = wtMemory Then StorageStream.Position := 0;
 IOMode := iomRead;
 If Assigned(fStateChange) Then fStateChange(False, True, False);
 fOpen := True;
end;

Procedure TlplStorage.SetClosed;
Begin
 If IOMode = iomClosed Then Exit;
 If fWriteTo = wtFile Then Closefile(StorageFile);
 If fWriteTo = wtMemory Then StorageStream.Position := 0;
 IOMode := iomClosed;
 If Assigned(fStateChange) Then fStateChange(True, False, False);
 fOpen := False;
End;

Procedure TlplStorage.BW(Var Buffer; Count: Integer);
Begin
 If fWriteTo = wtFile Then BlockWrite(StorageFile, Buffer, Count);
 If fWriteTo = wtMemory Then StorageStream.Write(Buffer, Count);
End;

Procedure TlplStorage.BR(Var Buffer; Count: Integer);
Begin
 If fWriteTo = wtFile Then BlockRead(StorageFile, Buffer, Count);
 If fWriteTo = wtMemory Then StorageStream.Read(Buffer, Count);
End;

Procedure TlplStorage.SetWriteTo(Value: TWriteTo);
Begin
 If fWriteTo = wtFile Then begin
  If IOMode = iomWrite Then Begin
   SetClosed;
  End;
  If IOMode = iomRead Then Begin
   SetClosed;
   StorageStream.LoadFromFile(fFilename);
  End;
 End;
 If Value <> fWriteTo Then fWriteTo := Value;
 If fWriteTo = wtMemory Then begin
  StorageStream.Position := 0;
 End;
End;

Function TlplStorage.CreateNewArchive: Boolean;
Var
 Value: TValue;
Begin
 Result := True;
 If IOMode <> iomClosed Then SetClosed; // If read or write close file
 If fWriteTo = wtFile Then begin
  If Fileexists(FFilename) Then Begin
   // Raise not found exception
  end;
  If fFileName = '' Then Begin
   // Post exception - No filename
   Exit;
  End;
  Assignfile(StorageFile, FFilename);
  SetWrite;
  Blockwrite(StorageFile, FileID, Sizeof(FileID)); // Print File ID to file
 End;
 If fWriteTo = wtMemory Then Begin
  SetWrite;
  StorageStream.Write(FileID, Sizeof(FileID)); // Print File ID to stream
 End;
 Value.Valuetype := vtString;
 Value.ValueInString := fCustomID;
 AddEntry_Private(Value);
End;

Procedure TlplStorage.SaveArchive;
Begin
 If fWriteTo = wtMemory Then Begin
  StorageStream.SaveToFile(fFileName);
 End;
 If IOMode <> iomClosed Then SetClosed;
end;

Function TlplStorage.AddEntry_Private(Value: TValue): Boolean;
Var
 B: Byte;
 I: Integer;
 S: String;
Begin
 Result := True;
 If IOMode = iomWrite Then Begin
  Case Value.ValueType of
   vtByte   : Begin
               B := vtByte;
               BW(B, Sizeof(B));
               B := Value.ValueInByte;
               BW(B, Sizeof(B));
              End;
   vtInteger: Begin
               B := vtInteger;
               BW(B, SizeOf(B));
               S := IntToStr(Value.ValueInInteger);
               B := Length(S);
               BW(B, SizeOf(B));
               For I := 1 to Length(S) do Begin
                B := Ord(S[I]);
                BW(B, SizeOf(B));
               End;
              End;
   vtString : Begin
               B := vtString;
               BW(B, SizeOf(B));
               S := Value.ValueInString;
               B := Length(S);
               BW(B, SizeOf(B));
               For I := 1 to Length(S) do Begin
                B := Ord(S[I]);
                BW(B, SizeOf(B));
               End;
              End;
   vtBoolean: Begin
               B := vtBoolean;
               BW(B, Sizeof(B));
               If Value.ValueInBoolean Then B := 0 // True
                else B := 1; // False
               BW(B, Sizeof(B));
              End;
   vtCompressedBooleans: Begin
               B := vtCompressedBooleans;
               BW(B, Sizeof(B));
               B := CompressBooleans(Value.ValueInCompressedBooleans);
               BW(B, Sizeof(B));
              End;
  End;
 End
  else
 Begin
  Case IOMode of
   iomClosed: S := 'Closed';
   iomRead: S := 'Read';
  end;
  Raise ENotWrite.Create('Operation not allowed in ' + S + ' mode');
 End;
End;

Function TlplStorage.OpenArchive: Boolean;
Var
 Filecheck: Array [1 .. 10] of byte;
 I: Integer;
 Value: TValue;
Begin
 result := True;
 If IOMode <> iomClosed Then Begin
  Raise EAlreadyOpen.Create('A Storage file is already open');
 End;
 If WriteTo = wtFile Then begin
  If Fileexists(FFilename) Then begin
   Assignfile(StorageFile, Ffilename);
  End;
 End;
 SetRead;
 BR(FileCheck, SizeOf(Filecheck));
 For I := 1 to sizeof(FileID) do Begin
  If FileCheck[I] <> FileID[I] Then begin
   Raise EIncorrectFileType.Create('This file is NOT a LPL Storage File');
  End;
 End;
 Value := ReadNext;
 If Value.ValueType <> vtString Then begin
  // Raise incorrect structure exception
  Exit;
 End;
 If fCustomID <> Value.ValueInString Then Begin
  SetClosed;
  Result := False;
 End;
end;

Function TlplStorage.Readnext: TValue;
Var
 B, ValueT: Byte;
 S: String;
 Res: TValue;
 I: Integer;
 EndOfFile: boolean;
Begin
 Res.ValueType := vtUnknown;
 If IOMode <> iomRead Then Begin
  Case IOMode of
   iomClosed: S := 'Can not perform a ReadNext Command - No file is open';
   iomWrite: S := 'Can not perform a ReadNext Command when in write mode';
  End;
  Raise ENotRead.Create(S);
 End;
 EndOfFile := True; // Initialize the EndOfFile Variable
 If WriteTo = wtMemory Then EndOfFile := StorageStream.Position = StorageStream.Size;
 If WriteTo = wtFile Then EndOfFile := Eof(StorageFile);
 If Not EndOfFile then begin
  BR(ValueT, Sizeof(ValueT));
  Case ValueT of
   vtByte   : Begin
               Res.ValueType := vtByte;
               BR(Res.ValueInByte, Sizeof(Res.ValueInByte));
               Res.ValueInInteger := Res.ValueInByte;
               Res.ValueInString := IntToStr(Res.ValueInByte);
              End;
   vtInteger: Begin
               Res.ValueType := vtInteger;
               BR(B, SizeOf(B));
               S := '';
               For I := 1 to B do begin
                BR(B, SizeOf(B));
                S := S + Chr(B);
               End;
               Res.ValueInInteger := StrToInt(S);
               Res.ValueInString := S;
              End;
   vtString : Begin
               Res.ValueType := vtString;
               BR(B, SizeOf(B));
               S := '';
               For I := 1 to B do begin
                BR(B, SizeOf(B));
                S := S + Chr(B);
               End;
               Res.ValueInString := S;
              End;
   vtBoolean: Begin
               Res.ValueType := vtBoolean;
               BR(B, Sizeof(B));
               If B = 0 then Res.ValueInBoolean := True
                else Res.ValueInBoolean := False;
              End;
   vtCompressedBooleans: Begin
               Res.ValueType := vtCompressedBooleans;
               BR(B, Sizeof(B));
               Res.ValueInCompressedBooleans := DeCompressBooleans(B);
              End;
  End;
 End
  else
 Begin
  setClosed;
  Res.ValueType := vtEndOfFile;
 End;
 If Assigned(fReadNext) Then fReadNext(Res);
 Result := Res;
End;

Function TlplStorage.AddEntry(B: Byte): Boolean;
Var
 Value: TValue;
Begin
 Value.ValueType := vtByte;
 Value.ValueInByte := B;
 Result := AddEntry_Private(Value);
End;

Function TlplStorage.AddEntry(Int: Integer): Boolean;
Var
 Value: TValue;
Begin
 Value.ValueType := vtInteger;
 Value.ValueInInteger := Int;
 Result := AddEntry_Private(Value);
End;

Function TlplStorage.AddEntry(Str: String): Boolean;
Var
 Value: TValue;
Begin
 Value.ValueType := vtString;
 Value.ValueInString := Str;
 Result := AddEntry_Private(Value);
End;

Function TlplStorage.AddEntry(Boolean: Boolean): Boolean;
Var
 Value: Tvalue;
Begin
 Value.ValueType := vtBoolean;
 Value.ValueInBoolean := Boolean;
 Result := AddEntry_Private(Value);
End;

Function TlplStorage.AddEntry(CompressedBooleans: TCompressedBooleans): Boolean;
Var
 Value: TValue;
Begin
 Value.ValueType := vtCompressedBooleans;
 Value.ValueInCompressedBooleans := CompressedBooleans;
 Result := AddEntry_Private(Value);
End;

Procedure TlplStorage.CloseArchive;
Begin
 SetClosed;
End;

Function TlplStorage.EndOfFile: Boolean;
Begin
 Result := False;
 If IOMode = iomRead Then Begin
  If fWriteTo = wtMemory Then Result := StorageStream.Position = StorageStream.Size;
  If fWriteTo = wtFile Then Result := Eof(StorageFile);
 End;
End;

Function TlplStorage.VerifyData: Boolean;
Var
 AllBlock: String;
 Value: TValue;
 I: Integer;
 EOF: Boolean;

 Function CheckValue(aValue: TValue; cValue: Char): Boolean;
 Begin
// Format "S!?YSIBSC(S)" = String
//                        Unknown
//                        Any
//                        Byte
//                        String
//                        Integer
//                        Boolean
//                        String
//                        CompressedBooleans
  Result := False;
  If aValue.ValueType = vtEndOfFile Then Begin
   Result := True;
   Exit;
  End;
  If cValue = 'S' Then Result := aValue.ValueType = vtString;
  If cValue = 'Y' Then Result := aValue.ValueType = vtByte;
  If cValue = 'I' Then Result := aValue.ValueType = vtInteger;
  If cValue = 'B' Then Result := aValue.ValueType = vtBoolean;
  If cValue = 'C' Then Result := aValue.ValueType = vtCompressedBooleans;
  If cValue = '?' Then Result := True;
  If cValue = '!' Then Result := aValue.ValueType = vtUnknown;
 End;

Begin
 Result := false;
 EOF := true;
 AllBlock := fFormat;
 If WriteTo = wtFile Then Begin
  // Verify Not supported in file mode
  Exit;
 end;
 SetClosed;
 If Not Openarchive Then Begin
  Result := False;
  Exit;
 End;
 Result := true;
 Repeat
  For I := 1 to length(AllBlock) do begin
   If StorageStream.Position = StorageStream.Size - 1 Then begin
    Result := False;
    Exit;
   End;
   If Value.ValueType = vtEndOfFile Then EOF := True
    Else Value := ReadNext;
   If AllBlock[I] = '(' Then Begin
    // Loop Block
   End;
   If Not CheckValue(Value, AllBlock[I]) Then Result := false;
  End;
 Until EOF or Result = false;

End;

procedure TlplStorage.SetFormat(const Value: String);
begin
  fFormat := Value;
  If fFormat = '' Then fFormat := '?';
end;

Function TlplStorage.Append: Boolean;
Begin
 Result := True;
 If fWriteTo = wtFile Then Begin
  Result := False;
  Exit;
 End;
 If fWriteTo = wtMemory Then StorageStream.Position := StorageStream.Size;
 IOMode := iomWrite;
 If Assigned(fStateChange) Then fStateChange(False, False, True);
 fOpen := True;
End;

end.
