unit textfile;
{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}
(***************************************)
(* Copyright (C) 2013, SHIRAISHI Kazuo *)
(***************************************)


interface
uses  Classes,LCLVersion,
      SysUtils,Controls,Forms,ComCtrls, Clipbrd, LcLType, fileutil,Dialogs, math,
     {$IFNDEF LclGTK}printdlg, {$ENDIF}
     {$IFDEF Windows} Windows, {$ENDIF}
     {$IFDEF Unix} baseUnix,Unix,UnixType, {$ENDIF}
      base,arithmet,base2;

type
    Fnamestr=AnsiString;
type
    string1=string[1];
type
    TNewLine=class
    end;

   TNewZone=class
    end;

   TTab=class
         count:integer;
        constructor create(c:integer); overload;
        constructor create(b:double); overload;
       end;

type
   StringFunction =function(const s:String):String;

type
TTextDevice=class
  public
   Name:AnsiString;
   zonewidth:integer;
   margin:integer;
   TabCount:integer;
   leng:integer;
   EOL:string[2];
   AMode:AccessMode;
   OrgType:OrganizationType;
   isopen:boolean;
   EchoOn:boolean;
   prom2:ansistring;

   constructor create;
   procedure open(FName:FNameStr; am:AccessMode; og:OrganizationType; len:integer);virtual;
   procedure close;virtual;
   procedure erase(rs:tpRecordSetter;insideofwhen:boolean);virtual;
   procedure setpointer(rs:tpRecordSetter; insideofWhen:boolean);virtual;
   procedure AppendStr(const s:AnsiString);virtual;
   procedure AppendStrV2(const s:AnsiString);virtual;overload;   // s=''のときは空白を1個出力する
   procedure AppendStrV2(const x:Double);overload;
   procedure Tab(n:integer);
   procedure NewZone;
   procedure NewLine;
   procedure NewLineifneed;
   procedure flush;virtual;abstract;
   procedure WBuffClear;
   procedure WriteSeparator(ClaimNewLine:boolean);
   procedure setmargin(n:integer);
   procedure setzonewidth(n:integer);
   procedure setEndOfLine(const s:string);
   procedure setCoding(const s:string);virtual;
   function askmargin:integer;
   function askzonewidth:integer;
   function AskCharacterPending:integer;virtual;
   function AskFileSize:int64;virtual;
   procedure CheckForInput(option:IOoptions);
   procedure CheckForOutput(option:IOoptions);
   procedure initInput(LineNumb:integer;const prom:AnsiString; TimeLimit:double);virtual;
   procedure SetPrompt(const prom:ansistring);virtual;
   procedure CharacterInput(var s:AnsiString; option:IOoptions );virtual;abstract;
   function DataFoundForRead:integer;virtual;
   function DataFoundForWrite:integer;virtual;
   function choose(i1,i2,i3,i4:integer):integer;virtual;abstract;
   function RecType:RecordType;virtual;
   function Datum:AnsiString;virtual;
   function askpointer:Ansistring;virtual;
   function TrueFile:boolean;virtual;
   function AskTypeAhead:boolean;virtual;
   function inputData(list:TStringList; kindlist:ansistring; option:IOOptions):integer;
   function readData(list:TStringList; kindlist:ansistring; option:IOOptions):integer;
   procedure InputVariLen(list:TStringList; kindlist:ansistring; option:IOoptions; var count:integer);
   function LineInput(list:TStringList; count:integer; option:IOOptions):integer;
   // for Code Generate
   procedure Print(option:IOOptions; rs:tpRecordSetter; insideofWhen:boolean; args:array of const); virtual;
   procedure MatPrint(option:IOOptions; rs:tpRecordSetter; insideofWhen:boolean;args:array of const);virtual;
   procedure PrintUsing(const form:Ansistring; args:array of const; needNewLine:boolean; insideofwhen:boolean);
   procedure MatPrintUsing(const form:Ansistring; args:array of const; needNewLine:boolean; insideofwhen:boolean);
   procedure ValidateForWrite(option:IOOptions; rs:tpRecordSetter; insideofWhen:boolean);
   procedure formatsub(x:double;     var formatted:ansistring;const form:ansistring;
                           var i:integer;insideofwhen:boolean;TabCount0:integer);overload;
   procedure formatsub(n:Number;     var formatted:ansistring;const form:ansistring;
                           var i:integer;insideofwhen:boolean;TabCount0:integer);overload;
   procedure formatsub(s:AnsiString; var formatted:ansistring;const form:ansistring;
                           var i:integer;insideofwhen:boolean;TabCount0:integer);overload;
   procedure SetEcho(const s:string);
 protected
       WBuff:AnsiString;
       CurrentChar:string1;
       RBuff:AnsiString;
       rcp:integer;
       index:integer;
       index0:integer;
       extype:integer;
   function readNewLine:boolean;virtual;
   procedure  ReInput ;virtual;
   function ReadItem(var s:AnsiString; var quoted:boolean):boolean; virtual;
   function punctuate:boolean;virtual;
   function readline:boolean;virtual; abstract;
   procedure NextChar;virtual;
   function readEOL:boolean;virtual;
   procedure echo;virtual;
   procedure saveFilePos;virtual;
   function ReadByte:char;virtual;abstract;
end;

TTextDevice1=Class(TTextDevice)
   procedure setCoding(const s:string);override;
   procedure CharacterInput(var s:AnsiString; option:IOoptions);override;
   constructor create;
 protected
       importing,exporting:StringFunction;
end;

TTextfile=class(TTextDevice1)
 public
       //CharFile: file of char;
       CharFile:TFileStream;
       isDevice:boolean;
   constructor create;
   destructor destroy;override;
   procedure open(FName:FNameStr; am:AccessMode; og:OrganizationType; len:integer );override;
   procedure close;override;
   procedure erase(rs:tpRecordSetter; insideofwhen:boolean);override;
   procedure setpointer(rs:tpRecordSetter; insideofWhen:boolean );override;
   //procedure CharacterInput(var s:AnsiString; option:IOoptions);override;
   procedure flush;override;
   function DataFoundForRead:integer;override;
   function DataFoundForWrite:integer;override;
   function choose(i1,i2,i3,i4:integer):integer;override;
   function askpointer:Ansistring;override;
   function TrueFile:boolean;override;
   function AskFileSize:Int64;override;
   function AskCharacterPending:integer;override;
   function AskTypeAhead:boolean;override;
private
       exFilePos:Int64;
   function readline:boolean;override;
   procedure saveFilePos;override;
   function ReadByte:char;override;
end;



TInternalFile=class(TTextFile)
   function RecType:RecordType;override;
   procedure AppendStr(const s:AnsiString);override;
   procedure CharacterInput(var s:AnsiString; option:IOoptions);override;
   function Datum:AnsiString;override;
   function choose(i1,i2,i3,i4:integer):integer;override;
   function AskCharacterPending:integer;override;
   function AskTypeAhead:boolean;override;
   procedure AppendStrV2(const s:AnsiString);override;overload;   // 引用符で括る
   procedure Print(option:IOOptions; rs:tpRecordSetter; insideofWhen:boolean; args:array of const); override;
   procedure MatPrint(option:IOOptions; rs:tpRecordSetter; insideofWhen:boolean;args:array of const);override;

 private
   function readline:boolean;override;         //2007.5.7
   function punctuate:boolean;override;
   //procedure NextChar;override;              //2007.5.7
   //function readNewLine:boolean;override;    //2007.5.7
   //function readEOL:boolean;override;        //2007.5.7
end;



function formatDouble(x:Double; const form:ansiString; var index,code:integer):ansistring;


type
    TConsole=class(TTextDevice)
       constructor create;
       destructor destroy;override;
       procedure open(FName:FNameStr; am:AccessMode; og:OrganizationType; len:integer);override;
       procedure flush;override;
       procedure initInput(LineNumb:integer;const prom:AnsiString; TimeLimit:double);override;
       procedure SetPrompt(const prom:ansistring);override;
       procedure CharacterInput(var s:AnsiString; option:IOoptions);override;
       function choose(i1,i2,i3,i4:integer):integer;override;
       function AskCharacterPending:integer;override;
       function AskTypeAhead:boolean;override;
       function DataRequest:boolean;
    private
       function readline:boolean;override;
       procedure echo;override;
       procedure  ReInput ;override;
    end;



