{*************************************************************}
{                                                             }
{       Borland Delphi Visual Component Library               }
{       InterBase Express core components                     }
{                                                             }
{       Copyright (c) 1998-2003 Borland Software Corporation  }
{                                                             }
{    InterBase Express is based in part on the product        }
{    Free IB Components, written by Gregory H. Deatz for      }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.          }
{    Free IB Components is used under license.                }
{                                                             }
{    Additional code created by Jeff Overcash and used        }
{    with permission.                                         }
{*************************************************************}

unit Borland.Vcl.IBBlob;

{$A8,R-}

interface

uses
  SysUtils, Classes, IBHeader, IBExternals, DB, IB, IBDatabase, IBIntf;

const
  DefaultBlobSegmentSize = 16 * 1024; 

type
  { TIBBlobStream }
  TIBBlobStream = class(TStream)
  private
    FBase: TIBBase;
    FBlobID: IntPtr;
    FBlobMaxSegmentSize,
    FBlobNumSegments,
    FBlobSize: Long;
    FBlobType: Short;  { 0 = segmented, 1 = streamed }
    FBuffer: IntPtr;
    FBlobInitialized: Boolean;
    FHandle: IntPtr;
    FMode: TBlobStreamMode;
    FModified: Boolean;
    FPosition: Long;
    FGDSLibrary : IGDSLibrary;
  protected
    procedure CloseBlob;
    procedure CreateBlob;
    procedure EnsureBlobInitialized;
    procedure GetBlobInfo;
    function GetDatabase: TIBDatabase;
    function GetDBHandle: PISC_DB_HANDLE;
    function GetTransaction: TIBTransaction;
    function GetTRHandle: PISC_TR_HANDLE;
    procedure OpenBlob;
    procedure SetBlobID(Value: TISC_QUAD);
    function GetBlobID : TISC_QUAD;
    procedure SetDatabase(Value: TIBDatabase);
    procedure SetMode(Value: TBlobStreamMode);
    procedure SetTransaction(Value: TIBTransaction);
    procedure SetSize(NewSize: Int64); override;
  public
    constructor Create;
    destructor Destroy; override;
    function Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
    procedure Cancel;
    procedure CheckReadable;
    procedure CheckWritable;
    procedure FinalizeBlob;
    procedure LoadFromFile(Filename: string);
    procedure LoadFromStream(Stream: TStream);
    function Read(var Buffer: array of Byte; Offset, Count: Longint): Longint; override;
    procedure SaveToFile(Filename: string);
    procedure SaveToStream(Stream: TStream);
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
    procedure Truncate;
    function Write(const Buffer: array of Byte; Offset, Count: Longint): Longint; override;
    property Handle: IntPtr read FHandle;
    property BlobID: IntPtr read FBlobID;
    property DBBlobID: TISC_QUAD read GetBlobID write SetBlobID;
    property BlobMaxSegmentSize: Long read FBlobMaxSegmentSize;
    property BlobNumSegments: Long read FBlobNumSegments;
    property BlobSize: Long read FBlobSize;
    property BlobType: Short read FBlobType;
    property Database: TIBDatabase read GetDatabase write SetDatabase;
    property DBHandle: TISC_DB_HANDLE read GetDBHandle;
    property Mode: TBlobStreamMode read FMode write SetMode;
    property Modified: Boolean read FModified;
    property Transaction: TIBTransaction read GetTransaction write SetTransaction;
    property TRHandle: PISC_TR_HANDLE read GetTRHandle;
  end;

  procedure GetBlobInfo(hBlobHandle: IntPtr; var NumSegments, MaxSegmentSize,
                       TotalSize: Long; var BlobType: Short);
  procedure ReadBlob(hBlobHandle: IntPtr; Buffer: IntPtr; BlobSize: Long);
  procedure WriteBlob(hBlobHandle: IntPtr; Buffer: IntPtr; BlobSize: Long);

implementation

uses IBCustomDataSet, System.Runtime.InteropServices, IBErrorCodes;

procedure GetBlobInfo(hBlobHandle: IntPtr; var NumSegments, MaxSegmentSize,
                      TotalSize: Long; var BlobType: Short);
