{----------------------------------------------------------------------}
{ INOUT --- buffered input/output                                      }
{----------------------------------------------------------------------}
{ (c) Enter AG, Zrich, 1990           Creation: H. Thomas  Feb 1990   }
{----------------------------------------------------------------------}
{ $i switches.inc }
unit inout;

interface

const
  bufsize = word($FFFF);

type
  bufptr = ^buftype;
  buftype = array[0 .. pred(bufsize)] of char;

  fileptr = ^filetype;
  filetype = object
    fname  : string;
    fsize,
    fpos   : longint;
    bufpos : word;
    fbufptr: bufptr;
    fhandle,
    result : word;
    { init: make buffer and initialize fields }
    constructor init;
    { ioresult: return error code of last i/o of this file }
    function ioresult: word;
    { term: dispose buffer }
    destructor term;
  end;

  infileptr = ^infiletype;
  infiletype = object(filetype)
    { open: set fname, open file (for return code check result!) }
    procedure open(infn: string);
    { readch: get a character from file }
    function readch: char;
    { eof: true, if end of file reached }
    function eof: boolean;
    { close: close file }
    procedure close;
  end;

  outfileptr = ^outfiletype;
  outfiletype = object(filetype)
    { open: set fname, open file (for return code check result!) }
    procedure open(outfn: string);
    { writech: put a character to file }
    procedure writech(ch: char);
    { close: close file, writing last partial buffer }
    procedure close;
  end;

{----------------------------------------------------------------------}
implementation

uses dos;

type
  wlint = record case boolean of
    false: (l: longint);
    true: (wl,wh: word);
  end;

{======================================================================}
{ dos file procedures                                                  }
{----------------------------------------------------------------------}
procedure inopen(var fname: string; var fhandle, result: word);
var
  regs: registers;
begin { inopen }
  fname[succ(length(fname))] := #0;
  with regs do begin
    ah := $3D;
    ds := seg(fname[1]);
    dx := ofs(fname[1]);
    al := 0;
    intr($21,regs);
    if (flags and fcarry) = 0 then begin
      result := 0;
      fhandle := ax;
    end
    else begin
      result := ax;
      fname := '';
    end;
  end;
end; { inopen }

{----------------------------------------------------------------------}
procedure outopen(var fname: string; var fhandle, result: word);
var
  regs: registers;
begin { outopen }
  fname[succ(length(fname))] := #0;
  with regs do begin
    ah := $3C;
    ds := seg(fname[1]);
    dx := ofs(fname[1]);
    cx := 0;
    intr($21,regs);
    if (flags and fcarry) = 0 then begin
      result := 0;
      fhandle := ax;
    end
    else begin
      result := ax;
      fname := '';
    end;
  end;
end; { outopen }

{----------------------------------------------------------------------}
function lseek(fhandle: word; posofs, posseg: word; seekmode: byte;
               var result: word): longint;
var
  pos: wlint;
  regs: registers;
begin { lseek }
  with regs do begin
    ah := $42;
    bx := fhandle;
    dx := posofs;
    cx := posseg;
    al := seekmode;
    intr($21,regs);
    if (flags and fcarry) = 0 then begin
      result := 0;
      pos.wl := ax;
      pos.wh := dx;
    end
    else result := ax;
  end;
  lseek := pos.l;
end; { lseek }

{----------------------------------------------------------------------}
function getsize(fhandle: word; var result: word): longint;
var
  c: wlint;
  regs: registers;
begin { getsize }
  c.l := lseek(fhandle,0,0,1,result);
  if result = 0 then getsize := lseek(fhandle,0,0,2,result);
  if result = 0 then c.l := lseek(fhandle,c.wl,c.wh,0,result);
end; { getsize }

{----------------------------------------------------------------------}
procedure readblock(fhandle: word; var buffer; rlen: word; var result: word);
var
  regs: registers;
begin { readblock }
  with regs do begin
    ah := $3F;
    bx := fhandle;
    ds := seg(buffer);
    dx := ofs(buffer);
    cx := rlen;
    intr($21,regs);
    if (flags and fcarry) = 0 then result := 0 else result := ax;
  end;
end; { readblock }

{----------------------------------------------------------------------}
procedure writeblock(fhandle: word; var buffer; wlen: word; var result: word);
var
  regs: registers;
begin { writeblock }
  with regs do begin
    ah := $40;
    bx := fhandle;
    ds := seg(buffer);
    dx := ofs(buffer);
    cx := wlen;
    intr($21,regs);
    if (flags and fcarry) = 0 then result := 0 else result := ax;
  end;
end; { writeblock }

{----------------------------------------------------------------------}
procedure fclose(fhandle: word; var result: word);
var
  regs: registers;
begin { fclose }
  with regs do begin
    ah := $3E;
    bx := fhandle;
    intr($21,regs);
    if (flags and fcarry) = 0 then result := 0 else result := ax;
  end;
end; { fclose }

{======================================================================}
{ filetype methods                                                     }
{----------------------------------------------------------------------}
constructor filetype.init;
begin { init }
  new(fbufptr);
  fname := '';
end; { init }

{----------------------------------------------------------------------}
{ ioresult: return error code of last i/o of this file                 }
{----------------------------------------------------------------------}
function filetype.ioresult: word;
begin { ioresult }
  ioresult := result;
  result := 0;
end; { ioresult }

{----------------------------------------------------------------------}
destructor filetype.term;
begin { term }
  dispose(fbufptr);
end; { term }

{======================================================================}
{ infiletype methods                                                   }
{----------------------------------------------------------------------}
procedure infiletype.open(infn: string);
begin { open }
  fname := fexpand(infn);
  inopen(fname,fhandle,result);
  if result = 0 then fsize := getsize(fhandle,result);
  fpos := 0;
  bufpos := bufsize;
end; { open }

{----------------------------------------------------------------------}
function infiletype.readch: char;
var
  regs: registers;
begin { readch }
  if bufpos = bufsize then begin
    if fsize-fpos > bufsize
    then readblock(fhandle,fbufptr^,bufsize,result)
    else readblock(fhandle,fbufptr^,fsize-fpos,result);
    bufpos := 0;
  end;
  readch := fbufptr^[bufpos];
  inc(bufpos);
  inc(fpos);
end; { readch }

{----------------------------------------------------------------------}
function infiletype.eof: boolean;
begin { eof }
  eof := fpos >= fsize;
end; { eof }

{----------------------------------------------------------------------}
procedure infiletype.close;
var
  regs: registers;
begin { close }
  fclose(fhandle,result);
  fname := '';
end; { close }

{======================================================================}
{ outfiletype methods                                                  }
{----------------------------------------------------------------------}
procedure outfiletype.open(outfn: string);
begin { open }
  fname := fexpand(outfn);
  outopen(fname,fhandle,result);
  fpos := 0;
  bufpos := 0;
end; { open }

{----------------------------------------------------------------------}
{ writech: put a character to file                                     }
{----------------------------------------------------------------------}
procedure outfiletype.writech(ch: char);
begin { writech }
  if bufpos = bufsize then begin
    writeblock(fhandle,fbufptr^,bufpos,result);
    bufpos := 0;
  end;
  fbufptr^[bufpos] := ch;
  inc(bufpos);
  inc(fpos);
end; { writech }

{----------------------------------------------------------------------}
{ close: close file, writing last partial buffer }
{----------------------------------------------------------------------}
procedure outfiletype.close;
begin { close }
  if bufpos > 0 then writeblock(fhandle,fbufptr^,bufpos,result);
  if result = 0 then fclose(fhandle,result);
  fname := '';
end; { close }

{======================================================================}
end. { inout }