cpwbuf.pas

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

{*******************************************************************
*                                                                  *
*  COMPONENT for MS DOS and Windows source code.                   *
*                                                                  *
*  (c) 1992, Roderic D. M. Page                                    *
*                                                                  *
*  Language: Turbo Pascal (Pascal with object-oriented extensions) *
*  Compiler: Turbo Pascal 6.0 (MS DOS)                             *
*            Turbo Pascal for Windows 1.0 (WINDOWS)                *
*                                                                  *
*  Notes:    Program interface is currently Windows specific.      *
*                                                                  *
*******************************************************************}


{$I CPDIR.INC}

unit cpwbuf;

{
  General text buffer routines, designed for use by:

  1. Lexical scanner

  2. All text output routines.


  The buffers are declared as global variables.

  <\b To do>

  Error checking for memory allocation error.


  <\b History>

  28 Aug 1991 Code cleaned up, display window updated by calling <\i InvalidateRect>.

   7 Nov 1991 Update modified to call <\i UpDateWindow> and no longer scrolls to end of display buffer.

   5 Feb 1992 Text file device driver added to simplify text output. Conditional directive DEVICE
              added throughout code. May eventually want to remove that code.

  15 Apr 1992 Leiden bugs #0 and #12 were a bit obscure.

              #0 fixed by correcting code in function LogInOut.
              Code added to truncate text buffer.

              #12 caused by integer variable Start being incremented
              beyond MAXINT, causing Start to be negative. This
              value was then passed to NextLineBreak, causing a
              range check error when used as an index to Buffer.
              Fixed by decrementing [[TEXTBUFFERSIZE]] to 32766.

  21 Apr 1992 Text display in log window improved by indenting text
              from left margin of window by one character.

   3 Jun 1992 Trying to fix problem with editor. Now each line in
              buffer is added separately, otherwise if memory
              limit is exceeded no text is entered.

              <\i TabbedTextOut> now used instead of <\i TextOut>.
              This allows tabs to be used in the output which makes
              it easy to copy and paste data into, say, Exzel which
              requires tab-delimited text.

  30 Jul 1992 Supports TPW 1.5.

  15 Jan 1993 Comments in WSHELP format.
}


interface

uses
   {$IFDEF WINDOWS}
   WinDos,
   WinTypes,
   WinProcs,
   {$IFDEF BWCC}    { use Borland-style dialogs }
   BWCC,
   {$IFDEF VER10}   { TPW 1.0 }
   WObjectB,
   StdDlgsB,
   {$ELSE}
   WObjects,
   StdDlgs,
   {$ENDIF} {VER10}
   {$ELSE}
   WObjects,        { use standard dialogs }
   StdDlgs,
   {$ENDIF} {BWCC}
   Strings,
   cpwprint,
   {$ENDIF} {WINDOWS}
   cpvars,
   cputil,
   cperror,
   cpwvars;

const
   TEXTBUFFERSIZE =  32766; { 32K-1 bytes in text buffer }
   LINEBUFFERSIZE =    254; { 254 characters per line maximum }
   LineBreak      =    #10; { LF }
   MSDOSLineBreak = #13#10; { CR/LF }
   DefaultLogFile = 'LOG.OUT'; { Name of default log file }
   TABSPACES      = 8; { Number of spaces to expand a tab }

