gcc/m2/gm2-libs/IO.mod

   1 (* IO.mod provides Read, Write, Errors procedures mapping onto 0, 1 and 2.
   2
   3 Copyright (C) 2001-2023 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   8 GNU Modula-2 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 GNU Modula-2 is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  *)
  26
  27 IMPLEMENTATION MODULE IO ;
  28
  29
  30 FROM StrLib IMPORT StrCopy ;
  31 FROM SYSTEM IMPORT ADR, SIZE ;
  32 FROM libc IMPORT read, write, system, isatty ;
  33
  34 FROM FIO IMPORT File, StdIn, StdOut, StdErr, WriteChar, ReadChar,
  35                 GetUnixFileDescriptor, FlushBuffer ;
  36
  37 FROM errno IMPORT geterrno, EINTR, EAGAIN ;
  38 FROM ASCII IMPORT cr, eof, nl;
  39 FROM termios IMPORT TERMIOS, Flag, InitTermios, KillTermios,
  40                     SetFlag, tcgetattr, tcsetattr, cfmakeraw,
  41                     tcsdrain, tcsnow, tcsflush ;
  42
  43
  44 CONST
  45    MaxDefaultFd = 2 ;
  46
  47 TYPE
  48    BasicFds = RECORD
  49                  IsEof,
  50                  IsRaw: BOOLEAN ;
  51               END ;
  52
  53 VAR
  54    fdState: ARRAY [0..MaxDefaultFd] OF BasicFds ;
  55
  56
  57 (*
  58    IsDefaultFd - returns TRUE if, fd, is 0, 1 or 2.
  59 *)
  60
  61 PROCEDURE IsDefaultFd (fd: INTEGER) : BOOLEAN ;
  62 BEGIN
  63    RETURN( (fd<=MaxDefaultFd) AND (fd>=0) )
  64 END IsDefaultFd ;
  65
  66
  67 PROCEDURE Read (VAR ch: CHAR) ;
  68 VAR
  69    r: INTEGER ;
  70 BEGIN
  71    WITH fdState[0] DO
  72       FlushBuffer(StdOut) ;
  73       FlushBuffer(StdErr) ;
  74       IF IsRaw
  75       THEN
  76          IF IsEof
  77          THEN
  78             ch := eof
  79          ELSE
  80             LOOP
  81                r := read(GetUnixFileDescriptor(StdIn), ADR(ch), 1) ;
  82                IF r=1
  83                THEN
  84                   RETURN
  85                ELSIF r=-1
  86                THEN
  87                   r := geterrno() ;
  88                   IF r#EAGAIN
  89                   THEN
  90                      IsEof := TRUE ;
  91                      ch := eof ;
  92                      RETURN
  93                   END
  94                END
  95             END
  96          END
  97       ELSE
  98          ch := ReadChar(StdIn)
  99       END
 100    END
 101 END Read ;
 102
 103
 104 (*
 105    doWrite - performs the write of a single character, ch,
 106              onto fd or f.
 107 *)
 108
 109 PROCEDURE doWrite (fd: INTEGER; f: File; ch: CHAR) ;
 110 VAR
 111    r: INTEGER ;
 112 BEGIN
 113    WITH fdState[fd] DO
 114       IF IsRaw
 115       THEN
 116          IF NOT IsEof
 117          THEN
 118             LOOP
 119                r := write(GetUnixFileDescriptor(f), ADR(ch), 1) ;
 120                IF r=1
 121                THEN
 122                   RETURN
 123                ELSIF r=-1
 124                THEN
 125                   r := geterrno() ;
 126                   IF (r#EAGAIN) AND (r#EINTR)
 127                   THEN
 128                      IsEof := TRUE ;
 129                      RETURN
 130                   END
 131                END
 132             END
 133          END
 134       ELSE
 135          WriteChar(f, ch)
 136       END
 137    END
 138 END doWrite ;
 139
 140
 141 PROCEDURE Write (ch: CHAR) ;
 142 BEGIN
 143    doWrite(1, StdOut, ch)
 144 END Write ;
 145
 146
 147 PROCEDURE Error (ch: CHAR) ;
 148 BEGIN
 149    doWrite(2, StdErr, ch)
 150 END Error ;
 151
 152
 153 (*
 154    setFlag - sets or unsets the appropriate flag in, t.
 155 *)
 156
 157 PROCEDURE setFlag (t: TERMIOS; f: Flag; b: BOOLEAN) ;
 158 BEGIN
 159    IF SetFlag(t, f, b)
 160    THEN
 161    END
 162 END setFlag ;
 163
 164
 165 (*
 166    doraw - sets all the flags associated with making this
 167            file descriptor into raw input/output.
 168 *)
 169
 170 PROCEDURE doraw (term: TERMIOS) ;
 171 BEGIN
 172    (*
 173     * from man 3 termios
 174     *           termios_p->c_iflag &= ~(IGNBRK | BRKINT | PARMRK | ISTRIP
 175     *                                   | INLCR | IGNCR | ICRNL | IXON);
 176     *           termios_p->c_oflag &= ~OPOST;
 177     *           termios_p->c_lflag &= ~(ECHO | ECHONL | ICANON | ISIG | IEXTEN);
 178     *           termios_p->c_cflag &= ~(CSIZE | PARENB);
 179     *           termios_p->c_cflag |= CS8;
 180     *)
 181    setFlag(term, ignbrk, FALSE) ;
 182    setFlag(term, ibrkint, FALSE) ;
 183    setFlag(term, iparmrk, FALSE) ;
 184    setFlag(term, istrip, FALSE) ;
 185    setFlag(term, inlcr, FALSE) ;
 186    setFlag(term, igncr, FALSE) ;
 187    setFlag(term, icrnl, FALSE) ;
 188    setFlag(term, ixon, FALSE) ;
 189
 190    setFlag(term, opost, FALSE) ;
 191
 192    setFlag(term, lecho, FALSE) ;
 193    setFlag(term, lechonl, FALSE) ;
 194    setFlag(term, licanon, FALSE) ;
 195    setFlag(term, lisig, FALSE) ;
 196    setFlag(term, liexten, FALSE) ;
 197
 198    setFlag(term, parenb, FALSE) ;
 199    setFlag(term, cs8, TRUE)
 200 END doraw ;
 201
 202
 203 (*
 204    dononraw - sets all the flags associated with making this
 205               file descriptor into non raw input/output.
 206 *)
 207
 208 PROCEDURE dononraw (term: TERMIOS) ;
 209 BEGIN
 210    (*
 211     * we undo these settings, (although we leave the character size alone)
 212     *
 213     * from man 3 termios
 214     *           termios_p->c_iflag &= ~(IGNBRK | BRKINT | PARMRK | ISTRIP
 215     *                                   | INLCR | IGNCR | ICRNL | IXON);
 216     *           termios_p->c_oflag &= ~OPOST;
 217     *           termios_p->c_lflag &= ~(ECHO | ECHONL | ICANON | ISIG | IEXTEN);
 218     *           termios_p->c_cflag &= ~(CSIZE | PARENB);
 219     *           termios_p->c_cflag |= CS8;
 220     *)
 221    setFlag(term, ignbrk, TRUE) ;
 222    setFlag(term, ibrkint, TRUE) ;
 223    setFlag(term, iparmrk, TRUE) ;
 224    setFlag(term, istrip, TRUE) ;
 225    setFlag(term, inlcr, TRUE) ;
 226    setFlag(term, igncr, TRUE) ;
 227    setFlag(term, icrnl, TRUE) ;
 228    setFlag(term, ixon, TRUE) ;
 229
 230    setFlag(term, opost, TRUE) ;
 231
 232    setFlag(term, lecho, TRUE) ;
 233    setFlag(term, lechonl, TRUE) ;
 234    setFlag(term, licanon, TRUE) ;
 235    setFlag(term, lisig, TRUE) ;
 236    setFlag(term, liexten, TRUE)
 237 END dononraw ;
 238
 239
 240 PROCEDURE BufferedMode (fd: INTEGER; input: BOOLEAN) ;
 241 VAR
 242    term: TERMIOS ;
 243    r   : INTEGER ;
 244 BEGIN
 245    IF IsDefaultFd(fd)
 246    THEN
 247       fdState[fd].IsRaw := FALSE
 248    END ;
 249    term := InitTermios() ;
 250    IF tcgetattr(fd, term)=0
 251    THEN
 252       dononraw(term) ;
 253       IF input
 254       THEN
 255          r := tcsetattr(fd, tcsflush(), term)
 256       ELSE
 257          r := tcsetattr(fd, tcsdrain(), term)
 258       END
 259    END ;
 260    term := KillTermios(term)
 261 END BufferedMode ;
 262
 263
 264 PROCEDURE UnBufferedMode (fd: INTEGER; input: BOOLEAN) ;
 265 VAR
 266    term  : TERMIOS ;
 267    result: INTEGER ;
 268 BEGIN
 269    IF IsDefaultFd(fd)
 270    THEN
 271       fdState[fd].IsRaw := TRUE
 272    END ;
 273    term := InitTermios() ;
 274    IF tcgetattr(fd, term)=0
 275    THEN
 276       doraw(term) ;
 277       IF input
 278       THEN
 279          result := tcsetattr(fd, tcsflush(), term)
 280       ELSE
 281          result := tcsetattr(fd, tcsdrain(), term)
 282       END
 283    END ;
 284    term := KillTermios(term)
 285 END UnBufferedMode ;
 286
 287
 288 (*
 289    EchoOn - turns on echoing for file descriptor, fd.  This
 290             only really makes sence for a file descriptor opened
 291             for terminal input or maybe some specific file descriptor
 292             which is attached to a particular piece of hardware.
 293 *)
 294
 295 PROCEDURE EchoOn (fd: INTEGER; input: BOOLEAN) ;
 296 VAR
 297    term  : TERMIOS ;
 298    result: INTEGER ;
 299 BEGIN
 300    term := InitTermios() ;
 301    IF tcgetattr(fd, term)=0
 302    THEN
 303       setFlag(term, lecho, TRUE) ;
 304       IF input
 305       THEN
 306          result := tcsetattr(fd, tcsflush(), term)
 307       ELSE
 308          result := tcsetattr(fd, tcsdrain(), term)
 309       END
 310    END ;
 311    term := KillTermios(term)
 312 END EchoOn ;
 313
 314
 315 (*
 316    EchoOff - turns off echoing for file descriptor, fd.  This
 317              only really makes sence for a file descriptor opened
 318              for terminal input or maybe some specific file descriptor
 319              which is attached to a particular piece of hardware.
 320 *)
 321
 322 PROCEDURE EchoOff (fd: INTEGER; input: BOOLEAN) ;
 323 VAR
 324    term  : TERMIOS ;
 325    result: INTEGER ;
 326 BEGIN
 327    term := InitTermios() ;
 328    IF tcgetattr(fd, term)=0
 329    THEN
 330       setFlag(term, lecho, FALSE) ;
 331       IF input
 332       THEN
 333          result := tcsetattr(fd, tcsflush(), term)
 334       ELSE
 335          result := tcsetattr(fd, tcsdrain(), term)
 336       END
 337    END ;
 338    term := KillTermios(term)
 339 END EchoOff ;
 340
 341
 342 (*
 343    Init -
 344 *)
 345
 346 PROCEDURE Init ;
 347 BEGIN
 348    WITH fdState[0] DO
 349       IsEof := FALSE ;
 350       IsRaw := FALSE
 351    END ;
 352    WITH fdState[1] DO
 353       IsEof := FALSE ;
 354       IsRaw := FALSE
 355    END ;
 356    WITH fdState[2] DO
 357       IsEof := FALSE ;
 358       IsRaw := FALSE
 359    END
 360 END Init ;
 361
 362
 363 BEGIN
 364    Init
 365 END IO.