lazarus/components/lazutils/ttfile.pas

(*******************************************************************
 *
 *  TTFile.Pas                                                1.3
 *
 *    File I/O Component (specification)
 *
 *  Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg
 *
 *  This file is part of the FreeType project, and may only be used
 *  modified and distributed under the terms of the FreeType project
 *  license, LICENSE.TXT. By continuing to use, modify or distribute
 *  this file you indicate that you have read the license and
 *  understand and accept it fully.
 *
 *  NOTES :
 *
 *  Changes from 1.2 to 1.3 :
 *
 *  - Moved stream into TFreeTypeStream object
 *
 *  Changes from 1.1 to 1.2 :
 *
 *  - Changes the stream operations semantics. See changes.txt
 *
 *  - stream records are now allocated on demand in the heap
 *
 *  - introduced the 'frame cache' to avoid Allocating/Freeing
 *    each frame, even tiny ones..
 *
 *  - support for thread-safety and re-entrancy
 *
 *    ( re-entrancy is there for information only.. )
 *
 *  Changes from 1.0 to 1.1 :
 *
 *  - defined the type TT_Stream for file handles
 *  - renamed ( and cleaned ) the API.
 *
 *  - caching and memory-mapped files use the same API :
 *
 *      TT_Access_Frame to notify
 *
 *  - only the interface was really rewritten. This component still
 *    only supports one opened file at a time.
 *
 ******************************************************************)

Unit TTFile;

interface

{$I TTCONFIG.INC}
{$R-}

uses TTTypes,
     TTError,
     Classes;

