Update copyright years.

[thirdparty/gcc.git] / gcc / m2 / gm2-libs-iso / TermFile.mod

(* TermFile.mod implement the ISO TermFile specification.

Copyright (C) 2009-2023 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.

This file is part of GNU Modula-2.

GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.

GNU Modula-2 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.  See the GNU
General Public License for more details.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  *)

IMPLEMENTATION MODULE TermFile ;


FROM ASCII IMPORT nul, lf, cr ;
FROM ChanConsts IMPORT ChanFlags ;
FROM RTio IMPORT GetDeviceId ;
FROM RTgenif IMPORT GenDevIF, InitGenDevIF ;
FROM RTdata IMPORT ModuleId, MakeModuleId, InitData, GetData, KillData ;
FROM IOChan IMPORT ChanExceptions, InvalidChan, CurrentFlags ;
FROM IOConsts IMPORT ReadResults ;
FROM Strings IMPORT Assign ;

FROM IOLink IMPORT DeviceId, DeviceTable, DeviceTablePtr, DeviceTablePtrValue, IsDevice,
                   AllocateDeviceId, RAISEdevException, MakeChan, UnMakeChan ;

FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
FROM Strings IMPORT Append ;


FROM SYSTEM IMPORT ADDRESS, ADR, LOC ;
FROM errno IMPORT geterrno ;
FROM ErrnoCategory IMPORT GetOpenResults ;

FROM RTgen IMPORT ChanDev, DeviceType, InitChanDev,
                  doLook, doSkip, doSkipLook, doWriteLn,
                  doReadText, doWriteText, doReadLocs, doWriteLocs,
                  checkErrno ;

FROM DynamicStrings IMPORT String, InitStringCharStar, CopyOut,
                           KillString ;

FROM termios IMPORT TERMIOS, InitTermios, KillTermios, tcgetattr,
                    tcsetattr, cfmakeraw, tcsnow ;


IMPORT libc ;


CONST
   O_RDONLY = 0 ;
   O_WRONLY = 1 ;

TYPE
   PtrToLoc   = POINTER TO LOC ;
   TermInfo   = POINTER TO RECORD
                              fd      : INTEGER ;
                              pushed  : CHAR ;
                              pushBack: BOOLEAN ;
                              old, new: TERMIOS ;
                           END ;

VAR
   mid: ModuleId ;
   did: DeviceId ;
   dev: ChanDev ;


(*
   InitTermInfo - creates a new TermInfo and initializes fields,
                  fd, and, pushed.
*)

PROCEDURE InitTermInfo (fd: INTEGER) : TermInfo ;
VAR
   t: TermInfo ;
BEGIN
   NEW(t) ;
   t^.fd := fd ;
   t^.pushBack := FALSE ;
   t^.new := InitTermios() ;
   t^.old := InitTermios() ;
   RETURN( t )
END InitTermInfo ;


(*
   KillTermInfo - deallocates memory associated with, t.
*)

PROCEDURE KillTermInfo (t: TermInfo) : TermInfo ;
BEGIN
   WITH t^ DO
      new := KillTermios(new) ;
      old := KillTermios(old)
   END ;
   DISPOSE(t) ;
   RETURN( NIL )
END KillTermInfo ;


(*
   getFd - return the file descriptor associated with, t.
*)

PROCEDURE getFd (t: TermInfo) : INTEGER ;
BEGIN
   RETURN( t^.fd )
END getFd ;


(*
   getPushBackChar - returns TRUE if a previously pushed back
                     character is available.  If TRUE then,
                     ch, will be assigned to the pushed back
                     character.
*)

PROCEDURE getPushBackChar (t: TermInfo; VAR ch: CHAR) : BOOLEAN ;
BEGIN
   WITH t^ DO
      IF pushBack
      THEN
         ch := pushed ;
         pushBack := FALSE ;
         RETURN( TRUE )
      ELSE
         RETURN( FALSE )
      END
   END
END getPushBackChar ;


(*
   setPushBackChar - attempts to push back, ch.  Only one character
                     may be pushed back consecutively.
*)

PROCEDURE setPushBackChar (t: TermInfo; ch: CHAR) : BOOLEAN ;
BEGIN
   WITH t^ DO
      IF pushBack
      THEN
         RETURN( FALSE )
      ELSE
         pushed := ch ;
         pushBack := TRUE ;
         RETURN( TRUE )
      END
   END
