gcc/m2/gm2-libs-iso/TermFile.mod

   1 (* TermFile.mod implement the ISO TermFile specification.
   2
   3 Copyright (C) 2009-2024 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 TermFile ;
  28
  29
  30 FROM ASCII IMPORT nul, lf, cr ;
  31 FROM ChanConsts IMPORT ChanFlags ;
  32 FROM RTio IMPORT GetDeviceId ;
  33 FROM RTgenif IMPORT GenDevIF, InitGenDevIF ;
  34 FROM RTdata IMPORT ModuleId, MakeModuleId, InitData, GetData, KillData ;
  35 FROM IOChan IMPORT ChanExceptions, InvalidChan, CurrentFlags ;
  36 FROM IOConsts IMPORT ReadResults ;
  37 FROM Strings IMPORT Assign ;
  38
  39 FROM IOLink IMPORT DeviceId, DeviceTable, DeviceTablePtr, DeviceTablePtrValue, IsDevice,
  40                    AllocateDeviceId, RAISEdevException, MakeChan, UnMakeChan ;
  41
  42 FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
  43 FROM Strings IMPORT Append ;
  44
  45
  46 FROM SYSTEM IMPORT ADDRESS, ADR, LOC ;
  47 FROM errno IMPORT geterrno ;
  48 FROM ErrnoCategory IMPORT GetOpenResults ;
  49
  50 FROM RTgen IMPORT ChanDev, DeviceType, InitChanDev,
  51                   doLook, doSkip, doSkipLook, doWriteLn,
  52                   doReadText, doWriteText, doReadLocs, doWriteLocs,
  53                   checkErrno ;
  54
  55 FROM DynamicStrings IMPORT String, InitStringCharStar, CopyOut,
  56                            KillString ;
  57
  58 FROM termios IMPORT TERMIOS, InitTermios, KillTermios, tcgetattr,
  59                     tcsetattr, cfmakeraw, tcsnow ;
  60
  61
  62 IMPORT libc ;
  63
  64
  65 CONST
  66    O_RDONLY = 0 ;
  67    O_WRONLY = 1 ;
  68
  69 TYPE
  70    PtrToLoc   = POINTER TO LOC ;
  71    TermInfo   = POINTER TO RECORD
  72                               fd      : INTEGER ;
  73                               pushed  : CHAR ;
  74                               pushBack: BOOLEAN ;
  75                               old, new: TERMIOS ;
  76                            END ;
  77
  78 VAR
  79    mid: ModuleId ;
  80    did: DeviceId ;
  81    dev: ChanDev ;
  82
  83
  84 (*
  85    InitTermInfo - creates a new TermInfo and initializes fields,
  86                   fd, and, pushed.
  87 *)
  88
  89 PROCEDURE InitTermInfo (fd: INTEGER) : TermInfo ;
  90 VAR
  91    t: TermInfo ;
  92 BEGIN
  93    NEW(t) ;
  94    t^.fd := fd ;
  95    t^.pushBack := FALSE ;
  96    t^.new := InitTermios() ;
  97    t^.old := InitTermios() ;
  98    RETURN( t )
  99 END InitTermInfo ;
 100
 101
 102 (*
 103    KillTermInfo - deallocates memory associated with, t.
 104 *)
 105
 106 PROCEDURE KillTermInfo (t: TermInfo) : TermInfo ;
 107 BEGIN
 108    WITH t^ DO
 109       new := KillTermios(new) ;
 110       old := KillTermios(old)
 111    END ;
 112    DISPOSE(t) ;
 113    RETURN( NIL )
 114 END KillTermInfo ;
 115
 116
 117 (*
 118    getFd - return the file descriptor associated with, t.
 119 *)
 120
 121 PROCEDURE getFd (t: TermInfo) : INTEGER ;
 122 BEGIN
 123    RETURN( t^.fd )
 124 END getFd ;
 125
 126
 127 (*
 128    getPushBackChar - returns TRUE if a previously pushed back
 129                      character is available.  If TRUE then,
 130                      ch, will be assigned to the pushed back
 131                      character.
 132 *)
 133
 134 PROCEDURE getPushBackChar (t: TermInfo; VAR ch: CHAR) : BOOLEAN ;
 135 BEGIN
 136    WITH t^ DO
 137       IF pushBack
 138       THEN
 139          ch := pushed ;
 140          pushBack := FALSE ;
 141          RETURN( TRUE )
 142       ELSE
 143          RETURN( FALSE )
 144       END
 145    END
 146 END getPushBackChar ;
 147
 148
 149 (*
 150    setPushBackChar - attempts to push back, ch.  Only one character
 151                      may be pushed back consecutively.
 152 *)
 153
 154 PROCEDURE setPushBackChar (t: TermInfo; ch: CHAR) : BOOLEAN ;
 155 BEGIN
 156    WITH t^ DO
 157       IF pushBack
 158       THEN
 159          RETURN( FALSE )
 160       ELSE
 161          pushed := ch ;
 162          pushBack := TRUE ;
 163          RETURN( TRUE )
 164       END
 165    END
 166 END setPushBackChar ;
 167
 168
 169 PROCEDURE look (d: DeviceTablePtr;
 170                 VAR ch: CHAR; VAR r: ReadResults) ;
 171 BEGIN
 172    doLook(dev, d, ch, r)
 173 END look ;
 174
 175
 176 PROCEDURE skip (d: DeviceTablePtr) ;
 177 BEGIN
 178    doSkip(dev, d)
 179 END skip ;
 180
 181
 182 PROCEDURE skiplook (d: DeviceTablePtr;
 183                     VAR ch: CHAR; VAR r: ReadResults) ;
 184 BEGIN
 185    doSkipLook(dev, d, ch, r)
 186 END skiplook ;
 187
 188
 189 PROCEDURE lnwrite (d: DeviceTablePtr) ;
 190 BEGIN
 191    doWriteLn(dev, d)
 192 END lnwrite ;
 193
 194
 195 PROCEDURE textread (d: DeviceTablePtr;
 196                     to: ADDRESS;
 197                     maxChars: CARDINAL;
 198                     VAR charsRead: CARDINAL) ;
 199 BEGIN
 200    doReadText(dev, d, to, maxChars, charsRead)
 201 END textread ;
 202
 203
 204 PROCEDURE textwrite (d: DeviceTablePtr;
 205                      from: ADDRESS;
 206                      charsToWrite: CARDINAL);
 207 BEGIN
 208    doWriteText(dev, d, from, charsToWrite)
 209 END textwrite ;
 210
 211
 212 PROCEDURE rawread (d: DeviceTablePtr;
 213                    to: ADDRESS;
 214                    maxLocs: CARDINAL;
 215                    VAR locsRead: CARDINAL) ;
 216 BEGIN
 217    doReadLocs(dev, d, to, maxLocs, locsRead)
 218 END rawread ;
 219
 220
 221 PROCEDURE rawwrite (d: DeviceTablePtr;
 222                     from: ADDRESS;
 223                     locsToWrite: CARDINAL) ;
 224 BEGIN
 225    doWriteLocs(dev, d, from, locsToWrite)
 226 END rawwrite ;
 227
 228
 229 (*
 230    doreadchar - returns a CHAR from the file associated with, g.
 231 *)
 232
 233 PROCEDURE doreadchar (g: GenDevIF; d: DeviceTablePtr) : CHAR ;
 234 VAR
 235    i : INTEGER ;
 236    fd: INTEGER ;
 237    t : TermInfo ;
 238    ch: CHAR ;
 239 BEGIN
 240    t := GetData(d, mid) ;
 241    WITH d^ DO
 242       fd := getFd(t) ;
 243       IF NOT getPushBackChar(t, ch)
 244       THEN
 245          REPEAT
 246             i := libc.read(fd, ADR(ch), SIZE(ch))
 247          UNTIL i#0 ;
 248          IF i<0
 249          THEN
 250             errNum := geterrno()
 251          END
 252       END ;
 253       RETURN( ch )
 254    END
 255 END doreadchar ;
 256
 257
 258 (*
 259    dounreadchar - pushes a CHAR back onto the file associated with, g.
 260 *)
 261
 262 PROCEDURE dounreadchar (g: GenDevIF; d: DeviceTablePtr; ch: CHAR) : CHAR ;
 263 VAR
 264    fd: INTEGER ;
 265    t : TermInfo ;
 266 BEGIN
 267    t := GetData(d, mid) ;
 268    WITH d^ DO
 269       fd := getFd(t) ;
 270       IF NOT setPushBackChar(t, ch)
 271       THEN
 272          RAISEdevException(cid, did, notAvailable,
 273                            'TermFile.dounreadchar: cannot push back more than one character consecutively')
 274       END ;
 275       RETURN( ch )
 276    END
 277 END dounreadchar ;
 278
 279
 280 (*
 281    dogeterrno - returns the errno relating to the generic device.
 282 *)
 283
 284 PROCEDURE dogeterrno (g: GenDevIF; d: DeviceTablePtr) : INTEGER ;
 285 BEGIN
 286    RETURN geterrno()
 287 END dogeterrno ;
 288
 289
 290 (*
 291    dorbytes - reads upto, max, bytes setting, actual, and
 292               returning FALSE if an error (not due to eof)
 293               occurred.
 294 *)
 295
 296 PROCEDURE dorbytes (g: GenDevIF; d: DeviceTablePtr;
 297                     to: ADDRESS;
 298                     max: CARDINAL;
 299                     VAR actual: CARDINAL) : BOOLEAN ;
 300 VAR
 301    fd: INTEGER ;
 302    t : TermInfo ;
 303    p : PtrToLoc ;
 304    i : INTEGER ;
 305 BEGIN
 306    t := GetData(d, mid) ;
 307    WITH d^ DO
 308       IF max>0
 309       THEN
 310          p := to ;
 311          IF getPushBackChar(t, p^)
 312          THEN
 313             actual := 1 ;
 314             RETURN( TRUE )
 315          END ;
 316          fd := getFd(t) ;
 317          i := libc.read(fd, p, max) ;
 318          IF i>=0
 319          THEN
 320             actual := i ;
 321             RETURN( TRUE )
 322          ELSE
 323             errNum := geterrno() ;
 324             actual := 0 ;
 325             RETURN( FALSE )
 326          END
 327       END
 328    END ;
 329    RETURN( FALSE )
 330 END dorbytes ;
 331
 332
 333 (*
 334    dowbytes - attempts to write out nBytes.  The actual
 335               number of bytes written are returned.
 336               If the actual number of bytes written is >= 0 then
 337               the return result will be true.  Failure to
 338               write any bytes results in returning FALSE
 339               errno set and the actual will be set to zero.
 340 *)
 341
 342 PROCEDURE dowbytes (g: GenDevIF; d: DeviceTablePtr;
 343                     from: ADDRESS;
 344                     nBytes: CARDINAL;
 345                     VAR actual: CARDINAL) : BOOLEAN ;
 346 VAR
 347    fd: INTEGER ;
 348    t : TermInfo ;
 349    i : INTEGER ;
 350 BEGIN
 351    t := GetData(d, mid) ;
 352    WITH d^ DO
 353       fd := getFd(t) ;
 354       i := libc.write(fd, from, nBytes) ;
 355       IF i>=0
 356       THEN
 357          actual := i ;
 358          RETURN( TRUE )
 359       ELSE
 360          errNum := geterrno() ;
 361          actual := 0 ;
 362          RETURN( FALSE )
 363       END
 364    END
 365 END dowbytes ;
 366
 367
 368 (*
 369    dowriteln - attempt to write an end of line marker to the
 370                file and returns TRUE if successful.
 371 *)
 372
 373 PROCEDURE dowriteln (g: GenDevIF; d: DeviceTablePtr) : BOOLEAN ;
 374 VAR
 375    a: ARRAY [0..1] OF CHAR ;
 376    i: CARDINAL ;
 377 BEGIN
 378    a[0] := cr ;
 379    a[1] := lf ;
 380    RETURN( dowbytes(g, d, ADR(a), SIZE(a), i) AND (i=SIZE(a)) )
 381 END dowriteln ;
 382
 383
 384 (*
 385    iseof - returns TRUE if end of file is seen.
 386 *)
 387
 388 PROCEDURE iseof (g: GenDevIF; d: DeviceTablePtr) : BOOLEAN ;
 389 VAR
 390    ch: CHAR ;
 391 BEGIN
 392    ch := doreadchar(g, d) ;
 393    WITH d^ DO
 394       IF errNum=0
 395       THEN
 396          ch := dounreadchar(g, d, ch) ;
 397          RETURN( FALSE )
 398       ELSE
 399          RETURN( TRUE )
 400       END
 401    END
 402 END iseof ;
 403
 404
 405 (*
 406    iseoln - returns TRUE if end of line is seen.
 407 *)
 408
 409 PROCEDURE iseoln (g: GenDevIF; d: DeviceTablePtr) : BOOLEAN ;
 410 VAR
 411    ch: CHAR ;
 412 BEGIN
 413    ch := doreadchar(g, d) ;
 414    WITH d^ DO
 415       IF errNum=0
 416       THEN
 417          ch := dounreadchar(g, d, ch) ;
 418          RETURN( ch=lf )
 419       ELSE
 420          RETURN( FALSE )
 421       END
 422    END
 423 END iseoln ;
 424
 425
 426 (*
 427    iserror - returns TRUE if an error was seen on the device.
 428 *)
 429
 430 PROCEDURE iserror (g: GenDevIF; d: DeviceTablePtr) : BOOLEAN ;
 431 BEGIN
 432    RETURN( d^.errNum#0 )
 433 END iserror ;
 434
 435
 436 (*
 437    getname - assigns, a, to the device name of the terminal.
 438 *)
 439
 440 PROCEDURE getname (d: DeviceTablePtr;
 441                    VAR a: ARRAY OF CHAR) ;
 442 VAR
 443    s: String ;
 444 BEGIN
 445    s := InitStringCharStar(libc.ttyname(0)) ;
 446    CopyOut(a, s) ;
 447    s := KillString(s)
 448 END getname ;
 449
 450
 451 (*
 452    freeData - disposes of, t.
 453 *)
 454
 455 PROCEDURE freeData (t: TermInfo) ;
 456 BEGIN
 457    t := KillTermInfo(t)
 458 END freeData ;
 459
 460
 461 (*
 462    handlefree -
 463 *)
 464
 465 PROCEDURE handlefree (d: DeviceTablePtr) ;
 466 VAR
 467    t : TermInfo ;
 468    fd: INTEGER ;
 469    i : INTEGER ;
 470 BEGIN
 471    t := GetData(d, mid) ;
 472    fd := getFd(t) ;
 473    i := libc.close(fd) ;
 474    checkErrno(dev, d) ;
 475    KillData(d, mid)
 476 END handlefree ;
 477
 478
 479 (*
 480    termOpen - attempts to open up the terminal device.  It fills
 481               in any implied flags and returns a result depending
 482               whether the open was successful.
 483 *)
 484
 485 PROCEDURE termOpen (t: TermInfo; VAR flagset: FlagSet; VAR e: INTEGER) : OpenResults ;
 486 VAR
 487    i: INTEGER ;
 488 BEGIN
 489    WITH t^ DO
 490       IF NOT (rawFlag IN flagset)
 491       THEN
 492          INCL(flagset, textFlag)
 493       END ;
 494       IF NOT (echoFlag IN flagset)
 495       THEN
 496          INCL(flagset, interactiveFlag)
 497       END ;
 498       IF NOT (writeFlag IN flagset)
 499       THEN
 500          INCL(flagset, readFlag)
 501       END ;
 502       IF writeFlag IN flagset
 503       THEN
 504          fd := libc.open(ADR("/dev/tty"), O_WRONLY, 0600B)
 505       ELSE
 506          fd := libc.open(ADR("/dev/tty"), O_RDONLY)
 507       END ;
 508       IF tcgetattr(fd, new)=0
 509       THEN
 510       END ;
 511       IF tcgetattr(fd, old)=0
 512       THEN
 513          IF rawFlag IN flagset
 514          THEN
 515             cfmakeraw(new)
 516          END ;
 517          IF tcsetattr(fd, tcsnow(), new)=0
 518          THEN
 519          END
 520       END ;
 521       e := geterrno() ;
 522       RETURN( GetOpenResults(e) )
 523    END
 524 END termOpen ;
 525
 526
 527 (*
 528    RestoreTerminalSettings -
 529 *)
 530
 531 PROCEDURE RestoreTerminalSettings (cid: ChanId) ;
 532 VAR
 533    d: DeviceTablePtr ;
 534    t: TermInfo ;
 535    e: INTEGER ;
 536 BEGIN
 537    d := DeviceTablePtrValue(cid, did) ;
 538    t := GetData(d, mid) ;
 539    WITH t^ DO
 540       IF tcsetattr(fd, tcsnow(), old)=0
 541       THEN
 542       END
 543    END
 544 END RestoreTerminalSettings ;
 545
 546
 547 (*
 548    Open - attempts to obtain and open a channel connected to
 549           the terminal.  Without the raw flag, text is implied.
 550           Without the echo flag, line mode is requested,
 551           otherwise single character mode is requested.
 552           If successful, assigns to cid the identity of
 553           the opened channel, and assigns the value opened to res.
 554           If a channel cannot be opened as required, the value of
 555           res indicates the reason, and cid identifies the
 556           invalid channel.
 557 *)
 558
 559 PROCEDURE Open (VAR cid: ChanId;
 560                 flagset: FlagSet; VAR res: OpenResults) ;
 561 VAR
 562    d: DeviceTablePtr ;
 563    t: TermInfo ;
 564    e: INTEGER ;
 565 BEGIN
 566    MakeChan(did, cid) ;              (* create new channel *)
 567    d := DeviceTablePtrValue(cid, did) ;
 568    t := InitTermInfo(-1) ;
 569    res := termOpen(t, flagset, e) ;
 570    InitData(d, mid, t, freeData) ;   (* attach memory to device and module *)
 571    WITH d^ DO
 572       flags := flagset ;
 573       errNum := e ;
 574       doLook := look ;
 575       doSkip := skip ;
 576       doSkipLook := skiplook ;
 577       doLnWrite := lnwrite ;
 578       doTextRead := textread ;
 579       doTextWrite := textwrite ;
 580       doRawRead := rawread ;
 581       doRawWrite := rawwrite ;
 582       doGetName := getname ;
 583       doFree := handlefree
 584    END
 585 END Open ;
 586
 587
 588 (*
 589    IsTermFile - tests if the channel identified by cid is open to
 590                 the terminal.
 591 *)
 592
 593 PROCEDURE IsTermFile (cid: ChanId) : BOOLEAN ;
 594 BEGIN
 595    RETURN( (cid # NIL) AND (InvalidChan() # cid) AND
 596            (IsDevice(cid, did)) AND
 597            ((readFlag IN CurrentFlags(cid)) OR
 598             (writeFlag IN CurrentFlags(cid))) )
 599 END IsTermFile ;
 600
 601
 602 (*
 603    Close - if the channel identified by cid is not open to the
 604            terminal, the exception wrongDevice is raised; otherwise
 605            closes the channel, and assigns the value identifying
 606            the invalid channel to cid.
 607 *)
 608
 609 PROCEDURE Close (VAR cid: ChanId) ;
 610 BEGIN
 611    IF IsTermFile(cid)
 612    THEN
 613       RestoreTerminalSettings(cid) ;
 614       UnMakeChan(did, cid) ;
 615       cid := InvalidChan()
 616    ELSE
 617       RAISEdevException(cid, did, wrongDevice,
 618                         'TermFile.' + __FUNCTION__ +
 619                         ': channel is opened to the terminal')
 620    END
 621 END Close ;
 622
 623
 624 (*
 625    Init -
 626 *)
 627
 628 PROCEDURE Init ;
 629 VAR
 630    gen: GenDevIF ;
 631 BEGIN
 632    MakeModuleId(mid) ;
 633    AllocateDeviceId(did) ;
 634    gen := InitGenDevIF(did,
 635                        doreadchar, dounreadchar,
 636                        dogeterrno, dorbytes, dowbytes,
 637                        dowriteln,
 638                        iseof, iseoln, iserror) ;
 639    dev := InitChanDev(term, did, gen)
 640 END Init ;
 641
 642
 643 BEGIN
 644    Init
 645 END TermFile.