ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/CPM/TURBOPAS/ENVIRON.LBR/STDIO.PZS/STDIO.PAS

Pascal/Delphi Source File | 2000-06-30 | 9KB | 423 lines

{ last mod 04-Jul-85 }
{$X-}
procedure ioinit(numfiles:integer);

{ initialize i/o variables, character table }

var
     i           :integer;
     fbp       :^fbuf;
begin
     if numfiles + 3 > MAXOPEN then
      error('Too many files requested.');
     openlist[TRMIN].mode := IOREAD;
     openlist[TRMOUT].mode := IOWRITE;
     openlist[PRINTER].mode := IOWRITE;
     for i:=PRINTER+1 to PRINTER+numfiles do
      with openlist[i] do
      begin
           new(fbp);
           fbufptr := fbp;
           mode := IOAVAIL;
      end;
     for i:=PRINTER+numfiles+1 to MAXOPEN do
      openlist[i].mode := IONAVAIL;
     for i:=0 to 47 do chartbl[i] := 'X';
     for i:=48 to 57 do chartbl[i] := 'D';
     for i:=58 to 64 do chartbl[i] := 'X';
     for i:=65 to 90 do chartbl[i] := 'U';
     for i:=91 to 96 do chartbl[i] := 'X';
     for i:=97 to 122 do chartbl[i] := 'L';
     for i:=123 to 127 do chartbl[i] := 'X';
end;

function open(var name:textline; accmode:integer):filedesc;

{ open a file with the given name for access in the given mode }

var
     intname   :string80;
     found     :boolean;
     i           :integer;

function openfile(accmode:integer; var iostuff: ioblock; var intname: string80)
         :boolean;

{ machine-dependent subroutine, attempts to open file with name intname
  and mode accmode.  If open ok, initializes iostuff and returns 'true'.
  If error, returns 'false' }

var
     foundcz   :boolean;
     j           :integer;
     fs           :integer;
     mode2     :byte;
