cpstream.pas

生物信息学中的遗传数据分析的delphi源码。

{$I CPDIR.INC}


unit cpstream;

{
   Interface to buffered stream


   3/1/91
      When stream is opened (without error checking)
      the first character is read. Calling
      routines can either access the current
      character (GetChar) or scan for the next
      character (ReadChar).

      Lexical scanners should include a
      call to GetChar in the Init procedure
      to access this first character.


   Note:
      EOF marker is #0


   3/14/91   Position markers Row and Col added.
   4/3/91    Tabs expanded


   26 Sep 1991 (note for earlier modifications)
               Tabs treated as fixed at eight space intervals
               and so are expanded to the next position.

}

interface

uses
   {$IFDEF WINDOWS}
   {$IFDEF DEBUG}
   WinCrt,
   {$ENDIF}
   {$IFDEF BWCC}    { use Borland-style dialogs }
   BWCC,
   {$IFDEF VER10}   { TPW 1.0 }
   WObjectB,
   StdDlgsB,
   {$ELSE}
   WObjects,
   StdDlgs,
   {$ENDIF} {VER10}
   {$ELSE}
   WObjects,
   {$ENDIF}
   WinTypes,
   WinProcs,
   Strings;
   {$ELSE}
   Crt,
   Objects;
   {$ENDIF}

const
   CR  = #13;     { carriage return }
   LF  = #10;     { line feed }
   EOF = #0;      { end of stream }
   TAB = #9;      { tab }

   TABSPACES = 8; { expand tab to TABSPACES spaces }


type
   FILEPOSPTR = ^FILEPOSREC;
      {Pointer to [FILEPOSREC]}
   FILEPOSREC = record
      {Position in input stream}
      Row:integer; {Current line}
      Col:integer; {Current position in line} 
      LastPosn:longint; {Last position in stream}
      BytesRead:longint; {Bytes read so far}
      end;

   STREAMOBJ_PTR = ^STREAMOBJ;
      {Pointer to [STREAMOBJ] }
   STREAMOBJ = object (TBufStream)
      {Encapsulate input stream}
      constructor Init (name:string);
         {Call <\i TBufStream.Init> and <\i TBufStream.Read> to initialise stream
          and read first character. Initialise file position record.}
      procedure MarkLastPosn;
         {Store current position in stream} 
      function ReadChar:Char;
         {Call <\i TBufStream.Read> to read a character from the stream, then update
          line and position line information.}
      function GetChar:Char;
         {Return the current character}
      function Empty:Boolean;
         {True if the current character is [[EOF:cpstream.EOF]]}
      function FilePosn:FILEPOSPTR;
         {Return a pointer to the file position information.}
      destructor Done; virtual;
         {Call <\i TBufStream.Done>}
      procedure ReadLine;
         {Eat rest of line including [[LF:cpstream.LF]] and [[CR:cpstream.CR]],
         so that the current character is the first character of the next line.}
      function Posn:string;
         {Return a string displaying the file position }
      private
      CurChar : char;
      F       : FILEPOSREC;
      end;


      CPSStream = object(TBufStream)
         procedure Error (Code, Info: integer);virtual;
         end;

implementation


   constructor STREAMOBJ.Init (name:string);
   { Open stream for input, and get first character }
   {$IFDEF WINDOWS}
   var
      FName: array[0..79] of Char;
   {$ENDIF}
   begin
      {$IFDEF WINDOWS}
      StrPCopy (FName, name);
      TBufStream.Init (FName, stOpenRead, 512);
      {$ELSE}
      TBufStream.Init (name, stOpenRead, 512);
      {$ENDIF}
      TBufStream.Read (CurChar, 1);
      F.Row := 1;
      F.Col := 1;
      F.LastPosn  := 0;
      F.BytesRead := 0;
   end;

   {$IFDEF debug}
   procedure ShowPlace (R, C:integer);
   var
      X,Y: integer;
   begin
      X := WhereX;
      Y := WhereY;
      GotoXY (40,25);
      write (output, '(',R,', ',C,')');
      GotoXY (X,Y);
   end;

   procedure CRTWriteCh (ch:char);
   begin
      write (output, ch);
   end;

   procedure CRTWriteln (ch:char);
   begin
      writeln (output, '***', ord(ch):5);
   end;
   {$ENDIF}

   function STREAMOBJ.Posn:string;
   { Row, Col in file }
   var
      s1, s2: string;
   begin
      Str (F.Row, s1);
      Str (F.Col, s2);
      Posn := '(' + s1 + ',' + s2 + ')';
   end;

   function STREAMOBJ.FilePosn:FILEPOSPTR;
   begin
      FilePosn := @F;
   end;

   procedure STREAMOBJ.MarkLastPosn;
   begin
      F.LastPosn := F.BytesRead;
   end;


   function STREAMOBJ.ReadChar:Char;
   { Read another character, update posn in file }
   begin
      TBufStream.Read (CurChar, 1);
      if (Status<> stOK) then begin       { If trying to read beyond end simulate a EOF }
         ReadChar := #0;
         Exit;
         end;
      Inc (F.BytesRead);
      ReadChar := CurChar;
      case CurChar of
          LF: Inc (F.Row);                 { line feed }
          CR: F.Col := 0;                  { carriage return }
         TAB: begin
                 { Assume that tabs are fixed at eight space intervals.
                   Then, we need to pad text till next tab space.
                   Note that F.Col points to the posn of the character
                   before the tab. If cols are numbered 0..n then
                   spaces to pad = }

                F.Col := F.Col + (TabSpaces - (F.Col mod TABSPACES));
              end;
         else Inc (F.Col);   { character in current row }
         end;
   end;

   function STREAMOBJ.GetChar:Char;
   { Return current character }
   begin
      GetChar := CurChar;
   end;

   function STREAMOBJ.Empty:Boolean;
   begin
      Empty := (CurChar = EOF);
   end;

   procedure STREAMOBJ.ReadLine;
   begin
      while (CurChar <> #10) and (CurChar <> #0) do begin
         TBufStream.Read (CurChar, 1);
         end;
      if (CurChar <> #0) then
         TBufStream.Read (CurChar, 1);
   end;

   destructor STREAMOBJ.Done;
   begin
      TBufStream.Done;
   end;


   procedure CPSStream.Error (Code, Info: integer);
   var
      Buf : array[0..80] of char;
      x : longint;
   begin
      TBufStream.Error (Code, Info);
      x := Info;
      case Code of
         stError: 
            wvsprintf (buf, 'Stream error: Access error (DOS code=%d)', x);
         stInitError:
            wvsprintf (buf, 'Stream error: Cannot initialize stream (DOS code=%d)', x);
         stReadError:
            wvsprintf (buf, 'Stream error: Read beyond end of stream (DOS code=%d)', x);
         stWriteError:
            wvsprintf (buf, 'Stream error: Cannot expand stream (DOS code=%d)', x);
         stGetError:
            wvsprintf (buf, 'Stream error: Get of unregistered object type (ObjType=%d)', x);
         stPutError:
            wvsprintf (buf, 'Stream error: Put of unregistered object type (VMTLink=%d)', x);
         end;
      BWCCMessageBox (0, buf, 'COMPONENT', mb_IconInformation);
   end;

end.