Power-Programmierung/CD1.mdf/pascal/library/dos/io/textio/textio.pas

Pascal/Delphi Source File | 1989-01-29 | 9.8 KB | 388 lines

unit TextIO;

{  useful text i/o features with turbo pascal:

     1. large text buffers for speedier handling when needed
     2. complete seek function for text files
     3. write formatted output to a string variable
     4. read contents of a string variable as formatted input
     5. backup to the previous line of a file (if possible)

   language:  turbo pascal macintosh "(*MAC-  -MAC*)" comments
         or:  turbo pascal 4.0 ibm.  "(*IBM-  -IBM*)" comments

   by d.g.gilbert
   dogStar software
   po box 302, bloomington, in 47402
   compuserve  71450,1570

   Translated to a unit by Mike Babulic,  (Jan.25,1989)
                           3827 Charleswood Dr. N.W.
                           Calgary, Alberta, CANADA
                           T2L 2C7
                           compuserve: 72307,314

        NOTE:  1) This unit has been created and tested on MS/DOS only.
        -----     Porting to the Macintosh will involve some modification,
                  especially for new additions like "BackLn".

               2) Obviously if you do "interesting" things in your programs
                  you can expect some side-effects the authors couldn't
                  possibly forsee. Be careful!


   MODIFICATION LOG
   ----------------

     88/01/25 - Turned demo program into a unit. (Babulic)

     88/01/27 - BackLn procedure added. (Babulic)
}


interface

{$R-}   { Turn off range checking       }
{$I-}   { Turn off I/O error checking   }

(*IBM-*)
   USES  DOS;

   TYPE
        chars   = PACKED ARRAY [0..maxint] OF char;
        bufferPtr = ^chars;
        procPtr   = pointer;

        tpFileRec = RECORD            {turbo pascal ibm text file record}
          handle   : word;
          mode     : word;
          fBufSize : word;
          private  : word;
          fBufPos  : word;
          fBufEnd  : word;
          fBuffer  : bufferPtr;
          openFunc : procptr;
          inOutFunc: procptr;
          flushFunc: procptr;
          closeFunc: procptr;
          userdata : PACKED ARRAY[1..16] OF byte;
          name     : PACKED ARRAY [0..79] OF char;
          tbuffer  : PACKED ARRAY [0..127] OF char; { default buffer}
          END;
(*-IBM*)
(*MAC-
   USES  memTypes, quickDraw, osIntf, toolIntf;

   TYPE
      chars   = PACKED ARRAY [0..maxint] OF char;
      bufferPtr = ^chars;
      pointer = ^integer;

      tpFileRec   = RECORD            {turbo pascal mac file record }
          fInpFlag: boolean;
          fOutFlag: boolean;
          fRefNum : integer;
          fVrefNum: integer;
          fBufSize: integer;
          fBufPos : integer;
          fBufEnd : integer;
          fBuffer : bufferPtr;
          fInOutProc: procPtr;
          END;
-MAC*)

CONST
      forOutput = true; forInput = false;



FUNCTION openText( VAR f: text;
         fname : STRING;
         output: boolean;  {true if want a rewrite }
         bufsize: integer
         ): boolean;     { true if opened successfully }

PROCEDURE closeText( VAR f: text);

FUNCTION PosText(VAR f:text):LongInt;


TYPE seekType = (seek_set, seek_cur, seek_end);

PROCEDURE seekText( VAR f: text; offset: longInt; seekFrom : seektype);
  { seek for textfiles }


procedure BackLn(var f:Text);


PROCEDURE openStrIO( VAR f: text; VAR s: STRING; out: boolean);
  { assign file input/output to string. }

PROCEDURE closeStrIO( VAR f: text; VAR s: STRING);
  { close stringiO: get length }


{==========================================================================}

implementation


(*IBM-*)
FUNCTION msDosSeek( fh:integer; index:longint; fromwhere:seekType):LongInt;
{ move file pointer to byte index (hiIndx,lowIndx), respective to fromWhere }
TYPE  long = record lo,hi:word end;
VAR  reg : registers;
     l   : long;