type
    ABUFFER = array[0..LINEBUFFERSIZE] of char; { A text line buffer }


    BUFFEROBJ = object
       { Line buffer object }
       Buffer : ABUFFER;
       { The buffer }
       function Full:Boolean;
       { True if buffer is full }
       function Return_Buffer:string;
       {}
       function Count:integer;
       { Return the number of bytes in the buffer }
       function FirstChar:char;
       { Return the first character innthe buffer }
       procedure Clear;
       { Clear the buffer }
       procedure AppendNull;
       { Append the null character (#0) to the contents of the buffer }
       procedure LineBreak;
       { Append the line break character (#10) to the contents of the buffer }
       procedure NullLineString (var S:ABUFFER);
       {}
       procedure AppendChar (ch: char);
       {}
       procedure AppendString (s: string);
       {}
       procedure AppendInteger (i:longint);
       {}
       procedure AppendSInteger (i:longint; Spaces:integer);
       {}
       procedure AppendSReal (r:real; n,m:integer);
       {}
       procedure InsertChar (ch:char; There:integer);
       {}
       procedure InsertInteger (i, there:integer);
       {}
       procedure InsertString (s:string; there:integer);
       {}
       procedure InsertLine (Symbol:char; Start, Stop:integer);
       {}
       procedure Show;
       {}
       procedure NewLine;
       {}
       procedure Title (s:string);
       {}
       procedure AValue (ATitle:string; value:longint);
       {}

       {$IFDEF DEVICE}
       procedure Display;
       {}
       {$ENDIF}

       function GetBufferText:PChar;
       {}

       procedure ExpandTab;
       {}
       private
       BufPtr : 0..LINEBUFFERSIZE;
       function ToString:string;
       end;


   CharBuffer = array[0..TEXTBUFFERSIZE] of Char;
   { The display buffer }
   CharBufPtr = ^CharBuffer;
   { Pointer to the display buffer }

   TEXTBUFFER = object
   {The object that encapsulates the display buffer

   The text buffer is a circular buffer of TEXTBUFFERSIZE bytes implemented
   as a zero-based array of char. Three pointers are used to keep track of
   the text. A head, tail, and buffer pointer.

   Each string is stored as a CR/LF terminated string of characters. The
   null characters are stripped off when the strings are stored. A count
   is keep of the number of lines in the buffer at any one time. This is
   necessary as each line is stored contiguously in the buffer, e.g.

   \\<bmc buf1.bmp\\>

   Initally the buffer looks like this:

   \\<bmc buf2.bmp\\>

   The buffer can store up to [TEXTBUFFERSIZE] characters. If more characters
   are entered then it starts to overwrite itself:

   After it becomes:

   \\<bmc buf3.bmp\\>


   To write text to the display buffer the user simply writes to the file
   [NewLog] using the standard procedures <\b write> and <\b writeln>. The
   text file device driver associated with the display buffer calls
   the [InsertPChar] method to insert the text.

   The buffer is associated with a window to display the text. This window's
   display is updated by the [Update] method. 
}
      szProgName    : array[0..128] of char;
      { Name of the program implementing the buffer }

      Strip         : Boolean; { flag for stripping OEM characters from buffer }
      Echo          : Boolean; { flag for echoing contents to log file }
      {$IFDEF WINDOWS}
      constructor Init (LogWindow :PWindow; szUserProgName:PChar);
      { Allocates memory for display buffer, associates display buffer with window
        <\bLogWindow>, sets [szProgName] to <\b szUserProgName>, and sets up text file
        device }
      {$ELSE}
      constructor Init;
      {}
      {$ENDIF}
      destructor Done;
      { Closes text file device, log file (if open) and frees memory allocated
      to display buffer }

      function BytesInBuffer:word;
      { Return the number of bytes in the buffer }

      {$IFNDEF DEVICE}
      procedure InsertATitle (ATitle: string);
      {}
      procedure InsertNewLine;
      {}
      procedure Insert;
      {}
      procedure InsertLineBuffer (var L:BUFFEROBJ);
      {}
      {$ENDIF}

      procedure AppendLogFile (FileName:string);
      { Opens the file <\b FileName> as log file for appending ouput } 
      procedure CloseLogFile;
      { Close log file }
      procedure InsertPChar (s:PChar);
      { Inserts null terminated string <\b s> in buffer }
      procedure InsertText (var S:ABUFFER);
      { Inserts line buffer <\b S> in buffer }
      procedure OpenLogFile (FileName: String);
      { Opens file <\b FileName> as log file }
      procedure SetEcho (Flag: Boolean);
      { Sets [Echo] flag }
      procedure SetStrip (Flag:Boolean);
      { Sets [Strip] flag }
      procedure Show (var f:text);
      { Write contents of buffer to text file <\b f> }
      {$IFDEF WINDOWS}
      function CanClear:Boolean;
      { Returns true if buffer has been saved to disk, or if
        user does not want to save buffer contents. }
      function Edit (EditorHWnd: HWnd; OEMStrip:Boolean):Boolean;
      { Copy the contents of the display buffer to the edit control whose
        handle is <\b EditorHWnd>, converting OEM characters to ANSI if
        <\b OEMStrip> is true. Returns true if successful. }
      procedure Print (hdcPrn:HDC);
      { Print the contents of the display buffer to the device content <\b hdcPrn> }
      procedure WShowPage (DC:HDC; Top, Bottom: integer);
      { Paint text lines <\b Top> to <\b Bottom> to the device context <\b DC>}
      procedure Update;
         { Calls the Windows API procedure UpdateWindow to repaint the
           associated display window, then adjusts the window's scroller }       
      procedure WClear;
      { Clears the display buffer by reseting all the pointers then
        repaints the display window. }
      {$ENDIF}
      procedure StartStopWatch;
      { Get the current time }
      procedure ShowElapsedTime;
      { Display the time elapsed since [StartStopWatch] was called }
      private
      { The buffer }
      Buffer        : CharBufPtr;           { The buffer }
      StartTime,
      ElapsedTime   : TimeRec;              { Clock }
      IsModified    : Boolean;              { Flag for modification }
      ALine         : BUFFEROBJ;            { A single line }
      BufPtr,
      Head,
      Tail          : 0..TEXTBUFFERSIZE;    { Ptrs }
      LCount,
      yChar,
      Lines,                                { Count of lines in buffer }
      LinesPerPage  : integer;
      LogFile       : text;                 { log file }
      Overwriting   : Boolean;              { Flag for overwriting }
      {$IFDEF WINDOWS}
      DisplayWindow : PWindow;              { Ptr to display window }
      {$ENDIF}
      function LinesBetween (L, R:integer):integer;
      function NextLineBreak (From:integer):integer;
      function OverFlow (Length:integer):integer;
      procedure ShowLines (var f:text; Start, Stop:integer);
      {$IFDEF WINDOWS}
      procedure PrintLines (hdcPrn:HDC; Start, Stop:integer);
      {$ENDIF}
      {$IFDEF DEBUG}
      procedure Dump (var f:text);
      {$ENDIF}
      end;


var
   Buffer        : BUFFEROBJ;
      { A line buffer } 
   DeviceBuffer  : array[0..LINEBUFFERSIZE] of char;
      { The buffer used by the text file driver associated with the display buffer }
   DisplayBuffer : TextBuffer;
      { The display buffer }

{$IFDEF DEVICE}
   NewLog        : text;   { Text file associated with display buffer }
{$ENDIF}

implementation

{**********************}
{                      }
{  Utilities           }
{                      }
{**********************}

function Max (A, B:integer):integer;
begin
   if (A > B) then
      Max := A
   else Max := B;
end;

{$IFDEF MSDOS}
{ Return the number of chars in a zero-based array. }
function StrLen (var S: ABUFFER):integer;
var
  i:integer;
begin
   i := 0;
   while (S[i] <> #0) do
      Inc (i);
   StrLen := Pred (i);
end;

{ Remove OEM graphics chars from s }
procedure StripOEM (var s: ABUFFER);
var
   i, l: integer;
begin
   l := StrLen (s);
   for i := 0 to l do
      case s[i] of
         ' '..'z':
            begin end;
         HBAR, D_HBAR:
            s[i] := '-';
         TEE, D_TEE, VBAR, D_VBAR, SIB, D_SIB:
            s[i] := '|';
         RT, D_RT, BOT, D_BOT:
            s[i] := '+';
         DUPLICATE:
            s[i] := '#';
         else begin end;
         end;
end;
{$ENDIF}

{ Ensure Line is always smaller than LINEBUFFERSIZE. }
procedure TruncateLine (Line:PChar);
begin
   if (StrLen (Line) >= LINEBUFFERSIZE - 2) then begin
      Line[LINEBUFFERSIZE-2] := #13;
      Line[LINEBUFFERSIZE-1] := #10;
      Line[LINEBUFFERSIZE]   := #0;
      end;
end;


{$IFDEF DEVICE}

{**********************}
{                      }
{  Text file driver    }
{                      }
{**********************}

{-----------------------------LogInOut-------------------------------------}

{ Copy text to display buffer }
function LogInOut (var F:TTextRec):integer;far;
var
   p: array[0..LINEBUFFERSIZE] of char; { local buffer }
begin
   if (F.BufPos <> 0) then begin
      { Copy device text buffer to display buffer }
      StrLCopy (p, PChar(F.BufPtr), F.BufPos);
      TruncateLine (p);
      DisplayBuffer.InsertPChar (p);
      F.BufPos := 0;
      end;
  LogInOut := 0;
end;

{-----------------------------LogClose-------------------------------------}

function LogClose (var F:TTextRec):integer;far;
begin
   LogClose := 0;
end;

{-----------------------------LogOpen--------------------------------------}

function LogOpen (var f:TTextRec):integer;far;
begin
   F.Mode      := fmOutput;  { device is output only }
   F.InOutFunc := @LogInOut;
   F.FlushFunc := @LogInOut;
   F.CloseFunc := @LogClose;
   LogOpen     := 0;
end;

{-----------------------------AssignLog------------------------------------}

{ Assign the display buffer's text file driver to f }
procedure AssignLog (var f:text);
begin
   with TTextRec(f) do begin
      Handle     := $FFFF;
      Mode       := fmClosed;
      BufSize    := SizeOf(DeviceBuffer);
      BufPtr     := @DeviceBuffer;
      OpenFunc   := @LogOpen;
      Name[0]    := #0;
      end;
end;

{$ENDIF}


{**********************}
{                      }
{  BUFFEROBJ object    }
{                      }
{**********************}


{ Return ptr to buffer }
function BUFFEROBJ.GetBufferText:PChar;
begin
   LineBreak;
   AppendNull;
   GetBufferText := @Buffer;
end;


{-----------------------------TITLE----------------------------------------}

   procedure BUFFEROBJ.Clear;
   begin
      FillChar (Buffer, Succ (LINEBUFFERSIZE), ' ');
      BufPtr    := 0;
   end;


   { Pad buffer with spaces til next tab stop }
   procedure BufferObj.ExpandTab;
   var
      i, j : integer;
   begin
      i := BufPtr + (TABSPACES - (BufPtr mod TABSPACES));
      for j := BufPtr to i do
         Buffer[j] := ' ';
      BufPtr := i;
   end;


   function BUFFEROBJ.Full:Boolean;
   begin
      Full := (BufPtr = LINEBUFFERSIZE);
   end;

   function BUFFEROBJ.ToString:string;
   var
      s: string[LINEBUFFERSIZE + 1];
   begin
      {$IFDEF MSDOS}                      { Return a Turbo Pascal string }
      Move (Buffer, s[1], Succ (BufPtr));
      s[0] := chr(BufPtr);
      {$ENDIF}
      {$IFDEF WINDOWS}                    { Return a "#0" terminated string }
      AppendNull;
      s := StrPas(Buffer);
      {$ENDIF}
      ToString := s;
   end;

   { Return a #13/#10/#0 terminated string }
   procedure BUFFEROBJ.NullLineString (var S: ABUFFER);
   begin
      Move (Buffer, S[0], BufPtr);
      S[BufPtr]   := #13;
      S[BufPtr+1] := #10;
      S[BufPtr+2] := #0;
   end;

   function BUFFEROBJ.Return_Buffer:string;
   begin
      Return_Buffer := ToString;
   end;

   function BUFFEROBJ.Count:integer;
   begin
      Count := BufPtr;
   end;

   function BUFFEROBJ.FirstChar:char;
   begin