mim/development/mim/vax/mimlib/netbase.mud

   1 <PACKAGE "NETBASE">
   2
   3 <ENTRY NETWORK NET-ADDRESS CONNECTION TIMEOUT CURRENT-CONNECTION NET-CHANNELS
   4        TIME-NUM CLOSE-DATA-CHANNEL KILL-CHANNEL INPUT-WAITING DO-TIMEOUT>
   5
   6 <INCLUDE-WHEN <COMPILING? "NETBASE"> "NETDEFS">
   7
   8 <NEW-CHANNEL-TYPE NETWORK <>
   9                   OPEN NETWORK-OPEN
  10                   CLOSE NETWORK-CLOSE
  11                   READ-BUFFER NETWORK-READ
  12                   READ-BYTE NETWORK-READ-BYTE
  13                   WRITE-BUFFER NETWORK-WRITE
  14                   WRITE-BYTE NETWORK-WRITE-BYTE
  15                   TIMEOUT NETWORK-TIMEOUT
  16                   INPUT-WAITING NETWORK-TYPE-AHEAD?
  17                   CLOSE-DATA-CHANNEL NET-CLOSE-ALT
  18                   FILE-HANDLE NET-FILE-HANDLE>
  19
  20 <COND (<NOT <VALID-TYPE? CONNECTION>>
  21        <NEWTYPE CONNECTION VECTOR>
  22        <NEWTYPE NET-ADDRESS UVECTOR>)>
  23
  24 <SETG NET-CHANNELS ()>
  25
  26 <DEFINE NET-FILE-HANDLE (CH:<CHANNEL 'NETWORK> OPER
  27                          "AUX" (DATA:CONNECTION <CHANNEL-DATA .CH>))
  28    <C-SOCKET .DATA>>
  29
  30 <DEFINE NETWORK-TYPE-AHEAD? (CHANNEL:<CHANNEL 'NETWORK> OPER
  31                              "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
  32                              (BUF:UVECTOR <STACK <IUVECTOR 1>>)
  33                              (CURRENT-CONNECTION:<SPECIAL <CHANNEL 'NETWORK>>
  34                               .CHANNEL))
  35    <COND (<CALL SYSCALL IOCTL <C-SOCKET .DATA> ,FIONREAD .BUF>
  36           <COND (<G? <1 .BUF> 0>
  37                  <1 .BUF>)>)>>
  38
  39 <DEFINE TIME-NUM (UV:<UVECTOR [2 FIX]> "OPT" NEW:<OR FIX FLOAT> "AUX" OLD)
  40    <SET OLD
  41         <COND (<0? <2 .UV>> <1 .UV>)
  42               (T
  43                <+ <FLOAT <1 .UV>> </ <FLOAT <2 .UV>> 1000000.0>>)>>
  44    <COND (<NOT <ASSIGNED? NEW>>)
  45          (<TYPE? .NEW FIX>
  46           <2 .UV 0>
  47           <1 .UV .NEW>)
  48          (T
  49           <1 .UV <FIX .NEW>>
  50           <2 .UV <FIX <* 1000000.0 <- .NEW <1 .UV>>>>>)>
  51    .OLD>
  52
  53 <DEFINE NETWORK-TIMEOUT (CHANNEL:<CHANNEL 'NETWORK> OPER
  54                          "OPT" NEW:<OR FIX FLOAT FALSE>
  55                          "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
  56                          UV (OLD <>))
  57    <COND (<SET UV <C-TIMEOUT .DATA>>
  58           <SET OLD <TIME-NUM .UV>>)>
  59    <COND (<NOT <ASSIGNED? NEW>>)
  60          (<NOT .NEW> <C-TIMEOUT .DATA <>>)
  61          (T
  62           <COND (<NOT .UV><SET UV <IUVECTOR 2>>)>
  63           <TIME-NUM .UV .NEW>
  64           <C-TIMEOUT .DATA .UV>)>
  65    .OLD>
  66
  67 <DEFINE NETWORK-OPEN (TYPE OPER NAME:<OR STRING FALSE>
  68                       "OPTIONAL" SERVICE:<OR NET-ADDRESS FIX>
  69                       (H:<OR NET-ADDRESS FIX> <CALL SYSCALL GETHOSTID>)
  70                       (NS:<OR FIX FALSE> <>)
  71                       "AUX" S
  72                       (FA <STACK <IUVECTOR ,ADDR-WORD-LEN>>)
  73                       (ADDR:NET-ADDRESS <CHTYPE .FA NET-ADDRESS>)
  74                       ERR KIND:FIX PROT:FIX SERVSOCK:FIX)
  75         <COND
  76          (<NOT <ASSIGNED? SERVICE>>
  77           <ERROR TOO-FEW-ARGUMENTS!-ERRORS
  78                  CHANNEL-OPEN
  79                  NETWORK>)
  80          (<NOT .NS>
  81           <COND (<TYPE? .SERVICE NET-ADDRESS>
  82                  <SET SERVSOCK <IN-ADDR-PORT .SERVICE>>
  83                  <SET PROT ,PROT-TCP>
  84                  <SET KIND ,SOCK-STREAM>
  85                  <SET H <NA-HOST .SERVICE>>
  86                  <SET ADDR .SERVICE>
  87                  <SET SERVICE <PUTLHW .SERVSOCK .PROT>>)
  88                 (T
  89                  <SET PROT <LHW .SERVICE>>
  90                  <SET SERVSOCK <RHW .SERVICE>>
  91                  <COND (<==? .PROT ,PROT-UDP> <SET KIND ,SOCK-DGRAM>)
  92                        (T <SET KIND ,SOCK-STREAM>)>
  93                  <BUILD-ADDRESS .SERVICE .H .ADDR>)>
  94           <COND (<SET S <CALL SYSCALL SOCKET ,AF-INET .KIND .PROT>>
  95                  <COND (<NOT <SET ERR <CALL SYSCALL CONNECT
  96                                             .S .ADDR ,ADDR-LEN>>>
  97                         <CALL SYSCALL CLOSE .S>
  98                         .ERR)
  99                        (T
 100                         <SETG NET-CHANNELS (.S .CURRENT-CHANNEL
 101                                             !,NET-CHANNELS)>
 102                         <CHTYPE [.S <CHTYPE <UVECTOR !.ADDR>
 103                                             NET-ADDRESS>
 104                                  .SERVICE 0 <> <>]
 105                                 CONNECTION>)>)>)
 106          (T
 107           <SETG NET-CHANNELS (.NS .CURRENT-CHANNEL
 108                               !,NET-CHANNELS)>
 109           <CHTYPE [.NS <CHTYPE <UVECTOR !.H> NET-ADDRESS>
 110                    .SERVICE 0 <> <>] CONNECTION>)>>
 111
 112 <DEFINE KILL-CHANNEL (CHANNEL:CHANNEL
 113                       "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
 114                       L:<OR FALSE LIST>)
 115    <COND (<SET L <MEMQ <C-SOCKET .DATA> ,NET-CHANNELS>>
 116           <COND (<==? .L ,NET-CHANNELS>
 117                  <SETG NET-CHANNELS <REST ,NET-CHANNELS 2>>)
 118                 (T
 119                  <PUTREST <REST ,NET-CHANNELS <- <LENGTH ,NET-CHANNELS>
 120                                                  <LENGTH .L>
 121                                                  1>>
 122                           <REST .L 2>>)>)>>
 123
 124 <DEFINE NET-CLOSE-ALT (C:<CHANNEL 'NETWORK> OPER
 125                        "AUX" (DATA:CONNECTION <CHANNEL-DATA .C>) NC)
 126    <COND (<TYPE? <SET NC <C-ALTCHANNEL .DATA>> CHANNEL>
 127           <COND (<CHANNEL-OPEN? .NC>
 128                  <CHANNEL-CLOSE .NC>)>
 129           <C-ALTCHANNEL .DATA <>>)
 130          (<TYPE? .NC FIX>
 131           <CALL SYSCALL CLOSE .NC>
 132           <C-ALTCHANNEL .DATA <>>)>>
 133
 134 <DEFINE NETWORK-CLOSE (CHANNEL:<CHANNEL 'NETWORK> OPER
 135                        "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>))
 136         <COND (<C-ALTCHANNEL .DATA>
 137                <CHANNEL-OP .CHANNEL CLOSE-DATA-CHANNEL>)>
 138         <KILL-CHANNEL .CHANNEL>
 139         <CALL SYSCALL CLOSE <C-SOCKET .DATA>>
 140         <C-SOCKET .DATA -1>
 141         .CHANNEL>
 142
 143 <DEFINE NETWORK-WRITE (CHANNEL:<CHANNEL 'NETWORK> OPER
 144                        "TUPLE" STUFF
 145                        "AUX" (CT:FIX <LENGTH .STUFF>)
 146                        (IOV:UVECTOR <STACK <IUVECTOR .CT>>) RLEN
 147                        (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
 148                        FROB:<OR STRING UVECTOR>
 149                        NC:<OR FIX FALSE>
 150                        (CURRENT-CONNECTION:<SPECIAL CHANNEL> .CHANNEL))
 151    #DECL ((STUFF) <<PRIMTYPE VECTOR>
 152                                       [REST <OR STRING UVECTOR>
 153                                        <OR FALSE FIX>]>)
 154    <COND
 155     (<L=? .CT 2>
 156      <SET FROB <1 .STUFF>>
 157      <COND (<OR <==? .CT 1> <NOT <2 .STUFF>>>
 158             <COND (<TYPE? .FROB STRING> <SET CT <LENGTH .FROB>>)
 159                   (T <SET CT <LENGTH .FROB>>)>)
 160            (T
 161             <SET CT <2 .STUFF>>)>
 162      <SET RLEN .CT>
 163      <COND (<TYPE? .FROB UVECTOR> <SET CT <* .CT 4>>)>
 164      <PROG ()
 165         <COND (<SET NC <ISYSCALL WRITE <C-SOCKET .DATA>
 166                                  .FROB .CT>>
 167                <COND (<L? .NC .CT>
 168                       <SET CT <- .CT .NC>>
 169                       <COND (<TYPE? .FROB UVECTOR>
 170                              <SET FROB <REST .FROB </ .NC 4>>>)
 171                             (T
 172                              <SET FROB <REST .FROB .NC>>)>
 173                       <AGAIN>)>
 174                .RLEN)>>)
 175     (T
 176      <SET NC <MAKE-ARGS .STUFF .IOV>>
 177      <PROG (NEW (RES 0))
 178         <COND
 179          (<SET NEW <ISYSCALL WRITEV <C-SOCKET .DATA> .IOV </ .CT 2>>>
 180           <COND (<G? <SET NC <- .NC .NEW>> 0>
 181                  <SET RES <+ <GET-COUNT .STUFF .IOV .NEW T> .RES>>
 182                  <AGAIN>)
 183                 (T
 184                  <SET RES <+ <GET-COUNT .STUFF .IOV .NEW> .RES>>)>
 185           .RES)>>)>>
 186
 187 <DEFINE NETWORK-READ-BYTE (CHANNEL:<CHANNEL 'NETWORK> OPER "AUX"
 188                            (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
 189                            (BUF <STACK <ISTRING 1>>)
 190                            (CURRENT-CONNECTION:<SPECIAL <CHANNEL 'NETWORK>>
 191                             .CHANNEL)
 192                            RES:<OR FIX FALSE>)
 193    <COND
 194     (<OR <NOT <C-TIMEOUT .DATA>>
 195          <DO-TIMEOUT .DATA>>
 196      <COND
 197       (<AND <SET RES <ISYSCALL READ <C-SOCKET .DATA> .BUF 1>>
 198             <G? .RES 0>>
 199        <1 .BUF>)>)>>
 200
 201 <DEFINE NETWORK-WRITE-BYTE (CHANNEL:<CHANNEL 'NETWORK> OPER BYTE:<OR FIX CHARACTER>
 202                             "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
 203                             (BUF1 <STACK <ISTRING 1>>)
 204                             (BUF2 <STACK <IUVECTOR 1>>)
 205                             (CURRENT-CONNECTION:<SPECIAL <CHANNEL 'NETWORK>>
 206                              .CHANNEL))
 207    <COND (<TYPE? .BYTE FIX>
 208           <1 .BUF2 .BYTE>
 209           <COND (<NETWORK-WRITE .CHANNEL .OPER .BUF2 1> .BYTE)>)
 210          (T
 211           <1 .BUF1 .BYTE>
 212           <COND (<ISYSCALL WRITE <C-SOCKET .DATA> .BUF1 1> .BYTE)>)>>
 213
 214
 215
 216 <DEFINE DO-TIMEOUT (DATA:CONNECTION "AUX" (BUF <STACK <IUVECTOR 1>>)
 217                     RES:<OR FIX FALSE>)
 218    <1 .BUF <LSH 1 <C-SOCKET .DATA>>>
 219    <COND
 220     (<SET RES
 221           <ISYSCALL SELECT <+ <C-SOCKET .DATA> 1> .BUF 0 0 <C-TIMEOUT .DATA>>>
 222      <COND (<0? .RES> ,TIMED-OUT)
 223            (T)>)>>
 224
 225 <DEFINE NETWORK-READ (CHANNEL:<CHANNEL 'NETWORK> OPER
 226                       "TUPLE" STUFF
 227                       "AUX" (CT:FIX <LENGTH .STUFF>)
 228                       (IOV:UVECTOR <STACK <IUVECTOR .CT>>)
 229                       (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
 230                       LAST FROB:<OR STRING UVECTOR> RES:<OR FIX FALSE>
 231                       (CURRENT-CONNECTION:<SPECIAL <CHANNEL 'NETWORK>>
 232                        .CHANNEL))
 233    #DECL ((STUFF) <<PRIMTYPE VECTOR>
 234                    [REST <OR STRING UVECTOR>
 235                     <OR FIX FALSE>]>)
 236    <COND (<OR <NOT <C-TIMEOUT .DATA>>
 237               <DO-TIMEOUT .DATA>>
 238           <COND
 239            (<L=? .CT 2>
 240             <SET FROB <1 .STUFF>>
 241             <COND (<OR <==? .CT 1> <NOT <2 .STUFF>>>
 242                    <COND (<TYPE? .FROB STRING> <SET CT <LENGTH .FROB>>)
 243                          (T <SET CT <LENGTH .FROB>>)>)
 244                   (T <SET CT <2 .STUFF>>)>
 245             <COND (<TYPE? .FROB UVECTOR> <SET CT <* .CT 4>>)>
 246             <COND (<SET RES <ISYSCALL READ <C-SOCKET .DATA> .FROB .CT>>
 247                    <COND (<TYPE? .FROB UVECTOR>
 248                           </ <+ .RES 3> 4>)
 249                          (.RES)>)>)
 250            (T
 251             <MAKE-ARGS .STUFF .IOV>
 252             <COND
 253              (<SET RES <ISYSCALL READV <C-SOCKET .DATA> .IOV </ .CT 2>>>
 254               <GET-COUNT .STUFF .IOV .RES>)>)>)>>
 255
 256 <DEFINE GET-COUNT (STUFF:<<PRIMTYPE VECTOR> [REST <OR STRING UVECTOR>
 257                                              <OR FALSE FIX>]>
 258                    IOV:<UVECTOR [REST FIX]>
 259                    CT:FIX "OPT" (WRITE?:<OR ATOM FALSE> <>))
 260    <REPEAT ((NC 0) FROB LEN NEW)
 261       <COND (<OR <EMPTY? .STUFF>
 262                  <L=? .CT 0>>
 263              <RETURN .NC>)>
 264       <SET LEN <2 .IOV>>
 265       <COND (.WRITE?
 266              <2 .IOV <SET NEW <MAX 0 <- .LEN .CT>>>>
 267              <1 .IOV <+ <1 .IOV> <- .LEN .NEW>>>)>
 268       <SET NEW <MIN .CT .LEN>>
 269       <SET CT <- .CT .NEW>>
 270       <COND (<TYPE? <1 .STUFF> UVECTOR>
 271              <SET NEW </ <+ .NEW 3> 4>>)>
 272       <SET NC <+ .NC .NEW>>
 273       <SET IOV <REST .IOV 2>>
 274       <SET STUFF <REST .STUFF 2>>>>
 275
 276 <DEFINE MAKE-ARGS (STUFF:<<PRIMTYPE VECTOR>
 277                           [REST <OR STRING UVECTOR> <OR FALSE FIX>]>
 278                    IOV:<UVECTOR [REST FIX]>)
 279   <COND (<NOT <0? <MOD <LENGTH .STUFF> 2>>>
 280          <ERROR ARGUMENT-VECTOR-IS-BAD-LENGTH!-ERROR
 281                 .STUFF NETWORK-READ/WRITE>)>
 282   <REPEAT (THING LEN (CT 0))
 283      <COND (<EMPTY? .STUFF> <RETURN .CT>)>
 284      <SET LEN <2 .STUFF>>
 285      <COND (<TYPE? <SET THING <1 .STUFF>> UVECTOR>
 286             <COND (<NOT .LEN>
 287                    <SET LEN <LENGTH .THING>>
 288                    <2 .STUFF .LEN>)>
 289             <SET LEN <* 4 .LEN>>)
 290            (T
 291             <COND (<NOT .LEN>
 292                    <SET LEN <LENGTH .THING>>
 293                    <2 .STUFF .LEN>)>)>
 294      <1 .IOV <CALL VALUE .THING>>
 295      <2 .IOV .LEN>
 296      <SET CT <+ .CT .LEN>>
 297      <SET STUFF <REST .STUFF 2>>
 298      <SET IOV <REST .IOV 2>>>>
 299
 300 <ENDPACKAGE>