BEGIN WITH REG DO BEGIN
  ah:= $42; { move f^ }
  al:= ord(fromwhere);
  cx:= long(index).hi; {hiindex}
  dx:= long(index).lo; {lowIndex}
  bx := fh;
  msdos(reg);
  IF 0 = (reg.flags AND $01) THEN
    msdosSeek:= 0
  ELSE BEGIN
    l.hi:= dx;
    l.lo:= ax;
    msdosSeek := longint(l);
  END;
END  END; { msDosSeek }
(*-IBM*)

{--------------------------------------------------------------------------}

FUNCTION openText( VAR f: text;
         fname : STRING;
         output: boolean;  {true if want a rewrite }
         bufsize: integer
         ): boolean;     { true if opened successfully }

VAR  abuf: pointer;
     err: integer;
BEGIN

(*IBM-*)
    assign( f, fname);
   { now change buf to the size we want}
    WITH tpfilerec(f) DO BEGIN
      getmem( abuf, bufsize);
      fBuffer:= abuf;
      fBufSize:= bufsize;
      END;
    IF output THEN rewrite( f) ELSE reset(f);
    err:= ioresult;
    IF err <> 0 THEN dispose(abuf); {forget it}
    openText:= err = 0;
(*-IBM*)
(*MAC-
    IF output THEN rewrite( f, fname, bufsize)
    ELSE reset( f, fname, bufsize);
    openText:= ioresult = 0;
-MAC*)
END; {openText}

PROCEDURE closeText( VAR f: text);
VAR  abuf: pointer;
BEGIN
(*IBM-*)
       abuf:= tpfilerec(f).fBuffer;
       close(f);
       dispose(abuf);
(*-IBM*)
END;


FUNCTION PosText(VAR f:text):LongInt;
  TYPE  long = record lo,hi:word end;
  VAR  reg : registers;
       p   : longint;
       l   : long  ABSOLUTE p;
  BEGIN
    WITH REG DO BEGIN
      ah:= $42; { move f^ }
      al:= ord(seek_cur);
      cx:= 0;
      dx:= 0;
      bx := tpfilerec(f).handle;
      msdos(reg);
      l.hi:= dx;
      l.lo:= ax;
    END;
    WITH tpfilerec(f) DO BEGIN
      IF mode=fmOutput THEN
        PosText := p + fBufPos
      ELSE
        PosText := p - fBufEnd + fBufPos;
    END
  END;


(*IBM-*)
CONST strFileName = '$%#temp.tmp';
CONST needStrFile: boolean = true; {1st time open tempFile }
VAR   strFile    : text; {.ibm -- save file i/o information for strIO}
(*-IBM*)

PROCEDURE openStrIO( VAR f: text; VAR s: STRING; out: boolean);
{ assign file input/output to string. }
BEGIN

(*IBM-*)
   IF needStrFile THEN BEGIN
     assign(strFile, strFileName);
     rewrite(strFile); {<< need this to fill in valid turbo proc ptrs}
     tpfilerec(f):= tpfilerec(strFile);
     close(strFile); erase(strFile);
     tpfilerec(strfile):= tpfilerec(f);
     needStrFile:= false;
     END;
   tpfilerec(f):= tpfilerec(strFile);
   WITH tpFileRec(f) DO BEGIN
     IF out THEN mode:= fmOutput ELSE mode:= fmInput;
     END;
(*-IBM*)
(*MAC-
   WITH tpfilerec(f) DO BEGIN
     fInpFlag:= NOT out;
     fOutFlag:= out;
     fRefNum:= 1; {dummy}
     fVrefNum:= 1;
     fInOutProc:= NIL;
     END;
-MAC*)
   WITH tpFileRec(f) DO BEGIN
     fBuffer:= @s[1];
     fBufSize:= 255; {assume it is full string}
     IF out THEN fBufEnd:= fBufSize
     ELSE fBufEnd:= length(s);
     fBufPos:= 0;
     END;
