freepascal.compiler/rtl/inc/text.inc

{
    $Id$
    This file is part of the Free Pascal Run time library.
    Copyright (c) 1999-2000 by the Free Pascal development team

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

{
  Possible Defines:

  EOF_CTRLZ       Is Ctrl-Z (#26) a EOF mark for textfiles
  SHORT_LINEBREAK Use short Linebreaks #10 instead of #10#13
  MAC_LINEBREAK   Use Mac Linebreaks: #13 instead of #10 or #10#13

  SHORT_LINEBREAK is defined in the Linux system unit (syslinux.pp)

}

{****************************************************************************
                    subroutines For TextFile handling
****************************************************************************}

Procedure FileCloseFunc(Var t:TextRec);
Begin
  Do_Close(t.Handle);
  t.Handle:=UnusedHandle;
End;

Procedure FileReadFunc(var t:TextRec);
Begin
  t.BufEnd:=Do_Read(t.Handle,Longint(t.Bufptr),t.BufSize);
  t.BufPos:=0;
End;


Procedure FileWriteFunc(var t:TextRec);
var
  i : longint;
Begin
  i:=Do_Write(t.Handle,Longint(t.Bufptr),t.BufPos);
  if i<>t.BufPos then
    InOutRes:=101;
  t.BufPos:=0;
End;


Procedure FileOpenFunc(var t:TextRec);
var
  Flags : Longint;
Begin
  Case t.mode Of
    fmInput : Flags:=$10000;
   fmOutput : Flags:=$11001;
   fmAppend : Flags:=$10101;
  else
   begin
     InOutRes:=102;
     exit;
   end;
  End;
  Do_Open(t,PChar(@t.Name),Flags);
  t.CloseFunc:=@FileCloseFunc;
  t.FlushFunc:=nil;
  if t.Mode=fmInput then
   t.InOutFunc:=@FileReadFunc
  else
   begin
     t.InOutFunc:=@FileWriteFunc;
   { Only install flushing if its a NOT a file, and only check if there
     was no error opening the file, becuase else we always get a bad
     file handle error 6 (PFV) }
     if (InOutRes=0) and
        Do_Isdevice(t.Handle) then
      t.FlushFunc:=@FileWriteFunc;
   end;
End;


Procedure assign(var t:Text;const s:String);
Begin
  FillChar(t,SizEof(TextRec),0);
{ only set things that are not zero }
  TextRec(t).Handle:=UnusedHandle;
  TextRec(t).mode:=fmClosed;
  TextRec(t).BufSize:=TextRecBufSize;
  TextRec(t).Bufptr:=@TextRec(t).Buffer;
  TextRec(t).OpenFunc:=@FileOpenFunc;
  Move(s[1],TextRec(t).Name,Length(s));
End;


Procedure assign(var t:Text;p:pchar);
begin
  Assign(t,StrPas(p));
end;


Procedure assign(var t:Text;c:char);
begin
  Assign(t,string(c));
end;


Procedure Close(var t : Text);[IOCheck];
Begin
  if InOutRes<>0 then
   Exit;
  case TextRec(t).mode of
    fmInput,fmOutPut,fmAppend:
      Begin
        { Write pending buffer }
        If Textrec(t).Mode=fmoutput then
          FileFunc(TextRec(t).InOutFunc)(TextRec(t));
        { Only close functions not connected to stdout.}
        If ((TextRec(t).Handle<>StdInputHandle) and
            (TextRec(t).Handle<>StdOutputHandle) and
            (TextRec(t).Handle<>StdErrorHandle)) Then
          FileFunc(TextRec(t).CloseFunc)(TextRec(t));
        TextRec(t).mode := fmClosed;
        { Reset buffer for safety }
        TextRec(t).BufPos:=0;
        TextRec(t).BufEnd:=0;
      End
    else inOutRes := 103;
  End;
End;


Procedure OpenText(var t : Text;mode,defHdl:Longint);
Begin
  Case TextRec(t).mode Of {This gives the fastest code}
   fmInput,fmOutput,fmInOut : Close(t);
   fmClosed : ;
  else
   Begin
     InOutRes:=102;
     exit;
   End;
  End;
  TextRec(t).mode:=mode;
  TextRec(t).bufpos:=0;
  TextRec(t).bufend:=0;
  FileFunc(TextRec(t).OpenFunc)(TextRec(t));
  { reset the mode to closed when an error has occured }
  if InOutRes<>0 then
   TextRec(t).mode:=fmClosed;
End;


Procedure Rewrite(var t : Text);[IOCheck];
Begin
  If InOutRes<>0 then
   exit;
  OpenText(t,fmOutput,1);
End;


Procedure Reset(var t : Text);[IOCheck];
Begin
  If InOutRes<>0 then
   exit;
  OpenText(t,fmInput,0);
End;


Procedure Append(var t : Text);[IOCheck];
Begin
  If InOutRes<>0 then
   exit;
  OpenText(t,fmAppend,1);
End;


Procedure Flush(var t : Text);[IOCheck];
Begin
  If InOutRes<>0 then
   exit;
  if TextRec(t).mode<>fmOutput then
   begin
     if TextRec(t).mode=fmInput then
      InOutRes:=105
     else
      InOutRes:=103;
     exit;
   end;
{ Not the flushfunc but the inoutfunc should be used, becuase that
  writes the data, flushfunc doesn't need to be assigned }
  FileFunc(TextRec(t).InOutFunc)(TextRec(t));
End;


Procedure Erase(var t:Text);[IOCheck];
Begin
  If InOutRes <> 0 then
   exit;
  If TextRec(t).mode=fmClosed Then
   Do_Erase(PChar(@TextRec(t).Name));
End;


Procedure Rename(var t : text;p:pchar);[IOCheck];
Begin
  If InOutRes <> 0 then
   exit;
  If TextRec(t).mode=fmClosed Then
   Begin
     Do_Rename(PChar(@TextRec(t).Name),p);
     { check error code of do_rename }
     If InOutRes = 0 then
         Move(p^,TextRec(t).Name,StrLen(p)+1);
   End;
End;


Procedure Rename(var t : Text;const s : string);[IOCheck];
var
  p : array[0..255] Of Char;
Begin
  If InOutRes <> 0 then
   exit;
  Move(s[1],p,Length(s));
  p[Length(s)]:=#0;
  Rename(t,Pchar(@p));
End;


Procedure Rename(var t : Text;c : char);[IOCheck];
var
  p : array[0..1] Of Char;
Begin
  If InOutRes <> 0 then
   exit;
  p[0]:=c;
  p[1]:=#0;
  Rename(t,Pchar(@p));
End;


Function Eof(Var t: Text): Boolean;[IOCheck];
Begin
  If (InOutRes<>0) then
   exit(true);
  if (TextRec(t).mode<>fmInput) Then
   begin
     if TextRec(t).mode=fmOutput then
      InOutRes:=104
     else
      InOutRes:=103;
     exit(true);
   end;
  If TextRec(t).BufPos>=TextRec(t).BufEnd Then
   begin
     FileFunc(TextRec(t).InOutFunc)(TextRec(t));
     If TextRec(t).BufPos>=TextRec(t).BufEnd Then
      exit(true);
   end;
{$ifdef EOF_CTRLZ}
  Eof:=(TextRec(t).Bufptr^[TextRec(t).BufPos]=#26);
{$else}
  Eof:=false;
{$endif EOL_CTRLZ}
end;


Function Eof:Boolean;
Begin
  Eof:=Eof(Input);
End;


Function SeekEof (Var t : Text) : Boolean;
var
  oldfilepos, oldbufpos, oldbufend, reads: longint;
  isdevice: boolean;
Begin
  If (InOutRes<>0) then
   exit(true);
  if (TextRec(t).mode<>fmInput) Then
   begin
     if TextRec(t).mode=fmOutPut then
      InOutRes:=104
     else
      InOutRes:=103;
     exit(true);
   end;
  { try to save the current position in the file, seekeof() should not move }
  { the current file position (JM)                                          }
  oldbufpos := TextRec(t).BufPos;
  oldbufend := TextRec(t).BufEnd;
  reads := 0;
  oldfilepos := -1;
  isdevice := Do_IsDevice(TextRec(t).handle);
  repeat
    If TextRec(t).BufPos>=TextRec(t).BufEnd Then
     begin
       { signal that the we will have to do a seek }
       inc(reads);
       if not isdevice and
          (reads = 1) then
         begin
           oldfilepos := Do_FilePos(TextRec(t).handle) - TextRec(t).BufEnd;
           InOutRes:=0;
         end;
       FileFunc(TextRec(t).InOutFunc)(TextRec(t));
       If TextRec(t).BufPos>=TextRec(t).BufEnd Then
        begin
          { if we only did a read in which we didn't read anything, the }
          { old buffer is still valid and we can simply restore the     }
          { pointers (JM)                                               }
          dec(reads);
          SeekEof := true;
          break;
        end;
     end;
    case TextRec(t).Bufptr^[TextRec(t).BufPos] of
{$ifdef EOF_CTRLZ}
         #26 : 
           begin
             SeekEof := true;
             break;
           end;
{$endif EOF_CTRLZ}
     #10,#13,
      #9,' ' : ;
    else
     begin
       SeekEof := false;
       break;
     end;
    end;
   inc(TextRec(t).BufPos);
  until false;
  { restore file position if not working with a device }
  if not isdevice then
    { if we didn't modify the buffer, simply restore the BufPos and BufEnd  }
    { (the latter becuase it's now probably set to zero because nothing was }
    {  was read anymore)                                                    }
    if (reads = 0) then
      begin
        TextRec(t).BufPos:=oldbufpos;
        TextRec(t).BufEnd:=oldbufend;
      end
    { otherwise return to the old filepos and reset the buffer }
    else
      begin
        do_seek(TextRec(t).handle,oldfilepos);
        InOutRes:=0;
        FileFunc(TextRec(t).InOutFunc)(TextRec(t));
        TextRec(t).BufPos:=oldbufpos;
      end;
End;


Function SeekEof : Boolean;
Begin
  SeekEof:=SeekEof(Input);
End;


Function Eoln(var t:Text) : Boolean;
Begin
  If (InOutRes<>0) then
   exit(true);
  if (TextRec(t).mode<>fmInput) Then
   begin
     if TextRec(t).mode=fmOutPut then
      InOutRes:=104
     else
      InOutRes:=103;
     exit(true);
   end;
  If TextRec(t).BufPos>=TextRec(t).BufEnd Then
   begin
     FileFunc(TextRec(t).InOutFunc)(TextRec(t));
     If TextRec(t).BufPos>=TextRec(t).BufEnd Then
      exit(true);
   end;
  Eoln:=(TextRec(t).Bufptr^[TextRec(t).BufPos] in [#10,#13]);
End;


Function Eoln : Boolean;
Begin
  Eoln:=Eoln(Input);
End;


Function SeekEoln (Var t : Text) : Boolean;
Begin
  If (InOutRes<>0) then
   exit(true);
  if (TextRec(t).mode<>fmInput) Then
   begin
     if TextRec(t).mode=fmOutput then
      InOutRes:=104
     else
      InOutRes:=103;
     exit(true);
   end;
  repeat
    If TextRec(t).BufPos>=TextRec(t).BufEnd Then
     begin
       FileFunc(TextRec(t).InOutFunc)(TextRec(t));
       If TextRec(t).BufPos>=TextRec(t).BufEnd Then
        exit(true);
     end;
    case TextRec(t).Bufptr^[TextRec(t).BufPos] of
         #26,
     #10,#13 : exit(true);
      #9,' ' : ;
    else
     exit(false);
    end;
    inc(TextRec(t).BufPos);
  until false;
End;


Function SeekEoln : Boolean;
Begin
  SeekEoln:=SeekEoln(Input);
End;


Procedure SetTextBuf(Var F : Text; Var Buf);[INTERNPROC: In_settextbuf_file_x];


Procedure SetTextBuf(Var F : Text; Var Buf; Size : Longint);
Begin
  TextRec(f).BufPtr:=@Buf;
  TextRec(f).BufSize:=Size;
  TextRec(f).BufPos:=0;
  TextRec(f).BufEnd:=0;
End;


{*****************************************************************************
                               Write(Ln)
*****************************************************************************}

Procedure WriteBuffer(var f:Text;const b;len:longint);
var
  p   : pchar;
  left,
  idx : longint;
begin
  p:=pchar(@b);
  idx:=0;
  left:=TextRec(f).BufSize-TextRec(f).BufPos;
  while len>left do
   begin
     move(p[idx],TextRec(f).Bufptr^[TextRec(f).BufPos],left);
     dec(len,left);
     inc(idx,left);
     inc(TextRec(f).BufPos,left);
     FileFunc(TextRec(f).InOutFunc)(TextRec(f));
     left:=TextRec(f).BufSize-TextRec(f).BufPos;
   end;
  move(p[idx],TextRec(f).Bufptr^[TextRec(f).BufPos],len);
  inc(TextRec(f).BufPos,len);
end;


Procedure WriteBlanks(var f:Text;len:longint);
var
  left : longint;
begin
  left:=TextRec(f).BufSize-TextRec(f).BufPos;
  while len>left do
   begin
     FillChar(TextRec(f).Bufptr^[TextRec(f).BufPos],left,' ');
     dec(len,left);
     inc(TextRec(f).BufPos,left);
     FileFunc(TextRec(f).InOutFunc)(TextRec(f));
     left:=TextRec(f).BufSize-TextRec(f).BufPos;
   end;
  FillChar(TextRec(f).Bufptr^[TextRec(f).BufPos],len,' ');
  inc(TextRec(f).BufPos,len);
end;


Procedure fpc_Write_End(var f:Text);[Public,Alias:'FPC_WRITE_END']; iocheck; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
  if TextRec(f).FlushFunc<>nil then
   FileFunc(TextRec(f).FlushFunc)(TextRec(f));
end;


Procedure fpc_Writeln_End(var f:Text);[Public,Alias:'FPC_WRITELN_END']; iocheck; {$ifdef hascompilerproc} compilerproc; {$endif}
const
{$IFDEF SHORT_LINEBREAK}
  eollen=1;
  eol : array[0..0] of char=(#10);
{$ELSE SHORT_LINEBREAK}
{$ifdef MAC_LINEBREAK}
  eollen=1;
  eol : array[0..0] of char=(#13);
{$else MAC_LINEBREAK}
  eollen=2;
  eol : array[0..1] of char=(#13,#10);
{$endif MAC_LINEBREAK}
{$ENDIF SHORT_LINEBREAK}
begin
  If InOutRes <> 0 then exit;
  case TextRec(f).mode of
    fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
      begin
        { Write EOL }
        WriteBuffer(f,(@sLineBreak+1)^,length(sLineBreak));
        { Flush }
        if TextRec(f).FlushFunc<>nil then
          FileFunc(TextRec(f).FlushFunc)(TextRec(f));
      end;
    fmInput: InOutRes:=105
    else InOutRes:=103;
  end;
end;


Procedure fpc_Write_Text_ShortStr(Len : Longint;var f : Text;const s : String); iocheck; [Public,Alias:'FPC_WRITE_TEXT_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Begin
  If (InOutRes<>0) then
   exit;
  case TextRec(f).mode of
    fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
      begin
        If Len>Length(s) Then
          WriteBlanks(f,Len-Length(s));
        WriteBuffer(f,s[1],Length(s));
      end;
    fmInput: InOutRes:=105
    else InOutRes:=103;
  end;
End;

{ provide local access to write_str }
procedure Write_Str(Len : Longint;var f : Text;const s : String); iocheck; [external name 'FPC_WRITE_TEXT_SHORTSTR'];


Procedure fpc_Write_Text_Pchar_as_Array(Len : Longint;var f : Text;const s : array of char); iocheck; [Public,Alias:'FPC_WRITE_TEXT_PCHAR_AS_ARRAY']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
  ArrayLen : longint;
  p : pchar;
Begin
  If (InOutRes<>0) then
   exit;
  case TextRec(f).mode of
    fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
      begin
        p:=pchar(@s);
        { can't use StrLen, since that one could try to read past the end }
        { of the heap (JM)                                                }
        ArrayLen:=IndexByte(p^,high(s)+1,0);
        { IndexByte returns -1 if not found (JM) }
        if ArrayLen = -1 then
          ArrayLen := high(s)+1;
        If Len>ArrayLen Then
          WriteBlanks(f,Len-ArrayLen);
        WriteBuffer(f,p^,ArrayLen);
      end;
    fmInput: InOutRes:=105
    else InOutRes:=103;
  end;
End;


Procedure fpc_Write_Text_PChar_As_Pointer(Len : Longint;var f : Text;p : PChar); iocheck; [Public,Alias:'FPC_WRITE_TEXT_PCHAR_AS_POINTER']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
  PCharLen : longint;
Begin
  If (p=nil) or (InOutRes<>0) then
   exit;
  case TextRec(f).mode of
    fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
      begin
        PCharLen:=StrLen(p);
        If Len>PCharLen Then
          WriteBlanks(f,Len-PCharLen);
        WriteBuffer(f,p^,PCharLen);
      end;
    fmInput: InOutRes:=105
    else InOutRes:=103;
  end;
End;


Procedure fpc_Write_Text_AnsiStr (Len : Longint; Var f : Text; S : AnsiString); iocheck; [Public,alias:'FPC_WRITE_TEXT_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
 Writes a AnsiString to the Text file T
}
var
  SLen : longint;
begin
  If (InOutRes<>0) then
   exit;
  case TextRec(f).mode of
    fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
      begin
        SLen:=Length(s);
        If Len>SLen Then
          WriteBlanks(f,Len-SLen);
        if slen > 0 then
          WriteBuffer(f,PChar(S)^,SLen);
      end;
    fmInput: InOutRes:=105
    else InOutRes:=103;
  end;
end;


{$ifdef HASWIDESTRING}
Procedure fpc_Write_Text_WideStr (Len : Longint; Var f : Text; S : WideString); iocheck; [Public,alias:'FPC_WRITE_TEXT_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
 Writes a WideString to the Text file T
}
var
  SLen : longint;
begin
  If (pointer(S)=nil) or (InOutRes<>0) then
   exit;
  case TextRec(f).mode of
    fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
      begin
        SLen:=Length(s);
        If Len>SLen Then
          WriteBlanks(f,Len-SLen);
        WriteBuffer(f,PChar(AnsiString(S))^,SLen);
      end;
    fmInput: InOutRes:=105
    else InOutRes:=103;
  end;
end;
{$endif HASWIDESTRING}

Procedure fpc_Write_Text_SInt(Len : Longint;var t : Text;l : ValSInt); iocheck; [Public,Alias:'FPC_WRITE_TEXT_SINT']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
  s : String;
Begin
  If (InOutRes<>0) then
   exit;
  Str(l,s);
  Write_Str(Len,t,s);
End;


Procedure fpc_Write_Text_UInt(Len : Longint;var t : Text;l : ValUInt); iocheck; [Public,Alias:'FPC_WRITE_TEXT_UINT']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
  s : String;
Begin
  If (InOutRes<>0) then
   exit;
  Str(L,s);
  Write_Str(Len,t,s);
End;


procedure fpc_write_text_qword(len : longint;var t : text;q : qword); iocheck; [public,alias:'FPC_WRITE_TEXT_QWORD']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
  s : string;
begin
  if (InOutRes<>0) then
   exit;
  qword_str(q,s);
  write_str(len,t,s);
end;

procedure fpc_write_text_int64(len : longint;var t : text;i : int64); iocheck; [public,alias:'FPC_WRITE_TEXT_INT64']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
  s : string;
begin
  if (InOutRes<>0) then
   exit;
  int64_str(i,s);
  write_str(len,t,s);
end;


Procedure fpc_Write_Text_Float(rt,fixkomma,Len : Longint;var t : Text;r : ValReal); iocheck; [Public,Alias:'FPC_WRITE_TEXT_FLOAT']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
  s : String;
Begin
  If (InOutRes<>0) then
   exit;
  Str_real(Len,fixkomma,r,treal_type(rt),s);
  Write_Str(Len,t,s);
End;


Procedure fpc_Write_Text_Boolean(Len : Longint;var t : Text;b : Boolean); iocheck; [Public,Alias:'FPC_WRITE_TEXT_BOOLEAN']; {$ifdef hascompilerproc} compilerproc; {$endif}
Begin
  If (InOutRes<>0) then
   exit;
{ Can't use array[boolean] because b can be >0 ! }
  if b then
    Write_Str(Len,t,'TRUE')
  else
    Write_Str(Len,t,'FALSE');
End;


Procedure fpc_Write_Text_Char(Len : Longint;var t : Text;c : Char); iocheck; [Public,Alias:'FPC_WRITE_TEXT_CHAR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Begin
  If (InOutRes<>0) then
   exit;
  if (TextRec(t).mode<>fmOutput) Then
   begin
     if TextRec(t).mode=fmClosed then
      InOutRes:=103
     else
      InOutRes:=105;
     exit;
   end;
  If Len>1 Then
   WriteBlanks(t,Len-1);
  If TextRec(t).BufPos+1>=TextRec(t).BufSize Then
   FileFunc(TextRec(t).InOutFunc)(TextRec(t));
  TextRec(t).Bufptr^[TextRec(t).BufPos]:=c;
  Inc(TextRec(t).BufPos);
End;


{$ifdef HASWIDECHAR}
Procedure fpc_Write_Text_WideChar(Len : Longint;var t : Text;c : WideChar); iocheck; [Public,Alias:'FPC_WRITE_TEXT_WIDECHAR']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
  ch : char;
Begin
  If (InOutRes<>0) then
   exit;
  if (TextRec(t).mode<>fmOutput) Then
   begin
     if TextRec(t).mode=fmClosed then
      InOutRes:=103
     else
      InOutRes:=105;
     exit;
   end;
  If Len>1 Then
   WriteBlanks(t,Len-1);
  If TextRec(t).BufPos+1>=TextRec(t).BufSize Then
   FileFunc(TextRec(t).InOutFunc)(TextRec(t));
  ch:=c;
  TextRec(t).Bufptr^[TextRec(t).BufPos]:=ch;
  Inc(TextRec(t).BufPos);
End;
{$endif HASWIDECHAR}


{*****************************************************************************
                                Read(Ln)
*****************************************************************************}

Function NextChar(var f:Text;var s:string):Boolean;
begin
  if TextRec(f).BufPos<TextRec(f).BufEnd then
   begin
     if length(s)<high(s) then
      begin
        inc(s[0]);
        s[length(s)]:=TextRec(f).BufPtr^[TextRec(f).BufPos];
      end;
     Inc(TextRec(f).BufPos);
     If TextRec(f).BufPos>=TextRec(f).BufEnd Then
      FileFunc(TextRec(f).InOutFunc)(TextRec(f));
     NextChar:=true;
   end
  else
   NextChar:=false;
end;


Function IgnoreSpaces(var f:Text):Boolean;
{
  Removes all leading spaces,tab,eols from the input buffer, returns true if
  the buffer is empty
}
var
  s : string;
begin
  s:='';
  IgnoreSpaces:=false;
  while TextRec(f).Bufptr^[TextRec(f).BufPos] in [#9,#10,#13,' '] do
   if not NextChar(f,s) then
    exit;
  IgnoreSpaces:=true;
end;


procedure ReadNumeric(var f:Text;var s:string);
{
  Read numeric input, if buffer is empty then return True
}
begin
  repeat
    if not NextChar(f,s) then
      exit;
  until (length(s)=high(s)) or (TextRec(f).BufPtr^[TextRec(f).BufPos] in [#9,#10,#13,' ']);
end;


Procedure fpc_Read_End(var f:Text);[Public,Alias:'FPC_READ_END']; iocheck; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
  if TextRec(f).FlushFunc<>nil then
   FileFunc(TextRec(f).FlushFunc)(TextRec(f));
end;


Procedure fpc_ReadLn_End(var f : Text);[Public,Alias:'FPC_READLN_END']; iocheck; {$ifdef hascompilerproc} compilerproc; {$endif}
var prev: char;
Begin
{ Check error and if file is open and load buf if empty }
  If (InOutRes<>0) then
   exit;
  if (TextRec(f).mode<>fmInput) Then
   begin
     case TextRec(f).mode of
      fmOutPut,fmAppend:
        InOutRes:=104
       else
         InOutRes:=103;
     end;
     exit;
   end;
  if TextRec(f).BufPos>=TextRec(f).BufEnd Then
   begin
     FileFunc(TextRec(f).InOutFunc)(TextRec(f));
     if (TextRec(f).BufPos>=TextRec(f).BufEnd) then
       { Flush if set }
       begin
         if (TextRec(f).FlushFunc<>nil) then
           FileFunc(TextRec(f).FlushFunc)(TextRec(f));
         exit;
       end;
   end;
  repeat
    prev := TextRec(f).BufPtr^[TextRec(f).BufPos];
    inc(TextRec(f).BufPos);
{ no system uses #10#13 as line seperator (#10 = *nix, #13 = Mac, }
{ #13#10 = Dos), so if we've got #10, we can safely exit          }
    if prev = #10 then
      exit;
    if TextRec(f).BufPos>=TextRec(f).BufEnd Then
      begin
        FileFunc(TextRec(f).InOutFunc)(TextRec(f));
        if (TextRec(f).BufPos>=TextRec(f).BufEnd) then
          { Flush if set }
          begin
           if (TextRec(f).FlushFunc<>nil) then
             FileFunc(TextRec(f).FlushFunc)(TextRec(f));
           exit;
         end;
      end;
   if (prev=#13) then
     { is there also a #10 after it? }
     begin
       if (TextRec(f).BufPtr^[TextRec(f).BufPos]=#10) then
         { yes, skip that one as well }
         inc(TextRec(f).BufPos);
       exit;
     end;
  until false;
End;


Function ReadPCharLen(var f:Text;s:pchar;maxlen:longint):longint;
var
  sPos,len : Longint;
  p,startp,maxp : pchar;
Begin
  ReadPCharLen:=0;
{ Check error and if file is open }
  If (InOutRes<>0) then
   exit;
  if (TextRec(f).mode<>fmInput) Then
   begin
     case TextRec(f).mode of
       fmOutPut,fmAppend:
         InOutRes:=104
       else
         InOutRes:=103;
     end;
     exit;
   end;
{ Read maximal until Maxlen is reached }
  sPos:=0;
  repeat
    If TextRec(f).BufPos>=TextRec(f).BufEnd Then
     begin
       FileFunc(TextRec(f).InOutFunc)(TextRec(f));
       If TextRec(f).BufPos>=TextRec(f).BufEnd Then
         break;
     end;
    p:=@TextRec(f).Bufptr^[TextRec(f).BufPos];
    if SPos+TextRec(f).BufEnd-TextRec(f).BufPos>MaxLen then
     maxp:=@TextRec(f).BufPtr^[TextRec(f).BufPos+MaxLen-SPos]
    else
     maxp:=@TextRec(f).Bufptr^[TextRec(f).BufEnd];
    startp:=p;
  { search linefeed }
    while (p<maxp) and not(P^ in [#10,#13]) do
     inc(p);
  { calculate read bytes }
    len:=p-startp;
    inc(TextRec(f).BufPos,Len);
    Move(startp^,s[sPos],Len);
    inc(sPos,Len);
  { was it a LF or CR? then leave }
    if (spos=MaxLen) or
       ((p<maxp) and (p^ in [#10,#13])) then
      break;
  until false;
  ReadPCharLen:=spos;
End;


Procedure fpc_Read_Text_ShortStr(var f : Text;var s : String); iocheck; [Public,Alias:'FPC_READ_TEXT_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Begin
  s[0]:=chr(ReadPCharLen(f,pchar(@s[1]),high(s)));
End;


Procedure fpc_Read_Text_PChar_As_Pointer(var f : Text;var s : PChar); iocheck; [Public,Alias:'FPC_READ_TEXT_PCHAR_AS_POINTER']; {$ifdef hascompilerproc} compilerproc; {$endif}
Begin
  pchar(s+ReadPCharLen(f,s,$7fffffff))^:=#0;
End;


Procedure fpc_Read_Text_PChar_As_Array(var f : Text;var s : array of char); iocheck; [Public,Alias:'FPC_READ_TEXT_PCHAR_AS_ARRAY']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
  len: longint;
Begin
  len := ReadPCharLen(f,pchar(@s),high(s)+1);
  if len <= high(s) then
    s[len] := #0;
End;


Procedure fpc_Read_Text_AnsiStr(var f : Text;var s : AnsiString); iocheck; [Public,Alias:'FPC_READ_TEXT_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
  slen,len : longint;
Begin
  slen:=0;
  Repeat
    // SetLength will reallocate the length.
    SetLength(S,slen+255);
    len:=ReadPCharLen(f,pchar(Pointer(S)+slen),255);
    inc(slen,len);
  Until len<255;
  // Set actual length
  SetLength(S,Slen);
End;

{$ifdef hascompilerproc}
procedure fpc_Read_Text_Char(var f : Text; var c: char); iocheck; [Public,Alias:'FPC_READ_TEXT_CHAR'];compilerproc;
{$else hascompilerproc}
Function fpc_Read_Text_Char(var f : Text):char;[Public,Alias:'FPC_READ_TEXT_CHAR'];
{$endif hascompilerproc}
Begin
{$ifdef hascompilerproc}
  c:=#0;
{$else hascompilerproc}
  fpc_Read_Text_Char:=#0;
{$endif hascompilerproc}
{ Check error and if file is open }
  If (InOutRes<>0) then
   exit;
  if (TextRec(f).mode<>fmInput) Then
   begin
     case TextRec(f).mode of
       fmOutPut,fmAppend:
         InOutRes:=104
       else
         InOutRes:=103;
     end;
     exit;
   end;
{ Read next char or EOF }
  If TextRec(f).BufPos>=TextRec(f).BufEnd Then
   begin
     FileFunc(TextRec(f).InOutFunc)(TextRec(f));
     If TextRec(f).BufPos>=TextRec(f).BufEnd Then
{$ifdef hascompilerproc}
       begin
         c := #26;
         exit;
       end;
{$else hascompilerproc}
       exit(#26);
{$endif hascompilerproc}
   end;
{$ifdef hascompilerproc}
  c:=TextRec(f).Bufptr^[TextRec(f).BufPos];
{$else hascompilerproc}
  fpc_Read_Text_Char:=TextRec(f).Bufptr^[TextRec(f).BufPos];
{$endif hascompilerproc}
  inc(TextRec(f).BufPos);
end;


{$ifdef hascompilerproc}
Procedure fpc_Read_Text_SInt(var f : Text; var l : ValSInt); iocheck; [Public,Alias:'FPC_READ_TEXT_SINT']; compilerproc;
{$else hascompilerproc}
Function fpc_Read_Text_SInt(var f : Text):ValSInt;[Public,Alias:'FPC_READ_TEXT_SINT'];
{$endif hascompilerproc}
var
  hs   : String;
  code : Longint;
Begin
{$ifdef hascompilerproc}
  l:=0;
{$else hascompilerproc}
  fpc_Read_Text_SInt:=0;
{$endif hascompilerproc}
{ Leave if error or not open file, else check for empty buf }
  If (InOutRes<>0) then
   exit;
  if (TextRec(f).mode<>fmInput) Then
   begin
     case TextRec(f).mode of
       fmOutPut,fmAppend:
         InOutRes:=104
       else
         InOutRes:=103;
     end;
     exit;
   end;
  If TextRec(f).BufPos>=TextRec(f).BufEnd Then
   FileFunc(TextRec(f).InOutFunc)(TextRec(f));
  hs:='';
  if IgnoreSpaces(f) then
   ReadNumeric(f,hs);
{$ifdef hascompilerproc}
  Val(hs,l,code);
{$else hascompilerproc}
  Val(hs,fpc_Read_Text_SInt,code);
{$endif hascompilerproc}
  If code<>0 Then
   InOutRes:=106;
End;


{$ifdef hascompilerproc}
Procedure fpc_Read_Text_UInt(var f : Text; var u : ValUInt);  iocheck; [Public,Alias:'FPC_READ_TEXT_UINT']; compilerproc;
{$else hascompilerproc}
Function fpc_Read_Text_UInt(var f : Text):ValUInt;[Public,Alias:'FPC_READ_TEXT_UINT'];
{$endif hascompilerproc}
var
  hs   : String;
  code : longint;
Begin
{$ifdef hascompilerproc}
  u:=0;
{$else hascompilerproc}
  fpc_Read_Text_UInt:=0;
{$endif hascompilerproc}
{ Leave if error or not open file, else check for empty buf }
  If (InOutRes<>0) then
   exit;
  if (TextRec(f).mode<>fmInput) Then
   begin
     case TextRec(f).mode of
       fmOutPut,fmAppend:
         InOutRes:=104
       else
         InOutRes:=103;
     end;
     exit;
   end;
  If TextRec(f).BufPos>=TextRec(f).BufEnd Then
   FileFunc(TextRec(f).InOutFunc)(TextRec(f));
  hs:='';
  if IgnoreSpaces(f) then
   ReadNumeric(f,hs);
{$ifdef hascompilerproc}
  val(hs,u,code);
{$else hascompilerproc}
  val(hs,fpc_Read_Text_UInt,code);
{$endif hascompilerproc}
  If code<>0 Then
   InOutRes:=106;
End;


{$ifdef hascompilerproc}
procedure fpc_Read_Text_Float(var f : Text; var v : ValReal); iocheck; [Public,Alias:'FPC_READ_TEXT_FLOAT']; compilerproc;
{$else hascompilerproc}
Function fpc_Read_Text_Float(var f : Text):ValReal;[Public,Alias:'FPC_READ_TEXT_FLOAT'];
{$endif hascompilerproc}
var
  hs : string;
  code : Word;
begin
{$ifdef hascompilerproc}
  v:=0.0;
{$else hascompilerproc}
  fpc_Read_Text_Float:=0.0;
{$endif hascompilerproc}
{ Leave if error or not open file, else check for empty buf }
  If (InOutRes<>0) then
   exit;
  if (TextRec(f).mode<>fmInput) Then
   begin
     case TextRec(f).mode of
       fmOutPut,fmAppend:
         InOutRes:=104
       else
         InOutRes:=103;
     end;
     exit;
   end;
  If TextRec(f).BufPos>=TextRec(f).BufEnd Then
   FileFunc(TextRec(f).InOutFunc)(TextRec(f));
  hs:='';
  if IgnoreSpaces(f) then
    ReadNumeric(f,hs);
{$ifdef hascompilerproc}
  val(hs,v,code);
{$else hascompilerproc}
  val(hs,fpc_Read_Text_Float,code);
{$endif hascompilerproc}
  If code<>0 Then
   InOutRes:=106;
end;


{$ifdef hascompilerproc}
procedure fpc_Read_Text_QWord(var f : text; var q : qword); iocheck; [public,alias:'FPC_READ_TEXT_QWORD']; compilerproc;
{$else hascompilerproc}
function fpc_Read_Text_QWord(var f : text) : qword;[public,alias:'FPC_READ_TEXT_QWORD'];
{$endif hascompilerproc}
var
  hs   : String;
  code : longint;
Begin
{$ifdef hascompilerproc}
  q:=0;
{$else hascompilerproc}
  fpc_Read_Text_QWord:=0;
{$endif hascompilerproc}
  { Leave if error or not open file, else check for empty buf }
  If (InOutRes<>0) then
   exit;
  if (TextRec(f).mode<>fmInput) Then
   begin
     case TextRec(f).mode of
       fmOutPut,fmAppend:
         InOutRes:=104
       else
         InOutRes:=103;
     end;
     exit;
   end;
  If TextRec(f).BufPos>=TextRec(f).BufEnd Then
   FileFunc(TextRec(f).InOutFunc)(TextRec(f));
  hs:='';
  if IgnoreSpaces(f) then
   ReadNumeric(f,hs);
{$ifdef hascompilerproc}
  val(hs,q,code);
{$else hascompilerproc}
  val(hs,fpc_Read_Text_QWord,code);
{$endif hascompilerproc}
  If code<>0 Then
   InOutRes:=106;
End;

{$ifdef hascompilerproc}
procedure fpc_Read_Text_Int64(var f : text; var i : int64); iocheck; [public,alias:'FPC_READ_TEXT_INT64']; compilerproc;
{$else hascompilerproc}
function fpc_Read_Text_Int64(var f : text) : int64;[public,alias:'FPC_READ_TEXT_INT64']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$endif hascompilerproc}
var
  hs   : String;
  code : Longint;
Begin
{$ifdef hascompilerproc}
  i:=0;
{$else hascompilerproc}
  fpc_Read_Text_Int64:=0;
{$endif hascompilerproc}
{ Leave if error or not open file, else check for empty buf }
  If (InOutRes<>0) then
   exit;
  if (TextRec(f).mode<>fmInput) Then
   begin
     case TextRec(f).mode of
       fmOutPut,fmAppend:
         InOutRes:=104
       else
         InOutRes:=103;
     end;
     exit;
   end;
  If TextRec(f).BufPos>=TextRec(f).BufEnd Then
   FileFunc(TextRec(f).InOutFunc)(TextRec(f));
  hs:='';
  if IgnoreSpaces(f) then
   ReadNumeric(f,hs);
{$ifdef hascompilerproc}
  Val(hs,i,code);
{$else hascompilerproc}
  Val(hs,fpc_Read_Text_Int64,code);
{$endif hascompilerproc}
  If code<>0 Then
   InOutRes:=106;
End;


{*****************************************************************************
                               Initializing
*****************************************************************************}

procedure OpenStdIO(var f:text;mode,hdl:longint);
begin
  Assign(f,'');
  TextRec(f).Handle:=hdl;
  TextRec(f).Mode:=mode;
  TextRec(f).Closefunc:=@FileCloseFunc;
  case mode of
    fmInput :
      TextRec(f).InOutFunc:=@FileReadFunc;
    fmOutput :
      begin
        TextRec(f).InOutFunc:=@FileWriteFunc;
        TextRec(f).FlushFunc:=@FileWriteFunc;
      end;
  else
   HandleError(102);
  end;
end;


{
  $Log$
  Revision 1.16  2001-11-21 14:51:33  jonas
    * fixed writing of empty ansistring with specified width (merged)

  Revision 1.15  2001/09/25 16:34:59  jonas
    * fixed seekeof() so that it doesn't move the current possition in the
      file anymore (merged)
    * seekeof() now only regards #26 as EOF marker if EOF_CTRLZ is defined
      (just like eof()) (merged)
    * very tiny optimization to read_array_as_pchar

  Revision 1.14  2001/08/23 14:28:36  jonas
    + tempcreate/ref/delete nodes (allows the use of temps in the
      resulttype and first pass)
    * made handling of read(ln)/write(ln) processor independent
    * moved processor independent handling for str and reset/rewrite-typed
      from firstpass to resulttype pass
    * changed names of helpers in text.inc to be generic for use as
      compilerprocs + added "iocheck" directive for most of them
    * reading of ordinals is done by procedures instead of functions
      because otherwise FPC_IOCHECK overwrote the result before it could
      be stored elsewhere (range checking still works)
    * compilerprocs can now be used in the system unit before they are
      implemented
    * added note to errore.msg that booleans can't be read using read/readln

  Revision 1.13  2001/08/22 20:49:18  peter
    * regenerated

  Revision 1.12  2001/08/19 11:23:10  peter
    * read_array fix merged

  Revision 1.11  2001/07/21 15:53:28  jonas
    * really fixed write_array this time :/ (merged)

  Revision 1.10  2001/07/16 13:53:21  jonas
    * correctly fixed potential buffer overrun in write_array

  Revision 1.9  2001/07/08 21:00:18  peter
    * various widestring updates, it works now mostly without charset
      mapping supported

  Revision 1.8  2001/06/27 21:37:38  peter
    * v10 merges

  Revision 1.7  2001/06/04 11:43:51  peter
    * Formal const to var fixes
    * Hexstr(int64) added

  Revision 1.6  2001/04/08 13:21:30  jonas
    * fixed potential buffer overflow in FPC_WRITE_TEXT_PCHAR_AS_ARRAY (merged)

  Revision 1.5  2001/03/21 23:29:40  florian
    + sLineBreak and misc. stuff for Kylix compatiblity

  Revision 1.4  2000/11/23 13:14:02  jonas
    * fix for web bug 1210 from Peter (merged)

  Revision 1.3  2000/07/14 10:33:10  michael
  + Conditionals fixed

  Revision 1.2  2000/07/13 11:33:46  michael
  + removed logs

}