var
  items: IntPtr;
  results: IntPtr;
  i, item_length: Integer;
  item, resultsSize : Integer;

  function GetValue(Buff : IntPtr; OffSet : Integer; Length : Integer) : Integer;
  begin
    case Length of
      1 :  Result := Marshal.ReadByte(Buff, OffSet);
      2 :  Result := Marshal.ReadInt16(Buff, OffSet);
      4 :  Result := Marshal.ReadInt32(Buff, OffSet);
      else
        Result := Marshal.ReadInt64(Buff, OffSet);
    end;
  end;

begin
  ResultsSize := 100 * SizeOf(Char);
  Results := Marshal.AllocHGlobal(ResultsSize);
  items := Marshal.AllocHGlobal(4 * SizeOf(Char));
  try
    Marshal.WriteByte(items, 0, isc_info_blob_num_segments);
    Marshal.WriteByte(items, 1, isc_info_blob_max_segment);
    Marshal.WriteByte(items, 2, isc_info_blob_total_length);
    Marshal.WriteByte(items, 3, isc_info_blob_type);
    if GetGDSLibrary.isc_blob_info(StatusVector, hBlobHandle, 4, items, ResultsSize,
                      results) > 0 then
      IBDatabaseError;
    i := 0;
    while (i < ResultsSize) and (Marshal.ReadByte(results, i) <> isc_info_end) do
    begin
      item := Integer(Marshal.ReadByte(results, i));
      Inc(i);
      item_length := Marshal.ReadByte(results, i);
      Inc(i, 2);
      case item of
        isc_info_blob_num_segments:
          NumSegments := GetValue(results, i, item_length);
        isc_info_blob_max_segment:
          MaxSegmentSize := GetValue(results, i, item_length);
        isc_info_blob_total_length:
          TotalSize := GetValue(results, i, item_length);
        isc_info_blob_type:
          BlobType := GetValue(results, i, item_length);
      end;
      Inc(i, item_length);
    end;
  finally
    Marshal.FreeHGlobal(Results);
    Marshal.FreeHGlobal(items);
  end;
end;

procedure ReadBlob(hBlobHandle: IntPtr; Buffer: IntPtr; BlobSize: Long);
var
  CurPos: Long;
  SegLen: UShort;
  LocalBuffer, PBytesRead : IntPtr;
begin
  CurPos := 0;
  LocalBuffer := Buffer;
  PBytesRead := Marshal.AllocHGlobal(Sizeof(UShort));
  try
    Marshal.StructureToPtr(TObject(Buffer), LocalBuffer, false);
    SegLen := UShort(DefaultBlobSegmentSize);
    while (CurPos < BlobSize) do
    begin
      if (CurPos + SegLen > BlobSize) then
        SegLen := BlobSize - CurPos;
      if not ((GetGDSLibrary.isc_get_segment(StatusVector, hBlobHandle, PBytesRead, SegLen,
                               LocalBuffer) = 0) or
              (Marshal.ReadInt32(StatusVector, 1) = isc_segment)) then
        IBDatabaseError;
      LocalBuffer := IntPtr(Integer(LocalBuffer) + Marshal.ReadInt16(PBytesRead));
      Inc(CurPos, Marshal.ReadInt16(PBytesRead));
      Marshal.WriteInt16(PBytesRead, 0);
    end;
  finally
    Marshal.FreeHGlobal(PBytesRead);
  end;
end;

procedure WriteBlob(hBlobHandle: IntPtr; Buffer: IntPtr; BlobSize: Long);
var
  CurPos, SegLen: Long;
  LocalBuffer : IntPtr;
begin
  CurPos := 0;
  SegLen := DefaultBlobSegmentSize;
  LocalBuffer := Buffer;

  while (CurPos < BlobSize) do
  begin
    if (CurPos + SegLen > BlobSize) then
      SegLen := BlobSize - CurPos;
    if GetGDSLibrary.isc_put_segment(StatusVector, hBlobHandle, SegLen,
         LocalBuffer) > 0 then
      IBDatabaseError;
    Inc(CurPos, SegLen);
    LocalBuffer := IntPtr(Integer(LocalBuffer) + CurPos);
  end;
end;