END; {openStrIO}

PROCEDURE closeStrIO( VAR f: text; VAR s: STRING);
{ close stringiO: get length }
VAR  err: integer;
BEGIN
   s[0]:= chr( tpFileRec(f).fBufPos);
END; {closeStrIO}




PROCEDURE seekText( VAR f: text; offset: longInt;
            seekFrom : seektype);
{ seek for textfiles }
VAR
   count: longint;
   iseek: integer;
   err  : integer;
(*IBM-*)
   uf   : FILE;
BEGIN
  WITH tpFileRec(f) DO BEGIN
   offset := offset + fBufPos;
   IF handle<0 THEN {nada - not a disk file}
   ELSE IF (seekFrom=seek_cur) and (offset>=0)
           and (  (mode=fmInput) and (offset<fBufEnd)
               or (mode=fmOutput) and (offset<=fBufPos)) THEN
     fBufPos := offset
   ELSE BEGIN
    offset := offset - fBufPos;
    IF mode = fmOutput THEN BEGIN
     { flush buffer to disk if seek on output file}
      move(f, uf, sizeof(uf));    { need right file type for blockwrite}
      fileRec(uf).recsize:= 1;
      blockwrite( uf, fBuffer^, fBufPos, err);
      fBufPos:= 0;
      END;
    IF seekFrom = seek_cur THEN
      offset:= offset - fBufEnd + fBufPos;
    IF 0 = msdosSeek( handle, offset, seekFrom) THEN BEGIN
      fBufPos:= 0; fBufEnd:= 0; {next read/write will fill buffer as needed}
      END;
   END;
  END; {with}
(*-IBM*)
(*MAC-
BEGIN
  CASE seekFrom OF
    seek_set : iseek:= fsFromStart; {offset from 0}
    seek_cur : iseek:= fsFromMark;
    seek_end : iseek:= fsFromLEOF;
    END;
  WITH tpFileRec(f) DO
   IF fRefNum=0 THEN {not a disk file}
   ELSE BEGIN
    IF fOutFlag THEN BEGIN { flush buffer to disk if seek on output file}
      count:= fBufPos;
      err:= fsWrite( fRefNum, count, ptr(fBuffer));
      fBufPos:= 0;
      END
    ELSE IF seekFrom = seek_cur THEN
      offset:= offset - fBufEnd + fBufPos;
    IF 0 = setFpos( fRefNum, iseek, offset) THEN BEGIN
      fBufEnd:= 0; fBufPos:= 0;
      END;
   END;
-MAC*)
END; {seekText}



procedure BackCh(var f:Text);
  var  p,q: longint;
       ch: char;
  begin with tpFileRec(f) do begin
    if fBufPos>0 then
      SeekText(f,-1,seek_cur)
    else
    {
      if mode=fmOutput then begin
        SeekText(f,-1,seek_cur);
       end
      else } begin
        p := PosText(f) - 1;
        q := p - fBufSize;
        if q<0 then q := 0;
        SeekText(f,q,seek_set);
        read(f,ch);
        SeekText(f,p-1,seek_cur);
      end;
  end  end;

procedure BackLn(var f:Text);
  var ch: char;
      p:  longint;
      uf: File;
  begin
    BackCh(f); {Skip LF}
    BackCh(f); {Skip CR}
    if tpFileRec(f).mode=fmInput then begin
      REPEAT
        BackCh(f);
      UNTIL eoln(f);
      if eof(f) then
        SeekText(f,0,seek_set)
      else
        ReadLn(f);
     end
    else with tpFileRec(f) do begin
      reset(f);
      SeekText(f,0,seek_end);
      p := PosText(f);
      BackLn(f);
      p := PosText(f);
      close(f);
      append(f);
      IF 0 = msdosSeek( handle,p,seek_set) THEN BEGIN
        fBufPos := 0; fBufEnd := 0;
        END;
    end;
  end;


END.