type


   TCSVfile=class(TInternalFile)
       function RecType:RecordType;override;
      private
       function punctuate:boolean;override;
    end;


    TLocalPrinter=class(TTextDevice)
     public
           TextBuff:AnsiString;
       constructor create;
       destructor destroy;override;
       procedure open(FName:FNameStr; am:AccessMode; og:OrganizationType; len:integer);override;
       procedure close;override;
       procedure flush;override;
       procedure erase(rs:tpRecordSetter; insideofwhen:boolean);override;
       procedure CharacterInput(var s:AnsiString; option:IOoptions);override;
       function choose(i1,i2,i3,i4:integer):integer;override;
      private
       procedure  closeexec;
   end;

{$IFDEF Windows}
   TCommfile=class(TTextDevice1)
           FHandle:THandle;
           Limit:TDateTime;
       constructor create;
       destructor destroy;override;
       procedure open(FName:FNameStr; am:AccessMode; og:OrganizationType; len:integer );override;
       procedure close;override;
       procedure erase(rs:tpRecordSetter; insideofwhen:boolean);override;
       procedure initInput(LineNumb:integer;const prom:AnsiString; TimeLimit:double);override;
       procedure CharacterInput(var s:AnsiString; option:IOoptions);override;
       procedure flush;override;
       function DataFoundForRead:integer;override;
       function DataFoundForWrite:integer;override;
       function choose(i1,i2,i3,i4:integer):integer;override;
       function askpointer:Ansistring;override;
       function TrueFile:boolean;override;
       function AskCharacterPending:integer;override;
       function AskTypeAhead:boolean;override;
     private
       function readline:boolean;override;
       procedure PortOpen(const FName:string);
       procedure readchar(var c:char);
       procedure transstring(s:string);
       function GetReceiveLength: Integer;
       procedure ClearReceiveBuf;
       procedure PortClose;
       function ReadByte:char;override;
   end;

function isCommPortName(const FName:string):LongBool;
{$ENDIF}



type
 TDataSeq=Class(TTextDevice)
   public
      Count:integer;
      List:PStringArray;      //const arrayへのポインタ
      labelnumbers:PIntArray;  //const arrayへのポインタ
      DataPointer:integer;
    constructor create(count0:integer; list0:PStringArray; Ln0:PIntArray);
    procedure Restore(LabelNumber:integer);
    function DataFoundForRead:integer;override;
    function choose(i1,i2,i3,i4:integer):integer;override;
    function readNewLine:boolean;override;
    function punctuate:boolean;override;
   private
    function ReadItem(var s:AnsiString; var quoted:boolean):boolean;override;
    function readEOL:boolean;override;
  end;



var
  console:TConsole=nil;
  LocalPrinter:TLocalPrinter=nil;
  CharinputRequest:boolean=false;

procedure ReportException(InsideOfWhen:boolean; t:integer);overload;
procedure ReportException(InsideOfWhen:boolean; t:integer; s:string);overload;


implementation
uses
     myutils,objlist,sconsts,
     format,arrays,mythread,baslib,
     mathc,mathd,arraysc,baslibc,Arraysd,
     inputdlg,charinp,textfrm,textout,graphlib;

procedure ReportException(InsideOfWhen:boolean; t:integer);
var
   s1,s2:string;
begin
  if InsideOfWhen  then
              setexception(t)
  else if console<>nil then
    begin
      str(t,s1);
      console.newline;
      console.appendStr('EXCEPTION '+s1+' raised.');
      console.NewLine;
      TextMode:=true;
   end;
end;

procedure ReportException(InsideOfWhen:boolean; t:integer; s:string);
var
   s1,s2:string;
begin
  if InsideOfWhen  then
              setexception(t)
  else if console<>nil then
    begin
      str(t,s1);
      console.newline;
      console.appendStr('EXCEPTION '+s1+' raised. '+s);
      console.NewLine;
      TextMode:=true;
   end;
end;

constructor TTextDevice.create;
begin
    inherited create;

    WBuff:='';
    name:='';
    margin:=MaxInt;
    zonewidth:=24;
    TabCount:=0;
    leng:=maxint;
    EOL:=SConsts.EOL;

end;


procedure TTextDevice.open(FName:FNameStr; am:AccessMode; og:OrganizationType; len:integer);
begin
end;

procedure TTextDevice.close;
begin
end;

procedure TTextDevice.erase(rs:tpRecordSetter; insideofwhen:boolean);
begin
    //if insideofwhen then setexception(7311);
   ReportException(insideofwhen, 7311, 'ERASE #');
end;


procedure TTextDevice.setpointer(rs:tpRecordSetter; insideofWhen:boolean);
begin
   if (rs<>rsNone) and insideofWhen then setexception(choose(7002,7002,7205,7205));
end;

procedure TTextDevice.saveFilePos;
begin
end;

procedure TTextDevice.AppendStrV2(const s:AnsiString);
begin
   if s='' then
      AppendStr(' ')
   else
      AppendStr(s)
end;



procedure TTextDevice.AppendStrV2(const x:Double);
var
    n:number;
    s:string;
    i:integer;
begin
   {$IFDEF FPC_HAS_EXTENDED}
    convert(x,n);
    s:=Dstr(n)+' ' ;
   {$ELSE}
    s:=FloatToStr(x)+' ';
   i:=pos('E',s);
   if (i>0) and (s[i+1]<>'-') then
          s:=copy(s,1,i)+'+'+copy(s,i+1,length(s));
   if (s<>'0') and (s[1]<>'-') then
          s:=' '+s;
   {$ENDIF}
    AppendStr(s);
    s:='';
end;


procedure TtextDevice.appendStr(const s:AnsiString);
begin

   if (TabCount>0) and (TabCount + length(s) > margin) then
      newLine;
   WBuff:=WBuff + s;
   TabCount:=TabCount+Length(s);

end;

function spaces(n:integer):ansistring;
const
   space32='                                ';
var
  q,r:integer;
begin
  result:='';
  if n>0 then
    begin
      q:=n div 32;
      r:=n mod 32;
      while q>0 do
          begin
             result:=result+space32;
             dec(q)
          end;
      result:=result + copy(space32,1,r);
    end;
end;

procedure TTextDevice.Tab(n:integer);
begin
   if (n<1) then
      n:=1      ;
   n:=(n-1) mod margin {+1} ;
   if TabCount>n then newline;
   appendstr(spaces(n-TabCount));
end;

procedure TTextDevice.setmargin(n:integer);
begin
    if RecType<>rcDisplay then setexception(7312);
    if aMode=amInput then setexception(7313);
    if n>=zonewidth then
       margin:=n
    else
       setexceptionwith(s_MarginError,4006);
end;

procedure TTextDevice.setzonewidth(n:integer);
begin
    if RecType<>rcDisplay then setexception(7312);
    if aMode=amInput then setexception(7313);
    if (n<=margin) and (n>0) then
        zonewidth:=n
    else
       setexceptionwith(s_ZoneWidthError,4007);
end;

procedure TTextDevice.setEndOfLine(const s:string);
begin
  if Length(s) in [1,2] then
     EOL:=s;
end;

procedure TTextDevice.setCoding(const s:string);
begin
  setexception(8999)
end;

procedure TTextDevice.NewZone;
var
   i,j:integer;
begin
   i:=TabCount mod zonewidth;
   if i>0 then
      begin
          j:=zonewidth-i;
          if TabCount+j<margin then
             appendstr(spaces(j))
          else
            newline     ;
      end;
end;

procedure TTextDevice.NewLine;
begin
   WBuff:=WBuff +  EOL ;
   flush;
   TabCount:=0;
end;

procedure TTextDevice.NewLineIfNeed;
begin
    if TabCount>0 then
       NewLine;
end;

procedure TTextDevice.WriteSeparator(ClaimNewLine:boolean);
begin
    if (OrgType=OrgStream) or ClaimNewLine then
        newline
    else
        AppendStr(',')
end;

function formatDouble(x:Double; const form:ansiString; var index,code:integer):ansistring;
var
  n:number;
begin
    convert(x,n);
    result:=formatnum(componentsN(n),form,index,code);
end;

function formatNumber(n:Number; const form:ansiString; var index,code:integer):ansistring;
begin
    result:=formatnum(componentsN(n),form,index,code);
end;



function TTextDevice.askmargin:integer;
begin
 askmargin:=margin
end;

function TTextDevice.askZonewidth:integer;
begin
 askzonewidth:=zonewidth
end;


procedure TTextDevice.WBuffClear;
begin
   WBuff:='';
end;

procedure TTextDevice.CheckForInput(option:IOoptions);
begin
    if not isopen then  setexception(7004);
    if not (ioReadWrite in option) and (rectype<>rcDisplay) then setexception(7318);
    if Amode=amOutput then  setexception(7303);
    if (orgType=orgStream) and (ioSkipRest in option) then setexception(7321);
end;

