home *** CD-ROM | disk | FTP | other *** search
/ Delphi Anthology / aDELPHI.iso / Runimage / Delphi50 / Source / Vcl / ibblob.pas < prev    next >
Pascal/Delphi Source File  |  1999-08-11  |  12KB  |  432 lines
  1. {********************************************************}
  2. {                                                        }
  3. {       Borland Delphi Visual Component Library          }
  4. {       InterBase Express core components                }
  5. {                                                        }
  6. {       Copyright (c) 1998-1999 Inprise Corporation      }
  7. {                                                        }
  8. {    InterBase Express is based in part on the product   }
  9. {    Free IB Components, written by Gregory H. Deatz for }
  10. {    Hoagland, Longo, Moran, Dunst & Doukas Company.     }
  11. {    Free IB Components is used under license.           }
  12. {                                                        }
  13. {********************************************************}
  14.  
  15. unit IBBlob;
  16.  
  17. interface
  18.  
  19. uses
  20.   Windows, SysUtils, Classes, Forms, IBHeader, IBErrorCodes, IBExternals,
  21.   DB, IB, IBDatabase, IBUtils;
  22.  
  23. const
  24.   DefaultBlobSegmentSize = 16 * 1024; 
  25.  
  26. type
  27.   { TIBBlobStream }
  28.   TIBBlobStream = class(TStream)
  29.   private
  30.     FBase: TIBBase;
  31.     FBlobID: TISC_QUAD;
  32.     FBlobMaxSegmentSize,
  33.     FBlobNumSegments,
  34.     FBlobSize: Long;
  35.     FBlobType: Short;  { 0 = segmented, 1 = streamed }
  36.     FBuffer: PChar;
  37.     FBlobInitialized: Boolean;
  38.     FHandle: TISC_BLOB_HANDLE;
  39.     FMode: TBlobStreamMode;
  40.     FModified: Boolean;
  41.     FPosition: Long;
  42.   protected
  43.     procedure CloseBlob;
  44.     procedure CreateBlob;
  45.     procedure EnsureBlobInitialized;
  46.     procedure GetBlobInfo;
  47.     function GetDatabase: TIBDatabase;
  48.     function GetDBHandle: PISC_DB_HANDLE;
  49.     function GetTransaction: TIBTransaction;
  50.     function GetTRHandle: PISC_TR_HANDLE;
  51.     procedure OpenBlob;
  52.     procedure SetBlobID(Value: TISC_QUAD);
  53.     procedure SetDatabase(Value: TIBDatabase);
  54.     procedure SetMode(Value: TBlobStreamMode);
  55.     procedure SetTransaction(Value: TIBTransaction);
  56.   public
  57.     constructor Create;
  58.     destructor Destroy; override;
  59.     function Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
  60.     procedure CheckReadable;
  61.     procedure CheckWritable;
  62.     procedure Finalize;
  63.     procedure LoadFromFile(Filename: string);
  64.     procedure LoadFromStream(Stream: TStream);
  65.     function Read(var Buffer; Count: Longint): Longint; override;
  66.     procedure SaveToFile(Filename: string);
  67.     procedure SaveToStream(Stream: TStream);
  68.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  69.     procedure SetSize(NewSize: Long); override;
  70.     procedure Truncate;
  71.     function Write(const Buffer; Count: Longint): Longint; override;
  72.     property Handle: TISC_BLOB_HANDLE read FHandle;
  73.     property BlobID: TISC_QUAD read FBlobID write SetBlobID;
  74.     property BlobMaxSegmentSize: Long read FBlobMaxSegmentSize;
  75.     property BlobNumSegments: Long read FBlobNumSegments;
  76.     property BlobSize: Long read FBlobSize;
  77.     property BlobType: Short read FBlobType;
  78.     property Database: TIBDatabase read GetDatabase write SetDatabase;
  79.     property DBHandle: PISC_DB_HANDLE read GetDBHandle;
  80.     property Mode: TBlobStreamMode read FMode write SetMode;
  81.     property Modified: Boolean read FModified;
  82.     property Transaction: TIBTransaction read GetTransaction write SetTransaction;
  83.     property TRHandle: PISC_TR_HANDLE read GetTRHandle;
  84.   end;
  85.  
  86.   procedure GetBlobInfo(hBlobHandle: PISC_BLOB_HANDLE; var NumSegments, MaxSegmentSize,
  87.                        TotalSize: Long; var BlobType: Short);
  88.   procedure ReadBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Long);
  89.   procedure WriteBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Long);
  90.  
  91. implementation
  92.  
  93. uses IBIntf, IBCustomDataSet;
  94.  
  95. procedure GetBlobInfo(hBlobHandle: PISC_BLOB_HANDLE; var NumSegments, MaxSegmentSize,
  96.                       TotalSize: Long; var BlobType: Short);
  97. var
  98.   items: array[0..3] of Char;
  99.   results: array[0..99] of Char;
  100.   i, item_length: Integer;
  101.   item: Integer;
  102. begin
  103.   items[0] := Char(isc_info_blob_num_segments);
  104.   items[1] := Char(isc_info_blob_max_segment);
  105.   items[2] := Char(isc_info_blob_total_length);
  106.   items[3] := Char(isc_info_blob_type);
  107.  
  108.   if isc_blob_info(StatusVector, hBlobHandle, 4, @items[0], SizeOf(results),
  109.                     @results[0]) > 0 then
  110.     IBDatabaseError;
  111.  
  112.   i := 0;
  113.   while (i < SizeOf(results)) and (results[i] <> Char(isc_info_end)) do
  114.   begin
  115.     item := Integer(results[i]); Inc(i);
  116.     item_length := isc_vax_integer(@results[i], 2); Inc(i, 2);
  117.     case item of
  118.       isc_info_blob_num_segments:
  119.         NumSegments := isc_vax_integer(@results[i], item_length);
  120.       isc_info_blob_max_segment:
  121.         MaxSegmentSize := isc_vax_integer(@results[i], item_length);
  122.       isc_info_blob_total_length:
  123.         TotalSize := isc_vax_integer(@results[i], item_length);
  124.       isc_info_blob_type:
  125.         BlobType := isc_vax_integer(@results[i], item_length);
  126.     end;
  127.     Inc(i, item_length);
  128.   end;
  129. end;
  130.  
  131. procedure ReadBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Long);
  132. var
  133.   CurPos: Long;
  134.   BytesRead, SegLen: UShort;
  135.   LocalBuffer: PChar;
  136. begin
  137.   CurPos := 0;
  138.   LocalBuffer := Buffer;
  139.   SegLen := UShort(DefaultBlobSegmentSize);
  140.   while (CurPos < BlobSize) do
  141.   begin
  142.     if (CurPos + SegLen > BlobSize) then
  143.       SegLen := BlobSize - CurPos;
  144.     if not ((isc_get_segment(StatusVector, hBlobHandle, @BytesRead, SegLen,
  145.                              LocalBuffer) = 0) or
  146.             (StatusVectorArray[1] = isc_segment)) then
  147.       IBDatabaseError;
  148.     Inc(LocalBuffer, BytesRead);
  149.     Inc(CurPos, BytesRead);
  150.     BytesRead := 0;
  151.   end;
  152. end;
  153.  
  154. procedure WriteBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar;
  155.   BlobSize: Long);
  156. var
  157.   CurPos, SegLen: Long;
  158. begin
  159.   CurPos := 0;
  160.   SegLen := DefaultBlobSegmentSize;
  161.   while (CurPos < BlobSize) do
  162.   begin
  163.     if (CurPos + SegLen > BlobSize) then
  164.       SegLen := BlobSize - CurPos;
  165.     if isc_put_segment(StatusVector, hBlobHandle, SegLen,
  166.          PChar(@Buffer[CurPos])) > 0 then
  167.       IBDatabaseError;
  168.     Inc(CurPos, SegLen);
  169.   end;
  170. end;
  171.  
  172.  
  173. { TIBBlobStream }
  174. constructor TIBBlobStream.Create;
  175. begin
  176.   inherited Create;
  177.   FBase := TIBBase.Create(Self);
  178.   FBuffer := nil;
  179.   FBlobSize := 0;
  180. end;
  181.  
  182. destructor TIBBlobStream.Destroy;
  183. begin
  184.   if (FHandle <> nil) and
  185.      (Call(isc_close_blob(StatusVector, @FHandle), False) > 0) then
  186.     IBDataBaseError;
  187.   FBase.Free;
  188.   SetSize(0);
  189.   inherited Destroy;
  190. end;
  191.  
  192. function TIBBlobStream.Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
  193. begin
  194.   result := 0;
  195.   if Transaction <> nil then
  196.     result := Transaction.Call(ErrCode, RaiseError)
  197.   else if RaiseError and (ErrCode > 0) then
  198.     IBDataBaseError;
  199. end;
  200.  
  201. procedure TIBBlobStream.CheckReadable;
  202. begin
  203.   if FMode = bmWrite then IBError(ibxeBlobCannotBeRead, [nil]);
  204. end;
  205.  
  206. procedure TIBBlobStream.CheckWritable;
  207. begin
  208.   if FMode = bmRead then IBError(ibxeBlobCannotBeWritten, [nil]);
  209. end;
  210.  
  211. procedure TIBBlobStream.CloseBlob;
  212. begin
  213.   Finalize;
  214.   if (FHandle <> nil) and
  215.      (Call(isc_close_blob(StatusVector, @FHandle), False) > 0) then
  216.     IBDataBaseError;
  217. end;
  218.  
  219. procedure TIBBlobStream.CreateBlob;
  220. begin
  221.   CheckWritable;
  222.   FBlobID.gds_quad_high := 0;
  223.   FBlobID.gds_quad_low := 0;
  224.   Truncate;
  225. end;
  226.  
  227. procedure TIBBlobStream.EnsureBlobInitialized;
  228. begin
  229.   if not FBlobInitialized then
  230.     case FMode of
  231.       bmWrite:
  232.         CreateBlob;
  233.       bmReadWrite: begin
  234.         if (FBlobID.gds_quad_high = 0) and
  235.            (FBlobID.gds_quad_low = 0) then
  236.           CreateBlob
  237.         else
  238.           OpenBlob;
  239.       end;
  240.       else
  241.         OpenBlob;
  242.     end;
  243.   FBlobInitialized := True;
  244. end;
  245.  
  246. procedure TIBBlobStream.Finalize;
  247. begin
  248.   if (not FBlobInitialized) or (FMode = bmRead) or (not FModified) then
  249.     exit;
  250.   { need to start writing to a blob, create one }
  251.   Call(isc_create_blob2(StatusVector, DBHandle, TRHandle, @FHandle, @FBlobID,
  252.                        0, nil), True);
  253.   IBBlob.WriteBlob(@FHandle, FBuffer, FBlobSize);
  254.   Call(isc_close_blob(StatusVector, @FHandle), True);
  255.   FModified := False;
  256. end;
  257.  
  258. procedure TIBBlobStream.GetBlobInfo;
  259. var
  260.   iBlobSize: Long;
  261. begin
  262.   IBBlob.GetBlobInfo(@FHandle, FBlobNumSegments, FBlobMaxSegmentSize,
  263.     iBlobSize, FBlobType);
  264.   SetSize(iBlobSize);
  265. end;
  266.  
  267. function TIBBlobStream.GetDatabase: TIBDatabase;
  268. begin
  269.   result := FBase.Database;
  270. end;
  271.  
  272. function TIBBlobStream.GetDBHandle: PISC_DB_HANDLE;
  273. begin
  274.   result := FBase.DBHandle;
  275. end;
  276.  
  277. function TIBBlobStream.GetTransaction: TIBTransaction;
  278. begin
  279.   result := FBase.Transaction;
  280. end;
  281.  
  282. function TIBBlobStream.GetTRHandle: PISC_TR_HANDLE;
  283. begin
  284.   result := FBase.TRHandle;
  285. end;
  286.  
  287. procedure TIBBlobStream.LoadFromFile(Filename: string);
  288. var
  289.   Stream: TStream;
  290. begin
  291.   Stream := TFileStream.Create(FileName, fmOpenRead);
  292.   try
  293.     LoadFromStream(Stream);
  294.   finally
  295.     Stream.Free;
  296.   end;
  297. end;
  298.  
  299. procedure TIBBlobStream.LoadFromStream(Stream: TStream);
  300. begin
  301.   CheckWritable;
  302.   EnsureBlobInitialized;
  303.   Stream.Position := 0;
  304.   SetSize(Stream.Size);
  305.   if FBlobSize <> 0 then
  306.     Stream.ReadBuffer(FBuffer^, FBlobSize);
  307.   FModified := True;
  308. end;
  309.  
  310. procedure TIBBlobStream.OpenBlob;
  311. begin
  312.   CheckReadable;
  313.   Call(isc_open_blob2(StatusVector, DBHandle, TRHandle, @FHandle,
  314.                      @FBlobID, 0, nil), True);
  315.   try
  316.     GetBlobInfo;
  317.     SetSize(FBlobSize);
  318.     IBBlob.ReadBlob(@FHandle, FBuffer, FBlobSize);
  319.   except
  320.     Call(isc_close_blob(StatusVector, @FHandle), False);
  321.     raise;
  322.   end;
  323.   Call(isc_close_blob(StatusVector, @FHandle), True);
  324. end;
  325.  
  326. function TIBBlobStream.Read(var Buffer; Count: Longint): Longint;
  327. begin
  328.   CheckReadable;
  329.   EnsureBlobInitialized;
  330.   if (Count <= 0) then
  331.   begin
  332.     result := 0;
  333.     exit;
  334.   end;
  335.   if (FPosition + Count > FBlobSize) then
  336.     result := FBlobSize - FPosition
  337.   else
  338.     result := Count;
  339.   Move(FBuffer[FPosition], Buffer, result);
  340.   Inc(FPosition, Result);
  341. end;
  342.  
  343. procedure TIBBlobStream.SaveToFile(Filename: string);
  344. var
  345.   Stream: TStream;
  346. begin
  347.   Stream := TFileStream.Create(FileName, fmCreate);
  348.   try
  349.     SaveToStream(Stream);
  350.   finally
  351.     Stream.Free;
  352.   end;
  353. end;
  354.  
  355. procedure TIBBlobStream.SaveToStream(Stream: TStream);
  356. begin
  357.   CheckReadable;
  358.   EnsureBlobInitialized;
  359.   if FBlobSize <> 0 then
  360.   begin
  361.     Seek(0, soFromBeginning);
  362.     Stream.WriteBuffer(FBuffer^, FBlobSize);
  363.   end;
  364. end;
  365.  
  366. function TIBBlobStream.Seek(Offset: Longint; Origin: Word): Longint;
  367. begin
  368.   EnsureBlobInitialized;
  369.   case Origin of
  370.     soFromBeginning     : FPosition := Offset;
  371.     soFromCurrent    : Inc(FPosition, Offset);
  372.     soFromEnd           : FPosition := FBlobSize + Offset;
  373.   end;
  374.   result := FPosition;
  375. end;
  376.  
  377. procedure TIBBlobStream.SetBlobID(Value: TISC_QUAD);
  378. begin
  379.   System.Move(Value, FBlobID, SizeOf(TISC_QUAD));
  380.   FBlobInitialized := False;
  381. end;
  382.  
  383. procedure TIBBlobStream.SetDatabase(Value: TIBDatabase);
  384. begin
  385.   FBase.Database := Value;
  386.   FBlobInitialized := False;
  387. end;
  388.  
  389. procedure TIBBlobStream.SetMode(Value: TBlobStreamMode);
  390. begin
  391.   FMode := Value;
  392.   FBlobInitialized := False;
  393. end;
  394.  
  395. procedure TIBBlobStream.SetSize(NewSize: Long);
  396. begin
  397.   if (NewSize <> FBlobSize) then
  398.   begin
  399.     ReallocMem(FBuffer, NewSize);
  400.     FBlobSize := NewSize;
  401.     if NewSize = 0 then
  402.       FBuffer := nil;
  403.   end;
  404. end;
  405.  
  406. procedure TIBBlobStream.SetTransaction(Value: TIBTransaction);
  407. begin
  408.   FBase.Transaction := Value;
  409.   FBlobInitialized := False;
  410. end;
  411.  
  412. procedure TIBBlobStream.Truncate;
  413. begin
  414.   SetSize(0);
  415. end;
  416.  
  417. function TIBBlobStream.Write(const Buffer; Count: Longint): Longint;
  418. begin
  419.   CheckWritable;
  420.   EnsureBlobInitialized;
  421.   result := Count;
  422.   if Count <= 0 then
  423.     exit;
  424.   if (FPosition + Count > FBlobSize) then
  425.     SetSize(FPosition + Count);
  426.   Move(Buffer, FBuffer[FPosition], Count);
  427.   Inc(FPosition, Count);
  428.   FModified := True;
  429. end;
  430.  
  431. end.
  432.