END setPushBackChar ;


PROCEDURE look (d: DeviceTablePtr;
                VAR ch: CHAR; VAR r: ReadResults) ;
BEGIN
   doLook(dev, d, ch, r)
END look ;


PROCEDURE skip (d: DeviceTablePtr) ;
BEGIN
   doSkip(dev, d)
END skip ;


PROCEDURE skiplook (d: DeviceTablePtr;
                    VAR ch: CHAR; VAR r: ReadResults) ;
BEGIN
   doSkipLook(dev, d, ch, r)
END skiplook ;


PROCEDURE lnwrite (d: DeviceTablePtr) ;
BEGIN
   doWriteLn(dev, d)
END lnwrite ;


PROCEDURE textread (d: DeviceTablePtr;
                    to: ADDRESS;
                    maxChars: CARDINAL;
                    VAR charsRead: CARDINAL) ;
BEGIN
   doReadText(dev, d, to, maxChars, charsRead)
END textread ;


PROCEDURE textwrite (d: DeviceTablePtr;
                     from: ADDRESS;
                     charsToWrite: CARDINAL);
BEGIN
   doWriteText(dev, d, from, charsToWrite)
END textwrite ;


PROCEDURE rawread (d: DeviceTablePtr;
                   to: ADDRESS;
                   maxLocs: CARDINAL;
                   VAR locsRead: CARDINAL) ;
BEGIN
   doReadLocs(dev, d, to, maxLocs, locsRead)
END rawread ;


PROCEDURE rawwrite (d: DeviceTablePtr;
                    from: ADDRESS;
                    locsToWrite: CARDINAL) ;
BEGIN
   doWriteLocs(dev, d, from, locsToWrite)
END rawwrite ;


(*
   doreadchar - returns a CHAR from the file associated with, g.
*)

PROCEDURE doreadchar (g: GenDevIF; d: DeviceTablePtr) : CHAR ;
VAR
   i : INTEGER ;
   fd: INTEGER ;
   t : TermInfo ;
   ch: CHAR ;
BEGIN
   t := GetData(d, mid) ;
   WITH d^ DO
      fd := getFd(t) ;
      IF NOT getPushBackChar(t, ch)
      THEN
         REPEAT
            i := libc.read(fd, ADR(ch), SIZE(ch))
         UNTIL i#0 ;
         IF i<0
         THEN
            errNum := geterrno()
         END
      END ;
      RETURN( ch )
   END
END doreadchar ;


(*
   dounreadchar - pushes a CHAR back onto the file associated with, g.
*)

PROCEDURE dounreadchar (g: GenDevIF; d: DeviceTablePtr; ch: CHAR) : CHAR ;
VAR
   fd: INTEGER ;
   t : TermInfo ;
BEGIN
   t := GetData(d, mid) ;
   WITH d^ DO
      fd := getFd(t) ;
      IF NOT setPushBackChar(t, ch)
      THEN
         RAISEdevException(cid, did, notAvailable,
                           'TermFile.dounreadchar: cannot push back more than one character consecutively')
      END ;
      RETURN( ch )
   END
END dounreadchar ;


(*
   dogeterrno - returns the errno relating to the generic device.
*)

PROCEDURE dogeterrno (g: GenDevIF; d: DeviceTablePtr) : INTEGER ;
BEGIN
   RETURN geterrno()
END dogeterrno ;


(*
   dorbytes - reads upto, max, bytes setting, actual, and
              returning FALSE if an error (not due to eof)
              occurred.
*)

PROCEDURE dorbytes (g: GenDevIF; d: DeviceTablePtr;
                    to: ADDRESS;
                    max: CARDINAL;
                    VAR actual: CARDINAL) : BOOLEAN ;
VAR
   fd: INTEGER ;
   t : TermInfo ;
   p : PtrToLoc ;
   i : INTEGER ;
BEGIN
   t := GetData(d, mid) ;
   WITH d^ DO
      IF max>0
      THEN
         p := to ;
         IF getPushBackChar(t, p^)
         THEN
            actual := 1 ;
            RETURN( TRUE )
         END ;
         fd := getFd(t) ;
         i := libc.read(fd, p, max) ;
         IF i>=0
         THEN
            actual := i ;
            RETURN( TRUE )
         ELSE
            errNum := geterrno() ;
            actual := 0 ;
            RETURN( FALSE )
         END
      END
   END