procedure TTextDevice.CheckForOutput(option:IOoptions);
begin
    if not isopen then  setexception(7004);
    if not (ioReadWrite in option) and (rectype<>rcDisplay) then setexception(7317);
    if Amode=amInput then  setexception(7302);
end;

procedure TTextDevice.initInput(LineNumb:integer;const prom:AnsiString; TimeLimit:double);
begin
end;

function addlist(list:TStringList; index:integer; s:ansiString; KindList:ansistring):boolean;
var
  n:number;
begin
   if KindList[index +1]='n' then
         NVal(s,n);   //test for numeric representation
   with list do
      if index<count then
         strings[index]:=s
      else
         add(s);
   result:=true;
end;

function AddListForRead(list:TStringList; index:integer; s:ansiString;
                        KindList:ansistring; isInternalCSV:boolean):boolean;
var
  n:number;
begin
   if KindList[index +1]='n' then
      if isInternalCSV and (s='') then
         s:='0'
      else
         ;//NVal(s,n);   //test for numeric representation
   with list do
      if index<count then
         strings[index]:=s
      else
         add(s);
   result:=true;
end;
{
function AddListWithNoTest(list:TStringList; index:integer; s:ansiString; KindList:ansistring):boolean;
begin
   with list do
      if index<count then
         strings[index]:=s
      else
         add(s);
   result:=true;
end;
}

function TTextDevice.inputData(list:TStringList;  kindlist:ansistring; option:IOoptions):integer;
var
   s:ansiString;
   quoted:boolean;
   count:integer;
begin
   result:=0;
   if rectype<>rcDisplay then setexception(7318);

    count:=Length(KindList);
    ReadNewLine;
    if extype<>0 then begin result:=extype; exit end;

    index0:=-1;
    index:=0;
    repeat
       prom2:='';
       try
         while (index<count) and (extype=0)  and
             ReadItem(s,quoted) and addlist(list, index, s, KindList)
              and ((index=count-1) or punctuate)  do
                      inc(index)   ;
       except
         on E:EExtype do
              extype:=E.ExType;
       end;
       if  (ioSkipRest in option) then
          while CurrentChar<>'' do nextchar;
       if (extype div 10)=100 then
             begin extype:=choose(1006,1007,1008,1008); prom2:='overflow ' end
       else if extype=1106 then
             begin extype:=choose(1053,1054,1105,1105); prom2:='overflow ' end
       else if (extype=4001) or (extype=8101) then
             begin extype:=choose(8101,8103,8101,8120); prom2:='syntax error' end
       else if (extype=0) and  not ReadEOL then
            begin prom2:='extra data'; extype:=choose(8013,8003,8013,8013) end
       else if (extype=0) and (index<count) then
             begin prom2:='too few data'; extype:=choose(8012,8002,8012,8012) end;
       if (prom2<>'') and not (ioWhenInside in option) then
                                                            ReInput;
    until (index=count) or (extype<>0);
    result:=extype
    //echo;
    //if extype>0 then setexception(extype);


end;



function TTextDevice.readData(list:TStringList;  kindlist:ansistring; option:IOoptions):integer;
var
   index:integer;
   s:ansiString;
   q:boolean;
   count:integer;