{ TIBBlobStream }
constructor TIBBlobStream.Create;
begin
  inherited Create;
  FBase := TIBBase.Create(Self);
  FBuffer := nil;
  FBlobSize := 0;
  FGDSLibrary := GetGDSLibrary;
  FBlobID := Marshal.AllocHGlobal(Marshal.SizeOf(TypeOf(TISC_QUAD)));
  Marshal.WriteInt32(FBlobID, 0);
  Marshal.WriteInt32(FBlobID, 4, 0);
  FHandle := Marshal.AllocHGlobal(Marshal.SizeOf(TypeOf(TISC_BLOB_HANDLE)));
  Marshal.WriteIntPtr(FHandle, nil);
end;

destructor TIBBlobStream.Destroy;
begin
  if (Marshal.ReadIntPtr(FHandle) <> nil) and
     (Call(FGDSLibrary.isc_close_blob(StatusVector, FHandle), False) > 0) then
    IBDatabaseError;
  FBase.Free;
  SetSize(0);
  FGDSLibrary := nil;
  Marshal.FreeHGlobal(FBlobID);
  Marshal.FreeHGlobal(FHandle);
  inherited Destroy;
end;

function TIBBlobStream.Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
begin
  result := 0;
  if Transaction <> nil then
    result := Transaction.Call(ErrCode, RaiseError)
  else
    if RaiseError and (ErrCode > 0) then
      IBDatabaseError;
end;

procedure TIBBlobStream.CheckReadable;
begin
  if FMode = bmWrite then
    IBError(ibxeBlobCannotBeRead, [nil]);
end;

procedure TIBBlobStream.CheckWritable;
begin
  if FMode = bmRead then
    IBError(ibxeBlobCannotBeWritten, [nil]);
end;

procedure TIBBlobStream.CloseBlob;
begin
  FinalizeBlob;
  if (Marshal.ReadIntPtr(FHandle) <> nil) and
     (Call(FGDSLibrary.isc_close_blob(StatusVector, FHandle), False) > 0) then
    IBDatabaseError;
end;

procedure TIBBlobStream.CreateBlob;
begin
  CheckWritable;
  Marshal.WriteInt32(FBlobID, 0);
  Marshal.WriteInt32(FBlobID, 4, 0);
  Truncate;
end;

procedure TIBBlobStream.EnsureBlobInitialized;
begin
  if not FBlobInitialized then
    case FMode of
      bmWrite:
        CreateBlob;
      bmReadWrite: begin
        if (DBBlobID.gds_quad_high = 0) and
           (DBBlobID.gds_quad_low = 0) then
          CreateBlob
        else
          OpenBlob;
      end;
      else
        OpenBlob;
    end;
  FBlobInitialized := True;
end;

procedure TIBBlobStream.FinalizeBlob;
begin
  if (not FBlobInitialized) or (FMode = bmRead) then
    exit;
  { need to start writing to a blob, create one }
  Call(FGDSLibrary.isc_create_blob2(StatusVector, DBHandle, TRHandle, FHandle, FBlobID,
                       0, nil), True);
  Borland.Vcl.IBBlob.WriteBlob(FHandle, FBuffer, FBlobSize);
  Call(FGDSLibrary.isc_close_blob(StatusVector, FHandle), True);
  FModified := False;
end;

procedure TIBBlobStream.GetBlobInfo;
var
  iBlobSize: Long;
begin
  Borland.Vcl.IBBlob.GetBlobInfo(FHandle, FBlobNumSegments, FBlobMaxSegmentSize,
    iBlobSize, FBlobType);
  SetSize(iBlobSize);
end;

function TIBBlobStream.GetDatabase: TIBDatabase;
begin
  result := FBase.Database;
end;

function TIBBlobStream.GetDBHandle: PISC_DB_HANDLE;
begin
  result := FBase.DBHandle;
end;

function TIBBlobStream.GetTransaction: TIBTransaction;
begin
  result := FBase.Transaction;
end;

function TIBBlobStream.GetTRHandle: PISC_TR_HANDLE;
begin
  result := FBase.TRHandle;
end;

