path: root/gcc/m2/gm2-libs-iso/ClientSocket.mod

(* ClientSocket.mod provides a client TCP interface for ChanId's.

Copyright (C) 2008-2025 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 ClientSocket ;


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 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 libc IMPORT read, write, close ;
FROM errno IMPORT geterrno ;
FROM ErrnoCategory IMPORT GetOpenResults ;
FROM WholeStr IMPORT IntToStr ;

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

FROM wrapsock IMPORT clientInfo, clientOpen, clientOpenIP, getClientPortNo,
                     getClientSocketFd, getClientIP, getSizeOfClientInfo,
                     getPushBackChar, setPushBackChar, getClientHostname ;


TYPE
   PtrToLoc   = POINTER TO LOC ;
   ClientInfo = ADDRESS ;
VAR
   mid           : ModuleId ;
   did           : DeviceId ;
   dev           : ChanDev ;
   ClientInfoSize: CARDINAL ;


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 ;
   c : ClientInfo ;
   ch: CHAR ;
BEGIN
   c := GetData(d, mid) ;
   WITH d^ DO
      fd := getClientSocketFd(c) ;
      IF NOT getPushBackChar(c, ch)
      THEN
         REPEAT
            i := 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 ;
   c : ClientInfo ;
BEGIN
   c := GetData(d, mid) ;
   WITH d^ DO
      fd := getClientSocketFd(c) ;
      IF NOT setPushBackChar(c, ch)
      THEN
         RAISEdevException(cid, did, notAvailable,
                           'ClientSocket.dounreadchar: number of characters pushed back exceeds buffer')
      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 ;
   c : ClientInfo ;
   p : PtrToLoc ;
   i : INTEGER ;
BEGIN
   c := GetData(d, mid) ;
   WITH d^ DO
      IF max>0
      THEN
         p := to ;
         IF getPushBackChar(c, p^)
         THEN
            actual := 1 ;
            RETURN( TRUE )
         END ;
         fd := getClientSocketFd(c) ;
         i := read(fd, p, max) ;
         IF i>=0
         THEN
            actual := i ;
            RETURN( TRUE )
         ELSE
            errNum := geterrno() ;
            actual := 0 ;
            RETURN( FALSE )
         END
      ELSE
         RETURN( FALSE )
      END
   END
END dorbytes ;


(*
   dowbytes - attempts to write out nBytes.  The actual
              number of bytes written are returned.
              If the actual number of bytes written is >= 0 then
              the return result will be true.  Failure to
              write any bytes results in returning FALSE
              errno set and the actual will be set to zero.
*)

PROCEDURE dowbytes (g: GenDevIF; d: DeviceTablePtr;
                    from: ADDRESS;
                    nBytes: CARDINAL;
                    VAR actual: CARDINAL) : BOOLEAN ;
VAR
   fd: INTEGER ;
   c : ClientInfo ;
   i : INTEGER ;
BEGIN
   c := GetData(d, mid) ;
   WITH d^ DO
      fd := getClientSocketFd(c) ;
      i := 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 ;


PROCEDURE getname (d: DeviceTablePtr;
                   VAR a: ARRAY OF CHAR) ;
VAR
   c: ClientInfo ;
   b: ARRAY [0..6] OF CHAR ;
BEGIN
   c := GetData(d, mid) ;
   getClientHostname(c, ADR(a), HIGH(a)) ;
   Append(':', a) ;
   IntToStr(getClientPortNo(c) , b) ;
   Append(b, a)
END getname ;


(*
   freeData - disposes of, c.
*)

PROCEDURE freeData (c: ClientInfo) ;
BEGIN
   DEALLOCATE(c, ClientInfoSize) ;
END freeData ;


(*
   handlefree -
*)

PROCEDURE handlefree (d: DeviceTablePtr) ;
VAR
   c : ClientInfo ;
   fd: INTEGER ;
   i : INTEGER ;
BEGIN
   c := GetData(d, mid) ;
   fd := getClientSocketFd(c) ;
   i := close(fd) ;
   checkErrno(dev, d) ;
   KillData(d, mid)
END handlefree ;


(*
   OpenSocket - opens a TCP client connection to host:port.
*)

PROCEDURE OpenSocket (VAR cid: ChanId;
                      host: ARRAY OF CHAR; port: CARDINAL;
                      f: FlagSet; VAR res: OpenResults) ;
VAR
   d: DeviceTablePtr ;
   c: ClientInfo ;
   e: INTEGER ;
BEGIN
   MakeChan(did, cid) ;              (* create new channel *)
   ALLOCATE(c, ClientInfoSize) ;     (* allocate client socket memory *)
   d := DeviceTablePtrValue(cid, did) ;
   InitData(d, mid, c, freeData) ;   (* attach memory to device and module *)
   res := clientOpen(c, ADR(host), LENGTH(host), port) ;
   IF res=opened
   THEN
      e := 0
   ELSE
      e := geterrno()
   END ;
   WITH d^ DO
      flags := f ;
      errNum := e ;
      doLook := look ;
      doSkip := skip ;
      doSkipLook := skiplook ;
      doLnWrite := lnwrite ;
      doTextRead := textread ;
      doTextWrite := textwrite ;
      doRawRead := rawread ;
      doRawWrite := rawwrite ;
      doGetName := getname ;
      doFree := handlefree
   END
END OpenSocket ;


(*
   IsSocket - tests if the channel identified by cid is open as
              a client socket stream.
*)

PROCEDURE IsSocket (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 IsSocket ;


(*
   Close - if the channel identified by cid is not open to a socket
           stream, 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 IsSocket(cid)
   THEN
      UnMakeChan(did, cid) ;
      cid := InvalidChan()
   ELSE
      RAISEdevException(cid, did, wrongDevice,
                        'ClientSocket.' + __FUNCTION__ +
                        ': channel is not a socket stream')
   END
END Close ;


(*
   Init -
*)

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


BEGIN
   Init
END ClientSocket.