begin
    count:=Length(KindList);
    ReadNewLine;
    result:=extype;
    if extype<>0 then exit ;

    index:=0;
    try
       while (index<count) and (extype=0)
           and ReadItem(s,q)
           and AddListForRead(list,index,s,KindList,(self is TInternalFile) and (OrgType=OrgSeq))
           and ((index=count-1) or punctuate)  do
                   inc(index);
    except
      on E:EExtype do
           extype:=E.ExType;
    end;

    if extype=8001 then  begin result:=extype; exit end;            //Ver. 2.0.2.2
    if (extype=8101) then
       if (s='') and (self is TInternalFile)  then                 //Ver. 2.0.2.2
         with (self as TInternalFile).charfile do
            if (Orgtype<>orgSTREAM)or(position<size) then
               begin extype:=8120; result:=extype; exit end
             else
               begin extype:=8011; result:=extype; exit end
        else  {setexception(extype);}
               begin result:=extype; exit end;


    if (ioSkipRest in option) then
    while (CurrentChar<>'')and  not(CurrentChar[1] in [#13, #10]) do
                                                            nextchar;
    if (extype div 10) =100 then
               begin extype:=choose(1006,1008,1008,1008)  end;
    if extype=1106 then
               begin extype:=choose(1053,1105,1105,1105)  end;
    if extype=4001 then
                extype:=8101;   // choose(8101,8101,8101,8120);
    if extype=8102 then
                extype:=8105;
    if extype>0 then begin result:=extype; exit end;

    if index<count then
                     extype:=8012;
                     //setexception(8012);     //データ個数が不足

    if  not ReadEOL then
       if  CurrentChar=',' then
                     extype:=8013
                      //setexception(8013)     //データ個数が余分
       else
                     extype:=8105;
                      //setexception(8105);    //データの構文不正

    result:= extype
 end;

procedure TTextDevice.InputVariLen(list:TStringList;  kindlist:ansistring;
                                   option:IOoptions; var count:integer);
var
   s:ansiString;
   q:boolean;
begin
    if rectype<>rcDisplay then setexception(7318);

    ReadNewLine;
    index0:=-1;
    index:=0;
    repeat
         prom2:='';
           repeat
              if (length(KindList)<=index) then
                    setexception(5001);
              try
                if  ReadItem(s,q) and addlist(list,index,s,KindList) then
                  begin
                   count:=index+1;
                   if punctuate then
                    inc(index);
                  end;
              except
                 // extypeの値を残す
              end;
           until (CurrentChar='') or (extype<>0);

         if (extype>=1000) and (extype<1010) then
                     begin extype:=1007; prom2:='overflow ' end
         else if extype=1106 then
             begin extype:=choose(1053,1054,1105,1105); prom2:='overflow ' end
         else if extype=8101 then
               begin extype:=choose(8101,8103,8101,8120); prom2:='syntax error'  end
         else if currentchar<>'' then
               begin prom2:='extra data'; extype:=choose(8105,8102,8105,8120) end;
         if (prom2<>'') and not (ioWhenInside in option) then
               ReInput ;
    until (count=index+1) and (currentchar='') or (extype<>0);
    if extype>0 then setexception(extype);


end;

function TTextDevice.LineInput(list:TStringList; count:integer; option:IOOptions):integer;
begin
    if rectype<>rcDisplay then setexception(7318);
    result:=0;
    index:=0;
    while index<count do
        begin
          prom2:='';
          RBuff:='';
          if readline then List.add(RBuff);
          inc(index);
        end;
    if extype>0 then setexception(extype);


end;



procedure TTextDevice.SetPrompt(const prom:ansistring);
begin
end;


function TTextDevice.rectype:RecordType;
begin
   rectype:=rcDisplay
end;

function TTextDevice.Datum:AnsiString;
begin
  result:='UNKNOWN'
end;

function TTextDevice.askpointer:AnsiString;
begin
  result:='UNKNOWN'
end;

function TTextDevice.TrueFile:boolean;
begin
   result:=false
end;

procedure TTextDevice.SetEcho(const s:string);
begin
  if Uppercase(s)='ON' then
      echoOn:=true
  else if Uppercase(s)='OFF' then
      echoOn:=false
  else
      setexception(4103);

end;

function TTextDevice.AskCharacterPending:integer;
begin
  result:=-1
end;

function TTextDevice.AskFileSize:int64;
begin
  result:=0
end;

function TTextFile.AskFileSize:Int64;
begin
  Result:=CharFile.Size;
end;

function TTextDevice.AskTypeAhead:boolean;
begin
   result:=false
end;


function TTextDevice.ReadEOL:boolean;
begin
    result:=(CurrentChar='') and (rcp>length(RBuff));
end;

function TTextDevice.DataFoundForRead:integer;
begin
   result:=0;  //true
end;

function TTextDevice.DataFoundForWrite:integer;
begin
   result:=0;
end;

function TTextFile.DataFoundForRead:integer;
begin
   if isDevice then
      result:=0
   else
   begin
      try
        with CharFile do if Position<size then result:=0 else result:=7305;
      except
         on EExtype do raise;
         else setexception(7004)
      end;
   end;
end;

function TTextFile.DataFoundForWrite:integer;
begin
  result:=0;
  if isDevice then
     // result:=0
  else
     begin
        try
           with CharFile do
              if Position<Size then
                result:=7308;
        except
           on EExtype do raise;
           else  setexception(7004)
        end;
     end;
end;


function TTextFile.askpointer:ansistring;
begin
  if isOpen then
     if TrueFile then
       with CharFile do
         if Position>=Size then
            result:='END'
         else if Position=0 then
            result:='BEGIN'
         else
            result:='MIDDLE'
     else
        result:='UNKNOWN'
  else
     result:=''

end;

function TTextFile.TrueFile:boolean;
begin
  {$IFDEF Windows}
   result:= GetFileType((CharFile.handle)) =FILE_TYPE_DISK;
  {$ELSE}
   result:=not isDevice
  {$ENDIF}
end;


procedure TInternalFile.appendStr(const s:AnsiString);
begin
   WBuff:=WBuff + s;
   if length(WBuff)>leng then setexception(8301);
end;

function TInternalFile.punctuate:boolean;
begin
   result:=false;
   if (OrgType=orgSEQ) then
      begin
       result:=(CurrentChar=',');
       if result then nextChar;
      end
   else if (OrgType=orgSTREAM) then
     begin
       result:=readEOL and ReadNewLine;
     end;
end;

procedure  TTextDevice.ReInput;
begin
end;

Procedure TTextDevice.echo;
begin
end;


function TTextDevice.ReadNewLine:boolean;
begin
   result:=true;
   prom2:='';
   RBuff:='';
   ReadLine;
   rcp:=1;
   NextChar;
end;

procedure TTextDevice.NextChar;
begin
    CurrentChar:=copy(RBuff,rcp,1);
    if rcp<=length(RBuff) then inc(rcp);
end;

function TTextDevice.punctuate:boolean;
begin
    result:=CurrentChar=','  ;
    if result then
       begin
         nextChar;
         while (CurrentChar=' ') do NextChar ;       //space cut
         if currentChar='' then
            begin index0:=index; {echo;} setprompt('? ') ;ReadNewLine end;
       end;
end;


{****************}
{PRINT statements}
{****************}
 procedure TTextDevice.formatsub(x:double; var formatted:ansistring;const form:ansistring;
                               var i:integer;insideofwhen:boolean;TabCount0:integer);overload;
var
   j:integer;
   code:integer;
   exLen:integer;
begin
       if i>length(form) then
          begin
               AppendStr(formatted);
               newline;
               i:=1;
               formatted:='';
          end;

       {literals}
       formatted:=formatted +literals(form,i);

       {evaluate}

       {format an item}
        exLen:=length(formatted);
        formatted:=formatted + FormatDouble(x,form,i,code);
        if ((code=8203) or (code=8204)) then
            if insideofWhen then
                extype:=code
            else
              begin
                   AppendStr(formatted);
                   newline;
                   Tab(TabCount0 + Exlen);
                   AppendStrV2(x);
                   newline;
                   Tab(TabCount0);
                   for j:=1 to length(formatted) do formatted[j]:=' ';
              end;
     if extype=0 then
        formatted:=formatted +literals(form,i)
     else
        formatted:=''   ;
     if extype<>0 then setexception(extype);
end;

procedure TTextDevice.formatsub(n:Number; var formatted:ansistring;const form:ansistring;
                               var i:integer;insideofwhen:boolean;TabCount0:integer);overload;
var
   j:integer;
   code:integer;
   exLen:integer;
begin
       if i>length(form) then
          begin
               AppendStr(formatted);
               newline;
               i:=1;
               formatted:='';
          end;

       {literals}
       formatted:=formatted +literals(form,i);

       {evaluate}

       {format an item}
        exLen:=length(formatted);
        formatted:=formatted + FormatNumber(n,form,i,code);
        if ((code=8203) or (code=8204)) then
            if insideofWhen then
                extype:=code
            else
              begin
                   AppendStr(formatted);
                   newline;
                   Tab(TabCount0 + Exlen);
                   AppendStrV2(DStr(n));
                   newline;
                   Tab(TabCount0);
                   for j:=1 to length(formatted) do formatted[j]:=' ';
              end;
     if extype=0 then
        formatted:=formatted +literals(form,i)
     else
        formatted:=''   ;
     if extype<>0 then setexception(extype);
end;

procedure TTextDevice.formatsub(s:Ansistring; var formatted:ansistring;const form:ansistring;
                               var i:integer;insideofwhen:boolean;TabCount0:integer);overload;
var
   j:integer;
   code:integer;
   exLen:integer;
begin
       if i>length(form) then
          begin
               AppendStr(formatted);
               newline;
               i:=1;
               formatted:='';
          end;

       {literals}
       formatted:=formatted +literals(form,i);

       {evaluate}

       {format an item}
        exLen:=length(formatted);
        formatted:=formatted + formatStr(s,form,i,code);
        if ((code=8203) or (code=8204)) then
            if insideofWhen then
                extype:=code
            else
              begin
                   AppendStr(formatted);
                   newline;
                   Tab(TabCount0 + Exlen);
                   AppendStr(s);
                   newline;
                   Tab(TabCount0);
                   for j:=1 to length(formatted) do formatted[j]:=' ';
              end;
     if extype=0 then
        formatted:=formatted +literals(form,i)
     else
        formatted:=''   ;
     if extype<>0 then setexception(extype);
end;

 procedure TTextDevice.ValidateForWrite(option:IOOptions; rs:tpRecordSetter; insideofWhen:boolean);
 begin
    checkForOutput(option);
    Setpointer(rs,insideofWhen);
    extype:=DataFoundForWrite;
    if extype<>0 then
       setexceptionwith( s_DataFoundForWrite,extype);
 end;


var PRINTCriticalSection: TRTLCriticalSection;

PROCEDURE TTextDevice.Print(option:IOOptions; rs:tpRecordSetter; insideofWhen:boolean;  args:array of const);
var
   i:integer;
begin
   ValidateForWrite(option,rs, insideofwhen );
   EnterCriticalSection(PRINTCriticalSection);
   try
   try
     for i:=0 to High(args) do
       with args[i] do
        case VType of
          vtInteger:   AppendStrV2(VInteger);
          vtInt64:     AppendStrV2(VINT64^);
          vtExtended:  AppendStrV2(VExtended^);
          vtchar:      AppendStrV2(VChar);
          vtString:    AppendStrV2(VString^);
          vtAnsiString:AppendStrV2(string(VAnsiString));
          vtObject:begin
                       if VObject is TNewLine then
                          NewLine
                       else if VObject is TNewZone then
                          NewZone
                       else if VObject is TTab then
                          TAB(TTab(VObject).count)
                       else if VObject is TComplex then
                          AppendStrV2(TComplex(VObject).str)
                       else if VObject is TNumber then
                          AppendStrV2(TNumber(VObject).str);
                       VObject.free
                   end;
        end;
      flush
   except
     WBuffClear;
     raise
   end;
   finally
      LeaveCriticalSection(PRINTCriticalSection);
   end;


end;

procedure TTextDevice.MatPrint(option:IOOptions; rs:tpRecordSetter; insideofWhen:boolean; args:array of const);
var
   i:integer;
   d:integer;
   a:TArray;
begin
   ValidateForWrite(option,rs, insideofwhen );
   EnterCriticalSection(PRINTCriticalSection);
   try
   try
     i:=0;
     while i< High(args) do
       begin
         with args[i] do
           case VType of
             vtObject: a:=(VObject as TArray);
           end;
         inc(i);
         with args[i] do
           case VType of
             vtInteger: d:=Vinteger;
           end;
         inc(i);
         a.MatPrint(self,d);
       end;
      flush
   except
     WBuffClear;
     raise
   end;
   finally
      LeaveCriticalSection(PRINTCriticalSection);
   end;


end;

procedure TTextDevice.PrintUsing(const form:Ansistring; args:array of const; needNewLine:boolean; insideofwhen:boolean);
var
   formatted:ansistring;
   c:integer;
   TabCount0:integer;
   i:integer;
   t:char;
   x:double;
   s:ansistring;
   n:Number;
begin
  ValidateForWrite([],rsNone, insideofwhen );
  if not TestFormatString(form) then
                                     setexception(8201);

   formatted:='';
   i:=1;
   TabCount0:=TabCount;
   EnterCriticalSection(PRINTCriticalSection);
   try
   try
    for c:=0 to High(args) do
      begin
       with args[c] do
        case VType of
          vtInteger:   begin t:='x'; x:=VInteger end;
          vtInt64:     begin t:='x'; x:=VINT64^ end;
          vtExtended:  begin t:='x'; x:=VExtended^ end;
          vtchar:      begin t:='s'; s:=VChar end;
          vtString:    begin t:='s'; s:=VString^ end;
          vtAnsiString:begin t:='s'; s:=string(VAnsiString) end;
          vtObject:begin
                     if VObject is TNumber then
                        begin t:='n'; n:=(VObject as TNumber).value end;
                     VObject.free
                   end;
        end;
        if t='x' then
           formatsub(x,formatted,form,i,insideofwhen,TabCount0)
        else if t='n' then
           formatsub(n,formatted,form,i,insideofwhen,TabCount0)
        else if t='s' then
           formatsub(s,formatted,form,i,insideofwhen,TabCount0);
      end;

      AppendStr(formatted);
      if needNewline then newline;
      flush
  except
     WBuffClear;
     raise;
  end;
  finally
      LeaveCriticalSection(PRINTCriticalSection);
   end;

end;

procedure TTextDevice.MatPrintUsing(const form:Ansistring; args:array of const; needNewLine:boolean; insideofwhen:boolean);
var
   formatted:ansistring;
   c:integer;
   TabCount0:integer;
   i:integer;
   t:char;
   k:integer;
   a:TArray;
begin
   ValidateForWrite([],rsNone, insideofwhen );

   if not TestFormatString(form) then
                                     setexception(8201);
   formatted:='';
   i:=1;
   TabCount0:=TabCount;
   EnterCriticalSection(PRINTCriticalSection);
   try
   try
    for c:=0 to High(args) do
      begin
       with args[c] do
        case VType of
          vtObject:
             begin
               a:=(VObject as TArray);
               if a is TArray1N then
                 with a as TArray1N do
                     for k:=0 to size-1 do
                         formatsub(elements^[k],formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray2N then
                 with a as TArray2N do
                     for k:=0 to size-1 do
                         formatsub(elements^[k],formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray3N then
                 with a as TArray3N do
                     for k:=0 to size-1 do
                         formatsub(elements^[k],formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray4N then
                 with a as TArray4N do
                     for k:=0 to size-1 do
                         formatsub(elements^[k],formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray1S then
                 with a as TArray1S do
                     for k:=0 to size-1 do
                         formatsub(elements^[k],formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray2S then
                 with a as TArray2S do
                     for k:=0 to size-1 do
                         formatsub(elements^[k],formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray3S then
                 with a as TArray3S do
                     for k:=0 to size-1 do
                         formatsub(elements^[k],formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray4S then
                 with a as TArray4S do
                     for k:=0 to size-1 do
                         formatsub(elements^[k],formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray1C then
                 with a as TArray1C do
                     for k:=0 to size-1 do
                         formatsub(testreal(elements^[k]),formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray2C then
                 with a as TArray2C do
                     for k:=0 to size-1 do
                         formatsub(testreal(elements^[k]),formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray3C then
                 with a as TArray3C do
                     for k:=0 to size-1 do
                         formatsub(testreal(elements^[k]),formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray4C then
                 with a as TArray4C do
                     for k:=0 to size-1 do
                         formatsub((elements^[k]),formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray1D then
                 with a as TArray1D do
                     for k:=0 to size-1 do
                         formatsub((elements^[k]),formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray2D then
                 with a as TArray2D do
                     for k:=0 to size-1 do
                         formatsub((elements^[k]),formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray3D then
                 with a as TArray3D do
                     for k:=0 to size-1 do
                         formatsub((elements^[k]),formatted,form,i,insideofwhen,TabCount0)
               else if a is TArray4D then
                 with a as TArray4D do
                     for k:=0 to size-1 do
                         formatsub((elements^[k]),formatted,form,i,insideofwhen,TabCount0)
             end;
        end;
      AppendStr(formatted);
      if needNewline then newline;
      flush
    end;
  except
     WBuffClear;
     raise;
  end;
  finally
       LeaveCriticalSection(PRINTCriticalSection);
  end;


end;


constructor TTab.create(c:integer); overload;
begin
   inherited create;
   count:=c
end;

constructor TTab.create(b:double); overload;
begin
   inherited create;
   count:=LongIntRound(b)
end;


PROCEDURE TInternalFile.Print(option:IOOptions; rs:tpRecordSetter; insideofWhen:boolean;  args:array of const);
var
   i:integer;
begin
   ValidateForWrite(option,rs, insideofwhen );
   try
     for i:=0 to High(args) do
       begin
         with args[i] do
          case VType of
            vtInteger:   AppendStrV2(VInteger);
            vtInt64:     AppendStrV2(VINT64^);
            vtExtended:  AppendStrV2(VExtended^);
            vtchar:      AppendStrV2(VChar);
            vtString:    AppendStrV2(VString^);
            vtAnsiString:AppendStrV2(string(VAnsiString));
            vtObject:begin
                       if VObject is TNewLine then
                            NewLine
                       else if VObject is TNewZone then
                            WriteSeparator(false)
                       else if VObject is TComplex then
                          AppendStr(TComplex(VObject).str)
                       else if VObject is TNumber then
                          AppendStr(TNumber(VObject).str);
                       VObject.free
                     end;
          end;
       end;
      flush
   except
     WBuffClear;
     raise
   end;


end;

procedure TInternalFile.MatPrint(option:IOOptions; rs:tpRecordSetter; insideofWhen:boolean; args:array of const);
var
   i:integer;
   d:integer;
   a:TArray;
begin
   ValidateForWrite(option,rs, insideofwhen );
   try
     i:=0;
     while i< High(args) do
       begin
         with args[i] do
           case VType of
             vtObject: a:=(VObject as TArray);
           end;
         inc(i);
         with args[i] do
           case VType of
             vtInteger: d:=Vinteger;
           end;
         inc(i);
         a.MatWrite(self);
         if d<2 then
            WriteSeparator(false)
         else
            NewLine;
       end;
      flush
   except
     WBuffClear;
     raise
   end;
end;

function TInternalFile.rectype:RecordType;
begin
   rectype:=rcInternal
end;

procedure TInternalFile.CharacterInput(var s:AnsiString; option:IOoptions);
begin
  setexception(7451)
end;

function TTextDevice.ReadItem(var s:AnsiString; var quoted:boolean):boolean;
label L1;
begin
    result:=false;
    quoted:=false;
    s:='';
    while (CurrentChar=' ') do NextChar ;       //space cut
    if CurrentChar='"' then               // string constant
       begin
            quoted:=true;
            repeat
                NextChar;
                if (CurrentChar='"') then
                   begin
                       NextChar;
                       if CurrentChar<>'"' then goto L1;
                   end;
                s:=s + CurrentChar;
            until CurrentChar='';
            setexception(choose(8105,8102,8105,8120));
          L1:
            while CurrentChar=' ' do NextChar ;   //space cut
       end
    else
      begin
        While (CurrentChar<>'') and not (CurrentChar[1] in [#13, #10, ',']) do
           begin
              s:=s + CurrentChar;
              NextChar;
           end;
        while (length(s)>0) and (s[length(s)]=' ') do delete(s,length(s),1);
      end;
   result:=(extype=0)
end;

function TInternalFile.Datum:AnsiString;
var
   curChar:string[1];
   p:int64;
begin
  with CharFile do
    begin
      if Position>=Size then
         result:='NONE'
      else
         begin
            p:=Position;
            curchar:=currentchar;
            nextchar;
            while currentChar=' ' do nextChar;
            if currentchar='"' then
               result:='STRING'
            else
               result:='NUMERIC';
            seek(p,soFromBeginning);
            currentchar:=curchar;
         end;
    end;
end;



const
  BOM=#239#187#191;

function UTF8TOANSI(const s:string):string;
begin
   if COPY(s,1,3)=BOM then
      result:=UTF8TOANSI(COPY(s,4,Length(s)-3))
   else
      result:=System.Utf8ToAnsi(s)
end;

function ANSItoUTF8(const s:string):string;
begin
  result:=System.AnsiToUtf8(s)
end;

function Identity(const s:string):string;
begin
  result:=s
end;

constructor TTextDevice1.create;
begin
   inherited create;
   importing:=identity;
   exporting:=identity;
end;

procedure TTextDevice1.setCoding(const s:string);
begin
  if s='SYSTEM' then
  begin
     importing:=NativeToUTF8;
     exporting:=UTF8ToNative;
  end
  else if s='UTF-8' then
  begin
     importing:=identity;
     exporting:=identity;
  end
  else
    setexception(8999);
end;



function isTrueFile(s:string):boolean;
{$IFDEF Unix}
var
  buf: Stat;
begin
  result:=false;
  if (FPSTAT(PChar(s),buf)=0)          // 0.9.7.0_1
  and ((buf.st_mode and STAT_IFMT)=STAT_IFREG)then
    result:=true
end;
{$ELSE}
begin
   result:=true;  //dummy
end;
{$ENDIF}


function isDeviceName(const FName:string):LongBool;
var
   buf:array[0..255] of char;
begin
  {$IFDEF Windows}
   result:=(FName='PRN') or LongBool(QueryDosDevice(pchar(Utf8ToNative(Fname)),@buf,15));
  {$ELSE}
  result:=not isTrueFile(FName)
  {$ENDIF}
end;

procedure TTextFile.open(FName:FNameStr; am:AccessMode; og:OrganizationType; len:integer);
var
   IOR:integer;
   ermess:ansistring;
   mode:word;
begin
   if FName='' then setexception(7101);
   if isOpen   then setexception(7003);
   if (rectype=rcDISPLAY) and (og=orgSTREAM) then setexception(7101);
   if len<=0 then setexception(7051);
   name:=FName;
   leng:=len;
   margin:=len;
   if isDeviceName(FName) then
      isDevice:=true
   {$IFDEF Windows}
   else if (ExtractFileExt(FName)='') and not FileExists(FName) then
      Name:=Name+'.txt'
   {$ENDIF} ;   {Linuxでは，.txtの付加を行わない}

   AMode:=am;
   OrgType:=og;
   Case Amode of
     aminput:  if FileExists(FName) then
                  mode:=fmOpenRead +fmShareCompat
               else
                  setexceptionWith(Fname, 7102);
     else      if FileExists(FName) then
                  mode:=fmOpenReadWrite	 +fmShareCompat
               else
                  mode:=fmCreate +fmShareCompat ;
   end;
   try
      CharFile:=TFileStream.create(FName,mode);
   except
      On E:Exception do
           setExceptionWith(Fname+#13#10+E.message,7101);
   end;

   if Amode=amOutput then
      CharFile.Seek(0,soFromEnd);

   isOpen:=true;
   currentChar:='';
end;

procedure TTextFile.close;
begin
   if isOpen then
   begin
     isopen:=false;
     charfile.Free;
     CharFile:=nil;
   end;
end;



constructor TTextFile.create;
begin
   inherited create;
   WBuff:='';
end;


destructor TTextFile.destroy;
begin
    if isopen then close;
    inherited destroy;
end;


type TMyHandleStream=Class(THandleStream)
    Procedure SetSize1(size:Int64);
  end;

Procedure TMyHandleStream.SetSize1(size:int64);
begin
    SetSize(size)
end;

procedure TTextFile.erase(rs:tpRecordSetter; insideofwhen:boolean);
begin
    if not isopen then setexception(7004);
    if AMode=amOutIn then
       begin
         if rs=rsBegin then CharFile.Position:=0;
          with TMyHandleStream.Create(CharFile.Handle) do
             begin
              SetSize1(CharFile.Position);
              Free;
             end;
       end
    else
       setexception(7301) ;
end;

procedure TTextFile.setpointer(rs:tpRecordSetter; insideofWhen:boolean);
var
   errflag:boolean;
begin
  errflag:=false;
   if not isopen then setexception(7004);

   if isDevice then
   else
   try
     case rs of
      rsNone:  ;
      rsBEGIN: CharFile.Seek(0,soFromBeginning);
      rsEND:   CharFile.Seek(0,soFromEnd);
      rsSAME:  CharFile.Seek(exFilePos,soFromBeginning);
      rsNEXT:  Flush;
     end;
     saveFilePos;
     wbuff:='';
   except
       errflag:=true;
   end;
    if errflag then
       ReportException(InsideOfWhen,7205)
end;


procedure TTextFile.saveFilePos;
begin
   if not isDevice then
     exFilePos:=CharFile.Position
end;

 function TTextFile.readline:boolean;   //2011.4.24
  procedure TestEOFChar;
   var
      svFilePos:INT64;
      c:char;
   begin
      with CharFile do
        if Position<Size then
             begin
                svFilePos:=Position;
                Read(c,1);
                if (c=#26) and (position=size) then
                else
                   Position:=svFilePos
             end
   end;
var
   svFilePos:INT64;
   c:char;
   n:integer;
begin
    readline:=false;

    RBuff:='';
    with CharFile do
       begin
         svFilePos:=Position;
         n:=0;
         while (read(c,1)>0) and (c<>EOL[1]) do inc(n);
         Position:=svFilePos;
         SetLength(RBuff,n);
         read(Rbuff[1],n);
         if read(c,1)>0 then
            if (c=#13) and (read(c,1)>0) then
               if c=#10 then
                   TestEOFChar  // 次の文字がCtrl-Zでその次がEOFならCtrl-Z(1Ah)を読み飛ばす
               else
                   Position:=Position-1;
       end;
    RBuff:=importing(RBuff);
    readline:=(extype=0);
end;

procedure TInternalFile.AppendStrV2(const s:AnsiString);
begin
    AppendStr(AnsiQuotedStr(s,'"'))
end;


function TInternalFile.readline:boolean;           //2011.4.24
var
   svFilePos:INT64;
   c:char;
   n:integer;
begin
    readline:=false;
    RBuff:='';
    with CharFile do
        begin
          if position=size then
             begin extype:=8011; exit end;
          svFilePos:=Position;
          n:=0;
          while (read(c,1)>0) and (c in [#13,#10]) do
            begin
              inc(n);
              if c='"' then          // 引用符に囲まれた文字列を保護。
                repeat
                  inc(n);
                until (read(c,1)=0) or (c='"') ;
            end;

          Position:=svFilePos;
          SetLength(RBuff,n);
          read(Rbuff[1],n);
          if read(c,1)>0 then
             if (c=#13) and (read(c,1)>0) then
                if c<>#10 then
                    Position:=Position-1;

        end;
    RBuff:=importing(RBuff);
    readline:=(extype=0);
end;

Function TTextFile.ReadByte:char;
begin
   try
      CharFile.read(result,1)
   except
      setexception(7303);
   end
end;

{$IFNDEF Windows}
function isDBCSLeadByte(b:byte):boolean;
begin
  result:=b in [$80..$9F,$A1..$FE];
end;
{$ENDIF}


procedure TTextDevice1.CharacterInput(var s:ansistring; option:IOoptions);
var
  c:char;
begin
  c:=ReadByte;
  s:=c;
  if ioCharacterByte in option then
     exit
  {$IFDEF Windows}
  else if @importing<>@identity then
     begin
         if isDBCSLeadByte(byte(c))  then
                    s:=s+ReadByte;
         s:=Importing(s)
     end
  {$ENDIF}
  else    // UTF-8
     begin
        Case byte(c) of
          $c0 .. $df: s:=s+ReadByte;
          $e0 .. $ef: begin
                     s:=s+ReadByte;
                     s:=s+ReadByte;
                    end;
          $f0 .. $f7: begin
                     s:=s+ReadByte;
                     s:=s+ReadByte;
                     s:=s+ReadByte;
                    end;
        end;
     end;


end;



procedure TTextFile.flush;
var
   n:integer;
   s:string;
begin
   s:=exporting(WBuff);
   n:=length(s);
   try
      CharFile.Write(s[1],n);
   except
       setexception(9000);
   end;
   WBuffClear;
end;


function TTextFile.choose(i1,i2,i3,i4:integer):integer;
begin
   choose:=i3
end;

function TInternalFile.choose(i1,i2,i3,i4:integer):integer;
begin
   choose:=i4
end;


function TTextFile.AskCharacterPending:integer;
begin
  with CharFile do
     if Position>=Size then
        result:=0
     else
        result:=1
end;

function TInternalFile.AskCharacterPending:integer;
begin
  result:=-1
end;

function TInternalFile.AskTypeAhead:boolean;
begin
   result:=false
end;

function TTextFile.AskTypeAhead:boolean;
begin
   result:=true
end;






{********}
{TCONSOLE}
{********}

constructor TConsole.create;
begin
    inherited create;
    isopen:=true;
    margin:=InitialMargin;
    EchoOn:=true;
    with TextForm do
      begin
         if keepText then
             //SendMessage(memo1.Handle,EM_SETSEL,maxint,maxint)
             memo1.selstart:=length(memo1.lines.Text)   //要検討
         else
             memo1.clearAll;
         setReadOnly(true);
         if TextMode then
            begin
                   Visible:=True;
                   WindowState:=wsNormal;
                   Application.ProcessMessages;
                   BringToFront;
                   Application.ProcessMessages;
            end
         else
            Visible:=false;   //WindowState:=wsMinimized;
      end;
end;

destructor TConsole.destroy ;
begin
   with TextForm.memo1 do
      begin
         enabled:=true;
         if textmode then
             repaint;
      end;
   inherited destroy;
end;

procedure TConsole.open(FName:FNameStr; am:AccessMode; og:OrganizationType; len:integer);
begin
   setexception(7003);
end;


procedure TConsole.initInput(LineNumb:integer;const prom:AnsiString; TimeLimit:double);
begin
    InputDialog.LineNumber:=LineNumb;
    InputDialog.TimeLimit:=TimeLimit;
    CharInput.LineNumber:=LineNumb;
    CharInput.TimeLimit:=TimeLimit;
    RBuff:='';
    CurrentChar:='';
    rcp:=0;
    setPrompt(prom);
    prom2:='';
end;

procedure TConsole.SetPrompt(const prom:ansistring);
begin
     InputDialog.Label1.Caption:=prom;
     CharInput.label1.caption:=prom;
end;

function TConsole.ReadLine:boolean;
begin
   ReadLine:=DataRequest;
 end;


procedure  TConsole.ReInput;
begin
   extype:=0;
   index:=index0 + 1 ;
   DataRequest;
   rcp:=1;
   nextchar;
end;

Procedure TConsole.echo;
begin
    if EchoOn then
      begin
          if prom2<>'' then
          begin
            appendstr(prom2);
            newline
          end;
          appendstr(InputDialog.Label1.Caption);
          appendStr(Rbuff);
          newline
      end;
end;

(*
function  TConsole.DataRequest:boolean;
label
  L1;
begin
    wait(0.05);
    WaitReady;
    with InputDialog do
       begin
         Edit1.Text:=RBuff;
         Label2.caption:=prom2;
 L1:   //execute;    //CLXでExecuteを実行するとHangする
      //ShowModal;
      //  Execute;
       ConsoleInputRequest:=true;
       While ConsoleInputRequest do sleep(100);

       if not frag then setexception(8401);  // Time out
        if modalresult<>mrOk then
              if MessageDlg(s_ConfirmAbort,mtConfirmation,[mbYes,mbNo],0)=mrYes then
                   raise EParStop.create
              else
                   goto L1 ;
         RBuff:=edit1.text;
        end;
    echo;
    DataRequest:=(extype=0);
 end;
*)

function  TConsole.DataRequest:boolean;
var
  cont:boolean;
begin
    wait(0.05);
    WaitReady;
    with InputDialog do
       begin
         Edit1.Text:=RBuff;
         Label2.caption:=prom2;
         cont:=false;
         repeat
            ConsoleInputRequest:=true;
            While ConsoleInputRequest do sleep(100);
            if not frag then setexception(8401);  // Time out
            cont:=(modalresult=mrOk);
            if not cont
               and (confirm_s(s_ConfirmAbort)='YES')  then
               raise EParStop.create ;
         until cont;
         RBuff:=edit1.text;
        end;
    echo;
    DataRequest:=(extype=0);
 end;
procedure TConsole.CharacterInput(var s:ansistring; option:IOoptions);
var
  t:AnsiString;
begin
  wait(0.05);
  WaitReady;
  charInput.option:=option;
  CharacterInputRequest:=true;
  While CharacterInputRequest do (TThread.CurrentThread).Yield;
  t:=charInput.c1;
  if charinput.Timeout then setexception(8401);
  if echoOn then
         if t<>'' then begin appendstr(t);flush; end;  //2018/09/18
  if t<>'' then s:=t;
end;

procedure TConsole.flush;
begin
   //TextForm.AppendString(WBuff);
   Drop(Wbuff);
   WBuffClear;
end;


{*********}
{TTextFile}
{*********}










function TCSVFile.punctuate:boolean;
begin
   result:=(CurrentChar=',');
   if result then
       nextChar
   else
       result:=readEOL and ReadNewLine;  //ver 7.5.1
end;


function TCSVFile.rectype:RecordType;
begin
   rectype:=rcCSV
end;




function TConsole.choose(i1,i2,i3,i4:integer):integer;
begin
   choose:=i2
end;


function TConsole.AskCharacterPending:integer;
begin
  result:=length(charinput.c) ;
end;



function TConsole.AskTypeAhead:boolean;
begin
   result:=true
end;

{*************}
{Local Printer}
{*************}


constructor TLocalPrinter.create;
begin
  inherited create;
  AMode:=amOUTPUT;
  TextBuff:='';
  EchoOn:=false;
end;

destructor TLocalPrinter.destroy;
begin
   if TextBuff<>'' then close;
   inherited destroy
end;

procedure TLocalPrinter.open(FName:FNameStr; am:AccessMode; og:OrganizationType; len:integer);
begin
     isOpen:=true;
end;

procedure TLocalPrinter.close;
begin
  isOpen:=false;
  if TextBuff='' then exit;
  TmyThread(TThread.CurrentThread).SyncExec(closeexec);
end;

procedure TLocalPrinter.closeexec;
var
  Lines:TStringList;
begin
  Lines:=TStringList.Create;
  try
    try
         Lines.text:=TextBuff;
         {$IFNDEF LclGtk}
         with TPrintDialog1.create(TextForm) do
         begin
            if ShowModal=mrOk then
               PrintMemo(Lines);
            free;
         end;
         {$ENDIF}
        Lines.Text:='';
        TextBuff:='';
    finally
      lines.Free;
    end;
  except
    on E:Exception do
       MessageDlg('Printer Error'+EOL+E.Message, mtError, [mbOK], 0)
  end;
end;

procedure TLocalPrinter.flush;
begin
    TextBuff:=TextBuff + WBuff;
    WBuff:='';
end;

procedure TLocalPrinter.CharacterInput(var s:AnsiString; option:IOoptions);
begin
  setexception(7451)
end;

function TLocalPrinter.choose(i1,i2,i3,i4:integer):integer;
begin
   result:=i3
end;

procedure TLocalPrinter.erase(rs:tpRecordSetter; insideofwhen:boolean);
begin
   TextBuff:=''
end;




{***************}
{DATA statements}
{***************}
constructor TDataSeq.create(count0:integer; list0:PStringArray; Ln0:PIntArray);
begin
   inherited create;
   isOpen:=true;
   count:=count0;
   list:=list0;
   LabelNumbers:=Ln0;
   DataPointer:=0;
end;

procedure TDataSeq.Restore(LabelNumber:integer);
begin
   DataPointer:=0;
   if LabelNumber>0 then
      while (DataPointer<count) and (LabelNumbers^[DataPointer]<>LabelNumber) do
         inc(DataPointer);
end;

function TDataSeq.DataFoundForRead:integer;
begin
   if (List<>nil) and (DataPointer<count) then
      result:=0
   else
      result:=8001;
end;

function TDataSeq.ReadItem(var s:AnsiString; var quoted:boolean):boolean;
begin
    quoted:=false;
    if DataPointer<count then
       begin
          s:=List^[DataPointer];
          inc(DataPointer) ;
          if (length(s)>0) and (s[1]='"') then
             begin
                quoted:=true;
                delete(s,1,1)
             end
       end
    else
       begin
          extype:=8001;  //setexception(8001);     //Ver. 2.0.8.0.1.3
          s:=''  ;
      end;
    ReadItem:=(extype=0);
 end;

function TDataSeq.choose(i1,i2,i3,i4:integer):integer;
begin
   choose:=i1
end;

function TDataSeq.readNewLine:boolean;
begin
   result:=true;
end;
function TDataSeq.punctuate:boolean;
begin
   result:=true;
end;

function TDataSeq.readEOL:boolean;
begin
   result:=true;
end;



{$IFDEF Windows}
{**********}
{*TCOMFILE*}
{**********}
type
ECommError = class(Exception);


constructor TCommFile.create;
begin
   inherited create;
   WBuff:='';
   FHandle := INVALID_HANDLE_VALUE;        // ハンドルを初期化
end;

destructor TCommFile.destroy;
begin
    if isopen then close;
    inherited destroy;
end;

function ExtractPortName(const FName:string):string;
var
   p:integer;
begin
   p:=pos(':',Fname);
   if p>4 then
      result:=copy(FName,1,p-1)
   else
      result:=Fname;
end;

{$IFDEF Windows}
function isCommPortName(const FName:string):LongBool;
var
    size:dword;
    lpCC:TCOMMCONFIG;
begin
  size:=sizeOf(lpCC);
  result:=GetDefaultCommConfig(pchar(ExtractPortName(FName)),lpCC,size)
end;
{$ENDIF}


procedure TCommFile.open(FName:FNameStr; am:AccessMode; og:OrganizationType; len:integer);
var
   ermess:ansistring;
   s:string;
begin
   if FName='' then setexception(7101);
   if isOpen   then setexception(7003);
   if (rectype=rcDISPLAY) and (og=orgSTREAM) then  setexception(7101);
   if len<=0 then setexception(7051);

   name:=uppercase(FName);
   leng:=len;
   margin:=len;

   AMode:=am;
   OrgType:=og;

   try
     portopen(name);
   except
     on E:exception do
     setexceptionWith(E.Message,7101);
   end;

   isOpen:=true;
   currentChar:='';
end;

procedure TCommFile.close;
begin
   if isOpen then
   begin
     isOpen:=false;
     PortClose;
   end;
end;

procedure TCommFile.erase(rs:tpRecordSetter; insideofwhen:boolean);
begin
  //if insideofWhen then
  //   setexception(7301);
  ReportException(insideofwhen, 7301, 'ERASE #');
end;

function TCommFile.readline:boolean;
var
   i:integer;
   c,c1:char;
   n:integer;
begin

    readline:=false;

    RBuff:='';

    while true do
      begin
        readchar(c);
        if c=EOL[1] then
           break
        else
           //RBuff:=RBuff + c
           begin
                n:=Length(Rbuff);
                inc(n);
                SetLength(Rbuff,n);
                Rbuff[n]:=c;
           end;
      end;
    if (c=EOL[1]) and (length(EOL)=2) then
       readChar(c);

    RBuff:=Importing(RBuff);
    readline:=(extype=0);
end;

procedure TCommFile.CharacterInput(var s:ansistring; option:IOoptions);
var
   e:boolean;
   c:char;
   b:byte;
begin


    if ioClear in option then
          ClearReceiveBuf;
    if not (ioNoWait in option) or (GetReceiveLength>0) then
    begin
      try
        readchar(c);
        s:=c;
        if not (ioCharacterByte in option) then
          begin
           b:=Byte(c);
           if b>=$c0 then
              if b<$e0 then
                 begin
                   read(c);s:=s+c;
                 end
              else if b<$f0 then
                 begin
                   read(c);s:=s+c;
                   read(c);s:=s+c;
                 end
              else if b<$f8 then
                 begin
                   read(c);s:=s+c;
                   read(c);s:=s+c;
                   read(c);s:=s+c;
                 end
              else if b<$fc then
                 begin
                   read(c);s:=s+c;
                   read(c);s:=s+c;
                   read(c);s:=s+c;
                   read(c);s:=s+c;
                 end
              else if b<$fe then
                 begin
                   read(c);s:=s+c;
                   read(c);s:=s+c;
                   read(c);s:=s+c;
                   read(c);s:=s+c;
                   read(c);s:=s+c;
                 end
          end;
      except
            setexception(7303)
      end;
    end;
end;

procedure TCommFile.flush;
var
   i:integer;
   s:string;
begin
   s:=exporting(WBuff);
   try
     TransString(s)
   except
       setexception(9000);
   end;
   WBuffClear;
end;

function TCommFile.DataFoundForRead:integer;
begin
   result:=0;
end;

function TCommFile.DataFoundForWrite:integer;
begin
   result:=0;
end;

function TCommFile.askpointer:ansistring;
begin
     result:=''
end;

function TCommFile.TrueFile:boolean;
begin
   result:=false;
end;

function TCommFile.choose(i1,i2,i3,i4:integer):integer;
begin
   choose:=i3
end;

function TCOMMFile.AskCharacterPending:integer;
begin
  result:=GetReceiveLength
end;

function TCommFile.AskTypeAhead:boolean;
var
  CommProp:TCommProp;
begin
  result:=false;
  if GetCommProperties(FHandle,CommProp) then
     result:=CommProp.dwCurrentRxQueue>0;
end;

procedure TCommFile.PortOpen(const FName:string);
var
  lpCC:TCOMMCONFIG;
  size:dWord;
  LPCommProp:TCommProp;
  LPCOMMTIMEOUTs:TCOMMTIMEOUTs;
  SubName:string;
begin
  if (FHandle <> INVALID_HANDLE_VALUE) or (FName='') then begin
    raise ECommError.Create('');
  end;

  subName:=ExtractPortName(FName);
  if (Length(subName)>=5) and (uppercase(copy(subName,1,3))='COM')
     and (subName[4] in ['1'..'9']) and (subName[5] in ['0'..'9'])
     and ((Length(subName)=5) or (subName[6] in ['0'..'9'])) then
     subName:='\\.\' + subName;

  FHandle := CreateFile(Pchar(SubName),
                        GENERIC_READ or GENERIC_WRITE,// 読み書きアクセス
                        0,                            // 共有の対象としない
                        Nil,                          // セキュリティ属性なし
                        OPEN_EXISTING,                // オープン（通信では必ずこの設定）
                        FILE_FLAG_OVERLAPPED,         // オーバーラップ入出力を行う
                        0);                           // テンプレートファイルアクセスなし

  if FHandle = INVALID_HANDLE_VALUE then begin
    raise ECommError.Create(FName+s_FailedOpen);
  end;

  //SetBufferLength;                               // 送受信バッファ長の設定

  GetCommState(FHandle,lpCC.DCB);
  size:=sizeOf(lpCC);
  if GetDefaultCommConfig(PChar(ExtractPortName(FName)),lpCC,size)
     and ((pos(':',Fname)=0) or BuildCommDCB(PChar(FName),lpCC.DCB))
     and SetCommState(FHandle,lpCC.DCB) then
  else
     begin
        PortClose;
        raise ECommError.Create(FName + s_FailedOpen);
     end;

  GetCommTimeOuts(FHandle,LPCOMMTIMEOUTs);
  LPCOMMTIMEOUTS.ReadIntervalTimeout:=0;
  LPCOMMTIMEOUTS.ReadTotalTimeoutConstant:=0;
  SetCommTimeOuts(FHandle,LPCOMMTIMEOUTs);


end;

procedure TCommFile.PortClose;
var
  Msg     : TMsg;
  Handle  : THandle;
begin
  if FHandle <> INVALID_HANDLE_VALUE then
  begin
    CloseHandle(FHandle);                               // 通信ポートをクローズ
    FHandle := INVALID_HANDLE_VALUE;
  end;
end;


procedure TcommFile.readchar(var c:char);
var
    NumberOfBytes:DWord;
    TransSize:DWord;
    EventHandle  : THandle;
    Overlap     : TOVERLAPPED;           // オーバーラップ構造体
begin
  EventHandle := CreateEvent(Nil, True, False, Nil);
  with OverLap do
   begin
    Internal := 0;
    InternalHigh := 0;
    Offset := 0;
    OffsetHigh := 0;
    hEvent := EventHandle;
   end;
  c:=#0;
  try
    if not ReadFile(FHandle,c,1,NumberOfBytes,@OverLap) then
        while not ( GetOverlappedResult(FHandle, OverLap, TransSize, false)
                    or (now>Limit) ) do
           begin sleep(40); end;
  finally
    closeHandle(EventHandle);
  end;
  if Now>limit then
         setexception(8401);
end;

function TCommFile.ReadByte:char;
begin
  try
   readchar(result)
  except
    setexception(7303)
  end;
end;

procedure TcommFile.transstring(s:string);
var
    EventHandle  : THandle;
    DataSize,TransSize:DWord;
    Overlap     : TOVERLAPPED;           // オーバーラップ構造体
begin
  EventHandle := CreateEvent(Nil, True, False, Nil);     // 書き込み完了イベントオブジェクト
  with OverLap do begin
    Internal := 0;
    InternalHigh := 0;
    Offset := 0;
    OffsetHigh := 0;
    hEvent := EventHandle;
  end;
  DataSize:=length(s);
  try
    if DataSize>0 then
    begin
      if not WriteFile(FHandle, s[1], DataSize, TransSize, @OverLap) then
      while not (GetOverlappedResult(FHandle, OverLap, TransSize, false) )do
         begin sleep(40) end;
    end;
  finally
    closeHandle(EventHandle);
  end;
  if extype=-1 then
         raise EParStop.create;
end;

function TCommFile.GetReceiveLength: Integer;
var
  ErrorMask : DWORD;        // エラーコード
  ComStat   : TCOMSTAT;     // 通信状態
begin
  if FHandle <> INVALID_HANDLE_VALUE then begin
    ClearCommError(FHandle, ErrorMask, @ComStat);
    Result := ComStat.cbInQue;
  end
  else begin
    Result := 0;
  end;
end;

procedure TCommFile.ClearReceiveBuf;
begin
  if FHandle <> INVALID_HANDLE_VALUE then begin
    PurgeComm(FHandle, PURGE_RXABORT or PURGE_RXCLEAR);
  end;
end;


procedure TCommFile.initInput(LineNumb:integer;const prom:AnsiString; TimeLimit:double);
begin
    Limit:=TimeLimit;
end;
{$ENDIF}

initialization
  InitCriticalSection(PRINTCriticalSection);

finalization
  DoneCriticalSection(PRINTCriticalSection);


end.