type
  { TFreeTypeStream }

  TFreeTypeStream = class
  private
    function GetSize: longint;
  private
    FCurrentFrame : PByte;
    FFrameCursor  : Longint;
    FFrameSize    : LongInt;
    FFrameCache : PByte;

    FName: string;
    FStream: TStream;
    FBase,FStoredSize,FPosit: Longint;
    FOwnedStream: boolean;
    FOpen: boolean;
    FUsed: boolean;
    function GetFilePos: longint;
    function GetFileSize: longint;
    function GetPosition: longint;
    property Size: longint read GetSize;
    procedure Init;
  public
    constructor Create(APathName: string);
    constructor Create(AStream: TStream; AStreamOwner: boolean);
    destructor Destroy; override;
    function Activate: TError;
    function Deactivate: TError;
    function SeekFile(APos: Longint): TError;
    function SkipFile(ADist: Longint): TError;
    function ReadFile( var ABuff; ACount : Int ) : TError;
    function ReadAtFile( APos : Long; var ABuff; ACount : Int ) : TError;

   (*********************************************************************)
   (*                                                                   *)
   (*  Frame Functions                                                  *)
   (*                                                                   *)
   (*********************************************************************)

   (* Access the next aSize bytes *)
   function AccessFrame( aSize : Int ) : TError;

   (* Access the next min(aSize,file_size-file_pos) bytes *)
   function CheckAndAccessFrame( aSize : Int ) : TError;

   (* Forget the previously cached frame *)
   function ForgetFrame :  TError;

   (* The following functions should only be used after a      *)
   (* AccessFrame and before a ForgetFrame                     *)

   (* They do not provide error handling, intentionnaly, and are much faster *)
   (* moreover, they could be converted to MACROS in the C version           *)

   function GET_Byte   : Byte;
   function GET_Char   : ShortInt;
   function GET_Short  : Short;
   function GET_UShort : UShort;
   function GET_Long   : Long;
   function GET_ULong  : ULong;
   function GET_Tag4   : ULong;

    property Open: boolean read FOpen;
    property Name: string read FName;
    property Base: longint read FBase;
    property Position: longint read GetPosition;
    property Used: boolean read FUsed;
  end;

  function  TTFile_Init : TError;
  procedure TTFile_Done;

 (*********************************************************************)
 (*                                                                   *)
 (*  Stream Functions                                                 *)
 (*                                                                   *)
 (*********************************************************************)

 function  TT_Open_Stream( name       : String;
                           var stream : TT_Stream ) : TError;
 (* Open a file and return a stream handle for it               *)
 (* should only be used for a new typeface object's main stream *)
 function  TT_Open_Stream( AStream: TStream; AStreamOwner: boolean;
                           var stream : TT_Stream ) : TError;

 procedure TT_Close_Stream( var stream : TT_Stream );
 (* closes, then discards a stream, when it becomes unuseful *)
 (* should only be used for a typeface object's main stream  *)

 function  TT_Use_Stream( org_stream : TT_Stream;
                          out ftstream: TFreeTypeStream ) : TError;
 (* notices the component that we're going to use the file   *)
 (* opened in 'org_stream', and report errors to the 'error' *)
 (* variable. the 'stream' variable is untouched, except in  *)
 (* re-entrant buids.                                        *)

 (* in re-entrant builds, the original file handle is duplicated *)
 (* to a new stream which reference is passed to the 'stream'    *)
 (* variable.. thus, each thread can have its own file cursor to *)
 (* access the same file concurrently..                          *)

 procedure TT_Flush_Stream( stream : TT_Stream );
 (* closes a stream's font handle. This is useful to save      *)
 (* system resources.                                          *)

 procedure TT_Done_Stream( stream : TT_Stream );
 (* notice the file component that we don't need to perform    *)
 (* file ops on the stream 'stream' anymore..                  *)
 (*                                                            *)
 (* in re-entrant builds, should also discard the stream       *)

 function TT_Stream_Size( stream : TT_Stream ) : longint;

implementation

uses
  SysUtils;

  (* THREADS: TTMutex, *)

const
  frame_cache_size = 2048;
  (* we allocate a single block where we'll place all of our frames *)
  (* instead of allocating an new block on each access. Note that   *)
  (* frames that are bigger than this constant are effectively      *)
  (* allocated in the heap..                                        *)

  function TT_Stream_Size( stream : TT_Stream ) : longint;
  var
    rec : TFreeTypeStream;
  begin
    rec := TFreeTypeStream(stream.z);
    if rec = nil then
      TT_Stream_Size := 0
    else
      TT_Stream_Size := rec.Size;
  end;

(*******************************************************************
 *
 *  Function    :  TTFile_Init
 *
 *  Description :  Init the file component
 *
 ******************************************************************)
 function TTFile_Init : TError;
 begin
   TTFile_Init := Success;
 end;

(*******************************************************************
 *
 *  Function    :  TTFile_Done
 *
 *  Description :  Finalize the file component
 *
 ******************************************************************)
 procedure TTFile_Done;
 begin
   //nothing
 end;

(*******************************************************************
 *
 *  Function    :  TT_Open_Stream
 *
 *  Description :  opens the font file in a new stream
 *
 *  Input  :  stream  : target stream variable
 *            name    : file pathname
 *            error   : the variable that will be used to
 *                      report stream errors
 *
 *  Output :  True on sucess.
 *
 ******************************************************************)
 function TT_Open_Stream( name       : String;
                          var stream : TT_Stream ) : TError;
 var
   ftstream : TFreeTypeStream;

 begin
   TT_Open_Stream := Failure;
   stream.z := nil;
   ftstream := nil;

   try
     ftstream := TFreeTypeStream.Create(name);
     if ftstream.Activate then
       raise exception.Create('Cannot activate');
   except
     on ex: Exception do
     begin
       ftstream.free;
       exit;
     end;
   end;

   stream.z:= ftstream;
   TT_Open_Stream := Success;
 end;

 function TT_Open_Stream(AStream: TStream; AStreamOwner: boolean;
   var stream: TT_Stream): TError;
 var
   ftstream : TFreeTypeStream;

 begin
   TT_Open_Stream := Failure;
   stream.z := nil;
   ftstream := nil;

   try
     ftstream := TFreeTypeStream.Create(AStream,AStreamOwner);
     if ftstream.Activate then
       raise exception.Create('Cannot activate');
   except
     on ex: Exception do
     begin
       ftstream.free;
       exit;
     end;
   end;

   stream.z:= ftstream;
   TT_Open_Stream := Success;
 end;

(*******************************************************************
 *
 *  Function    : TT_Close_Stream
 *
 *  Description : Closes the font file and releases memory buffer
 *
 *  Input  :  None
 *
 *  Output :  True ( always )
 *
 ******************************************************************)
 procedure TT_Close_Stream( var stream : TT_Stream );
 begin
   if stream.z = nil then exit;
   TFreeTypeStream(stream.z).Free;
   stream.z   := nil;
 end;

(*******************************************************************
 *
 *  Function    : TT_Use_Stream
 *
 *  Description : Acquire the file mutex (blocking call)
 *
 *  Input  :  org_stream : original stream to use
 *            stream     : duplicate stream (in re-entrant builds)
 *                         set to 'org_stream' otherwise
 *            error      : error report variable
 *
 *  Output :  True on success. False on failure
 *
 ******************************************************************)
 function  TT_Use_Stream( org_stream : TT_Stream;
                          out ftstream: TFreeTypeStream) : TError;
 begin
   TT_Use_Stream := Failure;

   ftstream:= TFreeTypeStream(org_stream.z);
   if ftstream= nil then exit;
   if ftstream.FUsed then
   begin
     error := TT_Err_File_Error;
     ftstream := nil;
     exit;
   end;
   ftstream.FUsed := true;

   result := ftstream.Activate;
 end;

(*******************************************************************
 *
 *  Function    : TT_Flush_Stream
 *
 *  Description : closes a stream
 *
 *  Input  :  stream : the stream
 *
 *  Output :  True on success. False on failure
 *
 ******************************************************************)
 procedure TT_Flush_Stream( stream : TT_Stream );
 begin
   if stream.z = nil then exit;
   TFreeTypeStream(stream.z).Deactivate;
 end;

(*******************************************************************
 *
 *  Function    : TT_Done_Stream
 *
 *  Description : Release the file mutex on a stream
 *
 *  Input  :  stream : the stream
 *
 *  Output :  Nothing.
 *
 ******************************************************************)
 procedure TT_Done_Stream( stream : TT_Stream );
 {$IF FPC_FULLVERSION<20701}
 var
   p: Pointer;
 {$ENDIF}
 begin
   if stream.z = nil then exit;
   {$IF FPC_FULLVERSION<20701}
   {$HINT workaround for fpc bug 23868 when compiling with -O2}
   p:=stream.z;
   TFreeTypeStream(p).FUsed := false;
   {$ELSE}
   TFreeTypeStream(stream.z).FUsed := false;
   {$ENDIF}
 end;

(*******************************************************************
 *
 *  Function    :  AccessFrame
 *
 *  Description :  Notifies the component that we're going to read
 *                 aSize bytes from the current file position.
 *                 This function should load/cache/map these bytes
 *                 so that they will be addressed by the GET_xxx
 *                 functions easily.
 *
 *  Input  :  aSize   number of bytes to access.
 *
 *  Output :  True on success. False on failure
 *
 *            The function fails is the byte range is not within the
 *            the file, or if there is not enough memory to cache
 *            the bytes properly ( which usually means that aSize is
 *            too big in both cases ).
 *
 *            It will also fail if you make two consecutive calls
 *            to AccessFrame, without a ForgetFrame between
 *            them.
 *
 ******************************************************************)
 function TFreeTypeStream.AccessFrame( aSize : Int ) : TError;
 begin
   result := Failure;

   if FCurrentFrame <> nil then
   begin
     error := TT_Err_Nested_Frame_Access;
     exit;
   end;
   (* We already are accessing one frame *)

   if aSize > frame_cache_size then
     GetMem( FCurrentFrame, aSize )
   else
     FCurrentFrame := FFrameCache;

   if ReadFile( FCurrentFrame^, aSize ) then
   begin
     if aSize > frame_cache_size then
       FreeMem( FCurrentFrame, aSize );

     FCurrentFrame := nil;
     exit;
   end;

   FFrameSize   := aSize;
   FFrameCursor := 0;

   result := Success;
 end;

(*******************************************************************
 *
 *  Function    :  CheckAndAccess_Frame
 *
 *  Description :  Notifies the component that we're going to read
 *                 aSize bytes from the current file position.
 *                 This function should load/cache/map these bytes
 *                 so that they will be addressed by the GET_xxx
 *                 functions easily.
 *
 *  Input  :  aSize   number of bytes to access.
 *
 *  Output :  True on success. False on failure
 *
 *            The function fails is the byte range is not within the
 *            the file, or if there is not enough memory to cache
 *            the bytes properly ( which usually means that aSize is
 *            too big in both cases ).
 *
 *            It will also fail if you make two consecutive calls
 *            to AccessFrame, without a ForgetFrame between
 *            them.
 *
 *
 * NOTE :  The only difference with AccessFrame is that we check
 *         that the frame is within the current file.  We otherwise
 *         truncate it..
 *
 ******************************************************************)
 function TFreeTypeStream.CheckAndAccessFrame( aSize : Int ) : TError;
 var
   readBytes : Longint;
 begin
   readBytes := Size - Position;
   if aSize > readBytes then aSize := readBytes;
   result := AccessFrame( aSize);
 end;

(*******************************************************************
 *
 *  Function    :  ForgetFrame
 *
 *  Description :  Releases a cached frame after reading
 *
 *  Input  :  None
 *
 *  Output :  True on success. False on failure
 *
 ******************************************************************)
 function TFreeTypeStream.ForgetFrame : TError;
 begin
   result := Failure;

   if FCurrentFrame = nil then exit;

   if FFrameSize > frame_cache_size then
     FreeMem( FCurrentFrame, FFrameSize );

   FFrameSize    := 0;
   FCurrentFrame := nil;
   FFrameCursor  := 0;
 end;

(*******************************************************************
 *
 *  Function    :  GET_Byte
 *
 *  Description :  Extracts a byte from the current file frame
 *
 *  Input  :  None
 *
 *  Output :  Extracted Byte.
 *
 *  NOTES : We consider that the programmer is intelligent enough
 *          not to try to get a byte that is out of the frame. Hence,
 *          we provide no bounds check here. (A misbehaving client
 *          could easily page fault using this call).
 *
 ******************************************************************)
 function TFreeTypeStream.GET_Byte : Byte;
 begin
   GET_Byte := FCurrentFrame^[FFrameCursor];
   inc( FFrameCursor );
 end;

(*******************************************************************
 *
 *  Function    :  GET_Char
 *
 *  Description :  Extracts a signed byte from the current file frame
 *
 *  Input  :  None
 *
 *  Output :  Extracted char.
 *
 *  NOTES : We consider that the programmer is intelligent enough
 *          not to try to get a byte that is out of the frame. Hence,
 *          we provide no bounds check here. (A misbehaving client
 *          could easily page fault using this call).
 *
 ******************************************************************)
 function TFreeTypeStream.GET_Char : ShortInt;
 begin
   GET_Char := ShortInt( FCurrentFrame^[FFrameCursor] );
   inc( FFrameCursor );
 end;

(*******************************************************************
 *
 *  Function    :  GET_Short
 *
 *  Description :  Extracts a short from the current file frame
 *
 *  Input  :  None
 *
 *  Output :  Extracted short.
 *
 *  NOTES : We consider that the programmer is intelligent enough
 *          not to try to get a byte that is out of the frame. Hence,
 *          we provide no bounds check here. (A misbehaving client
 *          could easily page fault using this call).
 *
 ******************************************************************)
 function TFreeTypeStream.GET_Short : Short;
 begin
   GET_Short := (Short(FCurrentFrame^[ FFrameCursor ]) shl 8) or
                 Short(FCurrentFrame^[FFrameCursor+1]);
   inc( FFrameCursor, 2 );
 end;

(*******************************************************************
 *
 *  Function    :  GET_UShort
 *
 *  Description :  Extracts an unsigned  short from the frame
 *
 *  Input  :  None
 *
 *  Output :  Extracted ushort.
 *
 *  NOTES : We consider that the programmer is intelligent enough
 *          not to try to get a byte that is out of the frame. Hence,
 *          we provide no bounds check here. (A misbehaving client
 *          could easily page fault using this call).
 *
 ******************************************************************)
 function TFreeTypeStream.GET_UShort : UShort;
 begin
   GET_UShort := (UShort(FCurrentFrame^[ FFrameCursor ]) shl 8) or
                  UShort(FCurrentFrame^[FFrameCursor+1]);
   inc( FFrameCursor, 2 );
 end;

(*******************************************************************
 *
 *  Function    :  GET_Long
 *
 *  Description :  Extracts a long from the frame
 *
 *  Input  :  None
 *
 *  Output :  Extracted long.
 *
 *  NOTES : We consider that the programmer is intelligent enough
 *          not to try to get a byte that is out of the frame. Hence,
 *          we provide no bounds check here. (A misbehaving client
 *          could easily page fault using this call).
 *
 ******************************************************************)
 function TFreeTypeStream.GET_Long : Long;
 begin
   GET_Long := (Long(FCurrentFrame^[ FFrameCursor ]) shl 24) or
               (Long(FCurrentFrame^[FFrameCursor+1]) shl 16) or
               (Long(FCurrentFrame^[FFrameCursor+2]) shl 8 ) or
               (Long(FCurrentFrame^[FFrameCursor+3])       );
   inc( FFrameCursor, 4 );
 end;

(*******************************************************************
 *
 *  Function    :  GET_ULong
 *
 *  Description :  Extracts an unsigned long from the frame
 *
 *  Input  :  None
 *
 *  Output :  Extracted ulong.
 *
 *  NOTES : We consider that the programmer is intelligent enough
 *          not to try to get a byte that is out of the frame. Hence,
 *          we provide no bounds check here. (A misbehaving client
 *          could easily page fault using this call).
 *
 ******************************************************************)
 function TFreeTypeStream.GET_ULong : ULong;
 begin
   GET_ULong := (ULong(FCurrentFrame^[ FFrameCursor ]) shl 24) or
                (ULong(FCurrentFrame^[FFrameCursor+1]) shl 16) or
                (ULong(FCurrentFrame^[FFrameCursor+2]) shl 8 ) or
                (ULong(FCurrentFrame^[FFrameCursor+3])       );
   inc( FFrameCursor, 4 );
 end;

(*******************************************************************
 *
 *  Function    :  GET_Tag4
 *
 *  Description :  Extracts a Tag from the frame
 *
 *  Input  :  None
 *
 *  Output :  Extracted 4 byte Tag.
 *
 *  NOTES : We consider that the programmer is intelligent enough
 *          not to try to get a byte that is out of the frame. Hence,
 *          we provide no bounds check here. (A misbehaving client
 *          could easily page fault using this call).
 *
 ******************************************************************)
 function TFreeTypeStream.GET_Tag4 : ULong;
 var
   C : array[0..3] of Byte;
 begin
   move ( FCurrentFrame^[FFrameCursor], c{%H-}, 4 );
   inc( FFrameCursor, 4 );

   GET_Tag4 := ULong(C);
 end;

{ TFreeTypeStream }

function TFreeTypeStream.GetFileSize: longint;
begin
 if FStream = nil then
    result := 0
  else
    result := FStream.Size;
end;

function TFreeTypeStream.GetPosition: longint;
begin
  if Open then result := GetFilePos else result := FPosit;
end;

procedure TFreeTypeStream.Init;
begin
  FOpen:= false;
  FStream := nil;
  FBase:= 0;
  FStoredSize:= -1;
  FPosit:= 0;

  (* empty frame *)
  FCurrentFrame := nil;
  FFrameCursor  := 0;
  FFrameSize    := 0;

  (* create frame cache *)
  GetMem( FFrameCache, frame_cache_size );
end;

constructor TFreeTypeStream.Create(APathName: string);
begin
  if APathName = '' then
    raise exception.Create('Empty path name');
  Init;
  FName:= APathName;
end;

constructor TFreeTypeStream.Create(AStream: TStream; AStreamOwner: boolean);
begin
  Init;
  FStream:= AStream;
  FOwnedStream := AStreamOwner;
end;

destructor TFreeTypeStream.Destroy;
begin
  Deactivate;
  if FOwnedStream then FreeAndNil(FStream);

  if FCurrentFrame <> nil then ForgetFrame;
  if FFrameCache <> nil then
    FreeMem( FFrameCache, frame_cache_size );
  FFrameCache := nil;

  inherited Destroy;
end;

 function TFreeTypeStream.Activate: TError;
 begin
   result := Success;
   if Open then exit;

   //in case stream provided by user
   if (FName = '') and (FStream <> nil) then
   begin
     FOpen := True;
     exit;
   end;

   try
     FStream := TFileStream.Create(FName, fmOpenRead or fmShareDenyWrite);
     FOpen := True;
     FBase := 0;
     try
       if FStoredSize = -1 then FStoredSize := FStream.Size;
       if FPosit <> 0 then FStream.Position:= FPosit;
     except
       on ex:exception do
       begin
         FreeAndNil(FStream);
         FOpen := False;
         error := TT_Err_File_Error;
         result := Failure;
         exit;
       end;
     end;
   except
     on ex:exception do
     begin
       error := TT_Err_Could_Not_Open_File;
       result := Failure;
       exit;
     end;
   end;
 end;

 function TFreeTypeStream.Deactivate: TError;
 begin
   result := Success;
   if not Open then exit;

   if FName = '' then //in case stream provided by user
   begin
     FOpen := false;
     exit;
   end;

   FPosit := FStream.Position;
   FreeAndNil(FStream);
   FOpen := false;
 end;

 function TFreeTypeStream.SeekFile(APos: Longint): TError;
 begin
   if FStream = nil then
   begin
     error := TT_Err_File_Error;
     result := Failure;
     exit;
   end;
   try
     FStream.Position := APos;
   except
     on ex: exception do
     begin
       error        := TT_Err_Invalid_File_Offset;
       result := Failure;
       exit;
     end;
   end;
   result := Success;
 end;

 function TFreeTypeStream.SkipFile(ADist: Longint): TError;
 begin
   result := SeekFile(Position+ADist);
 end;

 function TFreeTypeStream.ReadFile(var ABuff; ACount: Int): TError;
 begin
   result := Failure;
   if FStream = nil then
   begin
     error := TT_Err_Invalid_File_Read;
     exit;
   end;
   try
     if FStream.Read(ABuff,ACount) <> ACount then
     begin
       error := TT_Err_Invalid_File_Read;
       exit;
     end;
     result := success;
   except
     on ex: Exception do
     begin
       error := TT_Err_Invalid_File_Read;
       exit;
     end;
   end;
 end;

function TFreeTypeStream.ReadAtFile(APos: Long; var ABuff; ACount: Int): TError;
begin
  result := Failure;

  if SeekFile( APos ) or
     ReadFile( ABuff, ACount ) then exit;

  result := Success;
end;

function TFreeTypeStream.GetSize: longint;
begin
  if Open then
    result := GetFileSize
  else
    result := FStoredSize;
end;

function TFreeTypeStream.GetFilePos: longint;
begin
  if FStream= nil then
    result := 0
  else
    result := FStream.Position;
end;

end.