END dorbytes ;


(*
   dowbytes - 
*)

PROCEDURE dowbytes (g: GenDevIF; d: DeviceTablePtr;
                    from: ADDRESS;
                    nBytes: CARDINAL;
                    VAR actual: CARDINAL) : BOOLEAN ;
VAR
   fd: INTEGER ;
   t : TermInfo ;
   i : INTEGER ;
BEGIN
   t := GetData(d, mid) ;
   WITH d^ DO
      fd := getFd(t) ;
      i := libc.write(fd, from, nBytes) ;
      IF i>=0
      THEN
         actual := i ;
         RETURN( TRUE )
      ELSE
         errNum := geterrno() ;
         actual := 0 ;
         RETURN( FALSE )
      END
   END
END dowbytes ;


(*
   dowriteln - attempt to write an end of line marker to the
               file and returns TRUE if successful.
*)

PROCEDURE dowriteln (g: GenDevIF; d: DeviceTablePtr) : BOOLEAN ;
VAR
   a: ARRAY [0..1] OF CHAR ;
   i: CARDINAL ;
BEGIN
   a[0] := cr ;
   a[1] := lf ;
   RETURN( dowbytes(g, d, ADR(a), SIZE(a), i) AND (i=SIZE(a)) )
END dowriteln ;


(*
   iseof - returns TRUE if end of file is seen.
*)

PROCEDURE iseof (g: GenDevIF; d: DeviceTablePtr) : BOOLEAN ;
VAR
   ch: CHAR ;
BEGIN
   ch := doreadchar(g, d) ;
   WITH d^ DO
      IF errNum=0
      THEN
         ch := dounreadchar(g, d, ch) ;
         RETURN( FALSE )
      ELSE
         RETURN( TRUE )
      END
   END
END iseof ;


(*
   iseoln - returns TRUE if end of line is seen.
*)

PROCEDURE iseoln (g: GenDevIF; d: DeviceTablePtr) : BOOLEAN ;
VAR
   ch: CHAR ;
BEGIN
   ch := doreadchar(g, d) ;
   WITH d^ DO
      IF errNum=0
      THEN
         ch := dounreadchar(g, d, ch) ;
         RETURN( ch=lf )
      ELSE
         RETURN( FALSE )
      END
   END
END iseoln ;


(*
   iserror - returns TRUE if an error was seen on the device.
*)