begin
     {$i-}
     openfile := false;
     with iostuff do
     begin
      assign(filevar,intname);
      if ioresult = 0 then
      begin
           mode2 := accmode and MODEMASK;
           if mode2 = IOREAD then
           begin
            reset(filevar);
            lastrec := filesize(filevar);
            reccnt := 0;
            bufindx := FBUFSIZE+1;
           end
           else if mode2 = IOWRITE then
           begin
            rewrite(filevar);
            bufindx := 1;
           end
           else if mode2 = IOAPPEND then
           begin
            reset(filevar);
            fs := filesize(filevar);
            if (ioresult = 0) and (fs > 0) then
            { file already exists }
            begin
             seek(filevar,fs-1);
             blockread(filevar,fbufptr^,1);
             seek(filevar,fs-1);
             { to overwrite last sector of file }
             j := 1; foundcz := false;
             while (j<=SECTSIZE) and (not foundcz) do
             begin
                  foundcz := ord(fbufptr^[j]) = eofchar;
                  if not foundcz then j:=j+1;
             end;
             bufindx := j;
            end
            else { file doesn't exist, create it }
            begin
             rewrite(filevar);
             bufindx := 1;
            end;
           end;
           if ioresult = 0 then
           begin
            openfile := true; mode := accmode; { flag file open }
            eofflag := false;
           end;
      end
      {$i+}
     end;
end; { openfile }

begin { open }
     intname := makestring(name);
     open := IOERROR;
     found := false;
     i := 1;
     while (i<=MAXOPEN) and (not found) do
     begin
      found := (openlist[i].mode = IOAVAIL);
      if found then
      begin
           if openfile(accmode,openlist[i],intname) then
            open := i;
      end
      else i := i + 1;
     end;
end { open };
{$X+}

procedure remove(var name:textline);

{ removes a file }

var
     filvar    :file;
     intname   :string80;
begin
     {$i-}
     intname := makestring(name);
     assign(filvar,intname);
     {$i+}
     if ioresult = 0 then
      erase(filvar);
end;

procedure putc(c:character);

{ puts 1 character to std. output }

begin
     if c = NEWLINE then
      writeln
     else
      write(chr(c));
end;

{$b-}
function keyin(var c:character):character;

{ gets a char. from the keyboard, doesn't echo it}

var
     ch      :char;
begin
     read(Kbd,ch);
     c := ord(ch);
     if (c = eofchar) then
      c := ENDFILE
     else if c = CR then
      c := NEWLINE;
     keyin := c;
end;
{$b+}

function getc(var c:character):character;

{ get 1 character from keyboard, echo it to screen}

var
     ch      :char;

begin
     c := keyin(c);
     putc(c);
     getc := c;
end;

function getbyte(var b:byte; fd:filedesc): boolean;

{ reads a binary byte from the file, returns false if physical end of file }

begin
     getbyte := true;
     with openlist[fd] do
     begin
      if eofflag then
           getbyte := false
      else
      begin
           if (bufindx > FBUFSIZE) then
           begin
            if eof(filevar) then
            begin
            getbyte := false;
            eofflag := true;
            end
            else
            begin
             {$i-}
             blockread(filevar,fbufptr^[1],FBUFSIZE div SECTSIZE);
             {$i+}
             if not (ioresult in [$99,0]) then
                  error('Disk read error');
            end;
            bufindx := 1;
           end;
           b := fbufptr^[bufindx];
           if bufindx and (SECTSIZE-1) = 0 then
        {don't read past last record}
           begin
            reccnt:=reccnt+1;
            if reccnt>=lastrec then eofflag := true;
           end;
           bufindx := bufindx + 1;
      end;
     end;
end; { getbyte}

function getcf(var c:character; fd: filedesc):character;

{ get a character from a file }

var
     junk :boolean;
     b      :byte;
begin
     if fd  = TRMIN then
      getcf := getc(c)
     else with openlist[fd] do
     begin
      if getbyte(b,fd) then
      begin
           c := b and $7F;
           if c = eofchar then
           begin
            c := ENDFILE;
            eofflag := true;
           end
           else
           begin
            if (c = CR) or (c = LF) then
            begin
             junk := getbyte(b,fd);
             c := NEWLINE;
            end
           end;
      end
      else
           c:=ENDFILE;
      getcf := c;
     end;
end { getcf };

procedure putbyte(b:byte; fd:filedesc);

{ writes a binary byte to the file }

begin
     with openlist[fd] do
     begin
      fbufptr^[bufindx] := b;
      bufindx := bufindx + 1;
      if bufindx > FBUFSIZE then
      begin
           {$i-}
           blockwrite(filevar,fbufptr^[1],FBUFSIZE div SECTSIZE);
           {$i+}
           if ioresult<>0 then error('Disk write error');
           bufindx := 1;
      end
     end
end; { putbyte }

procedure putcf(c:character; fd: filedesc);

{ put a character to a file }

begin
     if fd = TRMOUT then
      putc(c)
     else if fd = PRINTER then
     begin
      if c = NEWLINE then writeln(lst) else write(lst,chr(c));
     end
     else
     begin
      if c = NEWLINE then { do cr first }
      begin
           putbyte(CR,fd);
           c := LF;
      end;
      putbyte(c,fd);
     end;
end { putcf };

procedure pclose(fd: filedesc);

{ close a file }

begin
     if not (fd in [TRMIN,TRMOUT,PRINTER]) then
     with openlist[fd] do
     begin
      if ((mode and MODEMASK) in [IOWRITE,IOAPPEND]) then
      { flush last buffer }
      begin
           if (mode and BINMASK) = 0 then putcf(eofchar,fd);
           if bufindx > 1 then
            blockwrite(filevar,fbufptr^[1],
                  ((bufindx-2) div SECTSIZE)+1);
      end;
      close(filevar);
      mode := IOAVAIL;
     end;
end;

function getline(var s:textline; fd:filedesc; maxsize:integer):boolean;

{ gets line from file, returns false if end of file }

var
     i      :integer;
     c      :character;
begin
     i := 1;
     repeat
      if fd = TRMIN then {handle terminal line editing }
      begin
          s[i] := keyin(c);
          if (c=bks) then
          begin
          if (i>1) then
          begin
              i := i - 1; putc(bks); putc(space); putc(bks)
          end
          end
          else if ((c>=32) and (c<>127)) or (c=NEWLINE) then
          begin
          i := i + 1;
          putc(c)
          end
      end
      else
      begin
          s[i] := getcf(c,fd);
          i := i + 1;
      end
     until (c = NEWLINE) or (c = ENDFILE) or (i>=maxsize);
     if c = ENDFILE then
      i := i - 1;
     s[i] := EOS;
     getline := (c <> ENDFILE);
end;

procedure putstr(var str:textline; fd:filedesc);

{ put string in a file }

var
     i      :integer;
begin
     i := 1;
     while str[i] <> EOS do
     begin
      putcf(str[i],fd);
      i := i + 1;
     end;
end;

function getfile(var filevar :filedesc;
         var prompt:textline;
         var name:textline;
         mode:integer) :boolean;

{ get file name from keyboard and open file, returns 'false' if
  CR entered after prompt }

var
     openok,nofile    :boolean;
     junk      :boolean;
     fd           :filedesc;
     lenname   :integer;

begin
     openok := false;
     repeat
      putstr(prompt,TRMOUT);
      {$u+}
      junk := getline(name,TRMIN,MAXSTR);
      {$u-}
      lenname := slength(name);
      if name[lenname] = NEWLINE then name[lenname] := EOS;
      nofile := (name[1] in [EOS,NEWLINE]);
      if not nofile then
      begin
          fd := open(name,mode);
          openok := fd <> IOERROR;
          if openok then
          begin
           filevar := fd;
           getfile := true;
          end
          else
          begin
           writeln;
           write('Can''t open: '); putstr(name,TRMOUT);
           writeln;
          end
      end
      else getfile := false;
      until openok or nofile;
end;