procedure TIBBlobStream.LoadFromFile(Filename: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TIBBlobStream.LoadFromStream(Stream: TStream);
var
  b : TBytes;
begin
  CheckWritable;
  EnsureBlobInitialized;
  Stream.Position := 0;
  SetSize(Stream.Size);
  if FBlobSize <> 0 then
  begin
    SetLength(b, FBlobSize);
    Stream.ReadBuffer(b, FBlobSize);
    Marshal.Copy(b, 0, FBuffer, FBlobSize);
  end;
  FModified := True;
end;

procedure TIBBlobStream.OpenBlob;
begin
  CheckReadable;
  Call(FGDSLibrary.isc_open_blob2(StatusVector, DBHandle, TRHandle, FHandle,
                     FBlobID, 0, nil), True);
  try
    GetBlobInfo;
    SetSize(FBlobSize);
    Borland.Vcl.IBBlob.ReadBlob(FHandle, FBuffer, FBlobSize);
  except
    Call(FGDSLibrary.isc_close_blob(StatusVector, FHandle), False);
    raise;
  end;
  Call(FGDSLibrary.isc_close_blob(StatusVector, FHandle), True);
end;

function TIBBlobStream.Read(var Buffer: array of Byte; Offset, Count: Longint): Longint;
var
  i : Integer;
begin
  CheckReadable;
  EnsureBlobInitialized;
  if (Count <= 0) then
  begin
    result := 0;
    exit;
  end;
  if (FPosition + Count > FBlobSize) then
    result := FBlobSize - FPosition
  else
    result := Count;
                    
  for i := 0 to Result - 1 do
    Buffer[i] := Marshal.ReadByte(FBuffer, FPosition + i);
  Inc(FPosition, Result);
end;

procedure TIBBlobStream.SaveToFile(Filename: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TIBBlobStream.SaveToStream(Stream: TStream);
begin
  CheckReadable;
  EnsureBlobInitialized;
  if FBlobSize <> 0 then
  begin
    Seek(0, soBeginning);
    Stream.WriteBuffer(BytesOf(Marshal.PtrToStringAnsi(FBuffer)), FBlobSize);
    Stream.Size := FBlobSize;
  end;
end;

function TIBBlobStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
  EnsureBlobInitialized;
  case Origin of
    soBeginning     : FPosition := Offset;
    soCurrent	: Inc(FPosition, Offset);
    soEnd           : FPosition := FBlobSize + Offset;
  end;
  result := FPosition;
end;

procedure TIBBlobStream.SetBlobID(Value: TISC_QUAD);
begin
  Marshal.WriteInt32(FBlobID, Value.gds_quad_high);
  Marshal.WriteInt32(FBlobID, 4, Value.gds_quad_low);
  FBlobInitialized := False;
end;

function TIBBlobStream.GetBlobID : TISC_QUAD;
begin
  Result := TISC_QUAD(Marshal.PtrToStructure(FBlobID, TypeOf(TISC_QUAD)));
end;

procedure TIBBlobStream.SetDatabase(Value: TIBDatabase);
begin
  FBase.Database := Value;
  FBlobInitialized := False;
end;

procedure TIBBlobStream.SetMode(Value: TBlobStreamMode);
begin
  FMode := Value;
  FBlobInitialized := False;
end;

procedure TIBBlobStream.SetSize(NewSize: Int64);
begin
  if (NewSize <> FBlobSize) then
  begin
    If FBuffer = nil then
      FBuffer := Marshal.AllocHGlobal(NewSize)
    else
      FBuffer := Marshal.ReAllocHGlobal(FBuffer, IntPtr(NewSize));
    FBlobSize := NewSize;
    if NewSize = 0 then
    begin
      Marshal.FreeHGlobal(FBuffer);
      FBuffer := nil;
    end;
  end;
end;

procedure TIBBlobStream.SetTransaction(Value: TIBTransaction);
begin
  FBase.Transaction := Value;
  FBlobInitialized := False;
end;

procedure TIBBlobStream.Truncate;
begin
  SetSize(0);
end;

function TIBBlobStream.Write(const Buffer: array of Byte; Offset,
         Count: Longint): Longint;
begin
  CheckWritable;
  EnsureBlobInitialized;
  result := Count;
  if Count <= 0 then
    exit;
  if (FPosition + Count > FBlobSize) then
    SetSize(FPosition + Count);
  Marshal.Copy(TBytes(Buffer), 0, IntPtr(Integer(FBuffer) + FPosition), Count);
  Inc(FPosition, Count);
  FModified := True;
end;

procedure TIBBlobStream.Cancel;
begin
  if (not FBlobInitialized) or (FMode = bmRead) then
    exit;
  if FModified then
    OpenBlob;
  FModified := False;
end;

end.