PROCEDURE iserror (g: GenDevIF; d: DeviceTablePtr) : BOOLEAN ;
BEGIN
   RETURN( d^.errNum#0 )
END iserror ;


(*
   getname - assigns, a, to the device name of the terminal.
*)

PROCEDURE getname (d: DeviceTablePtr;
                   VAR a: ARRAY OF CHAR) ;
VAR
   s: String ;
BEGIN
   s := InitStringCharStar(libc.ttyname(0)) ;
   CopyOut(a, s) ;
   s := KillString(s)
END getname ;


(*
   freeData - disposes of, t.
*)

PROCEDURE freeData (t: TermInfo) ;
BEGIN
   t := KillTermInfo(t)
END freeData ;


(*
   handlefree - 
*)

PROCEDURE handlefree (d: DeviceTablePtr) ;
VAR
   t : TermInfo ;
   fd: INTEGER ;
   i : INTEGER ;
BEGIN
   t := GetData(d, mid) ;
   fd := getFd(t) ;
   i := libc.close(fd) ;
   checkErrno(dev, d) ;
   KillData(d, mid)
END handlefree ;


(*
   termOpen - attempts to open up the terminal device.  It fills
              in any implied flags and returns a result depending
              whether the open was successful.
*)

PROCEDURE termOpen (t: TermInfo; VAR flagset: FlagSet; VAR e: INTEGER) : OpenResults ;
VAR
   i: INTEGER ;
BEGIN
   WITH t^ DO
      IF NOT (rawFlag IN flagset)
      THEN
         INCL(flagset, textFlag)
      END ;
      IF NOT (echoFlag IN flagset)
      THEN
         INCL(flagset, interactiveFlag)
      END ;
      IF NOT (writeFlag IN flagset)
      THEN
         INCL(flagset, readFlag)
      END ;
      IF writeFlag IN flagset
      THEN
         fd := libc.open(ADR("/dev/tty"), O_WRONLY, 0600B)
      ELSE
         fd := libc.open(ADR("/dev/tty"), O_RDONLY)
      END ;
      IF tcgetattr(fd, new)=0
      THEN
      END ;
      IF tcgetattr(fd, old)=0
      THEN
         IF rawFlag IN flagset
         THEN
            cfmakeraw(new)
         END ;
         IF tcsetattr(fd, tcsnow(), new)=0
         THEN
         END
      END ;
      e := geterrno() ;
      RETURN( GetOpenResults(e) )
   END
END termOpen ;


(*
   RestoreTerminalSettings - 
*)

PROCEDURE RestoreTerminalSettings (cid: ChanId) ;
VAR
   d: DeviceTablePtr ;
   t: TermInfo ;
   e: INTEGER ;
BEGIN
   d := DeviceTablePtrValue(cid, did) ;
   t := GetData(d, mid) ;
   WITH t^ DO
      IF tcsetattr(fd, tcsnow(), old)=0
      THEN
      END
   END
END RestoreTerminalSettings ;


(*
   Open - attempts to obtain and open a channel connected to
          the terminal.  Without the raw flag, text is implied.
          Without the echo flag, line mode is requested,
          otherwise single character mode is requested.
          If successful, assigns to cid the identity of
          the opened channel, and assigns the value opened to res.
          If a channel cannot be opened as required, the value of
          res indicates the reason, and cid identifies the
          invalid channel.
*)

PROCEDURE Open (VAR cid: ChanId;
                flagset: FlagSet; VAR res: OpenResults) ;
VAR
   d: DeviceTablePtr ;
   t: TermInfo ;
   e: INTEGER ;
BEGIN
   MakeChan(did, cid) ;              (* create new channel *)
   d := DeviceTablePtrValue(cid, did) ;
   t := InitTermInfo(-1) ;
   res := termOpen(t, flagset, e) ;
   InitData(d, mid, t, freeData) ;   (* attach memory to device and module *)
   WITH d^ DO
      flags := flagset ;
      errNum := e ;
      doLook := look ;
      doSkip := skip ;
      doSkipLook := skiplook ;
      doLnWrite := lnwrite ;
      doTextRead := textread ;
      doTextWrite := textwrite ;
      doRawRead := rawread ;
      doRawWrite := rawwrite ;
      doGetName := getname ;
      doFree := handlefree
   END
END Open ;


(*
   IsTermFile - tests if the channel identified by cid is open to
                the terminal.
*)

PROCEDURE IsTermFile (cid: ChanId) : BOOLEAN ;
BEGIN
   RETURN( (cid # NIL) AND (InvalidChan() # cid) AND
           (IsDevice(cid, did)) AND
           ((readFlag IN CurrentFlags(cid)) OR
            (writeFlag IN CurrentFlags(cid))) )
END IsTermFile ;


(*
   Close - if the channel identified by cid is not open to the
           terminal, the exception wrongDevice is raised; otherwise
           closes the channel, and assigns the value identifying
           the invalid channel to cid.
*)

PROCEDURE Close (VAR cid: ChanId) ;
BEGIN
   IF IsTermFile(cid)
   THEN
      RestoreTerminalSettings(cid) ;
      UnMakeChan(did, cid) ;
      cid := InvalidChan()
   ELSE
      RAISEdevException(cid, did, wrongDevice,
                        'TermFile.' + __FUNCTION__ +
                        ': channel is opened to the terminal')
   END
END Close ;


(*
   Init - 
*)

PROCEDURE Init ;
VAR
   gen: GenDevIF ;
BEGIN
   MakeModuleId(mid) ;
   AllocateDeviceId(did) ;
   gen := InitGenDevIF(did,
                       doreadchar, dounreadchar,
                       dogeterrno, dorbytes, dowbytes,
                       dowriteln,
                       iseof, iseoln, iserror) ;
   dev := InitChanDev(term, did, gen)
END Init ;


BEGIN
   Init
END TermFile.