+-+-+-+ Beginning of part 23 +-+-+-+
XAdd`009/Host=LT2006`009/Type=X
XAdd`009/Host=LT2007`009/Type=X
XAdd`009/Host=LT2008`009/Type=X
XAdd`009/Host=LT2009`009/Type=X
XAdd`009/Host=LT2010`009/Type=X
XAdd`009/Host=LT2011`009/Type=X
XAdd`009/Host=LT2012`009/Type=X
XAdd`009/Host=LT2013`009/Type=X
XAdd`009/Host=LATALL`009/Type=X    /Link=ALL
XExit
X$ NoRebuild:
X$!
$ GOSUB UNPACK_FILE

$ FILE_IS = "TCPFINGER.FOR"
$ CHECKSUM_IS = 944478027
$ COPY SYS$INPUT VMS_SHARE_DUMMY.DUMMY
X`009Integer Function TCP_Finger(Host,Comm,Finger_out_routine)
X
Xc  Outgoing finger for EUNICE TCP/IP
Xc  P. Lucas, CMU,  16-OCT-1984
Xc  This code borrows heavily form examples taken from Joe Sventek's primer
Xc`009on how to do this stuff.
Xc
X        include 'INETSYM.INC'
X`009External`009Fing_Nonode, Fing_NoNet
X
X        integer*4 bufsiz, sd,  errlen
X`009integer*4 btrim
X        integer*2 sys$assign, sys$qiow
X        logical*4 inet_gethost
X        character*80 buffer
X`009logical*1 bytbuf(1024)
X`009character*132 tempcom, tempcom1
X`009Character`009Network*20,`009Get_Network*20
X`009character*(*)host,comm
X        integer*2 iosb(4), s
X        logical*4 error
X        integer*2 swab
X        character errbuf*256
X`009external  finger_out_routine
X`009external  Fing_Complete, Fing_Abort
Xc
Xc       FORTRAN equivalent of sockaddr_in
Xc
X        integer*2 i2buf(8)
X        logical*1 l1buf(16)
X`009Character`009Flush /255/
X
X        equivalence (i2buf(1), l1buf(1))
Xc  Default return status
X`009TCP_Finger = %Loc(Fing_Complete)
X`009call inet_lower(host)`009`009!we need lower case host name
X
Xc   must terminate with cr/lf
X`009if (comm(1:6).eq.'FINGER') then
X`009  lll=index(comm,' ')
X`009  if ((lll.ne.0).and.(lll+1.le.len(comm))) then
X`009    tempcom1=comm(lll+1:)
X`009  else
X`009    tempcom1=' '
X`009  endif
X`009else
X`009  tempcom1=comm
X`009endif
X`009lll=btrim(tempcom1)
X`009if(lll.eq.1 .and. tempcom1(1:1) .le. ' ') then
X`009`009tempcom = char(13)//char(10)
X`009else
X`009`009tempcom=tempcom1(1:lll)//char(13)//char(10)
X`009endif
Xc
Xc
Xc       assign channel to device and create socket
Xc
X        s = sys$assign('INET0:', sd,,)
X        if (error(s, 1, errbuf, errlen)) then
X`009`009TCP_Finger = %Loc(Fing_NoNet)`009`009!No TCP available
X`009`009return
X        endif
X        s = sys$qiow(%val(0), %val(sd), %val(IO$_SOCKET), %ref(iosb),
X     1            ,, %val(AF_INET), %val(SOCK_STREAM),,,,)
X        if (error(s, iosb(1), errbuf, errlen)) then
X          call finger_out_routine(errbuf(1:errlen))
X`009  TCP_Finger = %loc(fing_abort)
X`009  return
X        endif
Xc
Xc       fill in destination port and host address.  inet_gethost locates
Xc       the entry for the specified host in the file ETC:HOSTS.
Xc       and returns the internet address in the correct order
Xc
X        i2buf(1) = AF_INET
X        i2buf(2) = swab(79)
X        if (.not. inet_gethost(host(1:btrim(host)), l1buf(5))) then
X`009  TCP_Finger = %Loc(Fing_NoNode)
X`009  return
X        endif
Xc
Xc       connect to server
Xc
X        s = sys$qiow(%val(0), %val(sd), %val(IO$_CONNECT), %ref(iosb),
X     1            ,, %ref(l1buf), %val(16),,,,)
X        if (error(s, iosb(1), errbuf, errlen)) then
X`009  Call Finger_Out_Routine
X     1`009`009(': link failed]'// char(13)//char(10))
X          call finger_out_routine(errbuf(1:errlen))
X`009  TCP_Finger = %loc(fing_abort)
X`009  return
X        endif
Xc  Get network name
X`009Network = Get_Network('T')
X`009if (network .eq. '?')network = 'ARPA'`009!default to arpa
Xc  Finish message
X`009Call Finger_Out_Routine('.'//Network(:Btrim(Network))//']'
X     1`009`009//char(13)//char(10))
X
Xc
Xc   send the request
X          s = sys$qiow(%val(0), %val(sd), %val(IO$_SEND), %ref(iosb),,,
X     1              %ref(tempcom), %val(btrim(tempcom)),,,,)
X          if (error(s, iosb(1), errbuf, errlen)) then
X            call finger_out_routine(errbuf(1:errlen))
X`009    TCP_Finger = %loc(fing_abort)
X`009    return
X          endif
Xc       read on socket until 0 length read - seems to imply
Xc       that the partner has exited
Xc
X2        s = sys$qiow(%val(0), %val(sd), %val(IO$_RECEIVE), %ref(iosb),
X     1            ,, %ref(bytbuf), %val(1024),,,,)
X        if (error(s, iosb(1), errbuf, errlen)) then
X          call finger_out_routine(errbuf(1:errlen))
X`009  TCP_Finger = %loc(fing_abort)
X`009  return
X        endif
X        if (iosb(2) .eq. 0) goto 222
X`009nl = iosb(2)/80
X`009do ii = 1,nl
X`009`009call bytetostr(bytbuf((ii-1)*80+1),80,buffer)
X`009`009call finger_out_routine(buffer)
X`009enddo
X`009ilen=iosb(2)-nl*80
X`009if(ilen .gt. 0)then
X`009`009call bytetostr(bytbuf(nl*80+1),ilen,buffer)
X`009`009call finger_out_routine(buffer(1:ilen))
X`009endif
X`009goto 2
Xc
X222`009call sys$dassgn(%val(sd))
X`009return
X        end
Xc
Xc
Xc
Xc
Xc   Find host in etc:hosts and return inet address - GETHOST.INC
X
X        logical function inet_gethost(host, adrbuf)
X
X        character*(*) host
X        logical*1 adrbuf(4)
X        integer*4 lun, hostlen, n, i, adrlen, m, j, k
X        integer*4 lib$get_lun, inet_getword
X        character buffer*256, address*40, nicknm*40
X
X        integer*4 i4
X        logical*1 l1
X
X        equivalence (l1,i4)
X
X        if (.not. lib$get_lun(lun)) then
X          inet_gethost = .false.
X          return
X        endif
X        open (unit=lun, file='TWG$ETC:[000000]HOSTS.', type='OLD',`032
X     1     READONLY, err=10)
X        hostlen = len(host)
X1       continue
X        read (lun, 100, end=11) n, buffer
X100     format(q, (a))
X        if (buffer(1:1) .eq. '#') goto 1        ! have a comment
X        i = index(buffer(1:n), '#')
X        if (i .gt. 0) then
X          n = i
X        endif
X        do 4 i = 1, n
X          k = ichar(buffer(i:i))
X          if (k .eq. 9) then
X            buffer(i:i) = ' '           ! replace tabs by blanks
X          endif
X4       continue
X        i = 1
X        adrlen = inet_getword(buffer(1:n), i, address)
X        adrlen = adrlen + 1
X        address(adrlen:adrlen) = '.'
X2       continue
X        m = inet_getword(buffer(1:n), i, nicknm)
X        if (m .le. 0) goto 1
X        if (m .ne. hostlen) goto 2
X        if (nicknm(1:m) .ne. host(1:m)) goto 2
X        close(unit = lun)
X        call lib$free_lun(lun)
X        i = 1
X        do 3 j = 1, 4
X          k = i + index(address(i:adrlen), '.') - 2
X          call ots$cvt_ti_l(address(i:k), i4)
X          adrbuf(j) = l1
X          i = k + 2
X3       continue
X        inet_gethost = .true.
X        return
X11      close (unit = lun)
X10      call lib$free_lun(lun)
X        inet_gethost = .false.
X        return
X        end
X
X
Xc    Swap bytes in short integer - SWAB.INC
X
X        integer*2 function swab(short)
X
X        integer*2 short, result
X        logical*1 bytes(2), temp
X
X        equivalence (result, bytes(1))
X
X        result = short
X        temp = bytes(1)
X        bytes(1) = bytes(2)
X        bytes(2) = temp
X        swab = result
X
X        return
X        end
X
X
X
Xc   Translate error into printable string - ERROR.INC
X
X      logical function error(first, second, errbuf, errlen)
X
X      integer*2 first, second
X      character*(*) errbuf
X      integer*4 errlen
X      integer*2 err
X
X      errlen = 0
X      if (first .and. second) then
X         error = .false.
X         return
X      endif
X      if (.not. first) then
X        err = first
X      else
X        err = second
X      endif
X      if ((err .and. '8000'x) .eq. '8000'x) then
X        call eunice_error(err, errbuf, errlen)
X      else
X        call sys$getmsg(%val(err), %ref(errlen), errbuf, %val(15),)
X      endif
X      error = .true.
X      return
X
X      end
X
Xc   Fetch next word from buffer - GETWORD.INC
X
X      integer*4 function inet_getword(buf, i, out)
X
X      character*(*) buf, out
X      integer*4 i, n, j
X
X      n = len(buf)
X1     continue
X        if (i .gt. n) then
X          goto 2
X        elseif (buf(i:i) .ne. ' ') then
X          goto 2
X        else
X          i = i + 1
X        endif
X        goto 1
X2     continue
X      j = 1
X3     continue
X        if (i .gt. n) then
X          goto 4
X        elseif (buf(i:i) .eq. ' ') then
X          goto 4
X        else
X          out(j:j) = buf(i:i)
X          j = j + 1
X          i = i + 1
X        endif
X        goto 3
X4     continue
X
X      inet_getword = j - 1
X
X      return
X      end
X
X
X
Xc  Translate Eunice error number into printable string - EUNICEERR.INC
X
X      subroutine eunice_error(error, errbuf, errlen)
X
X      integer*2 error
X      character*(*) errbuf, temp*100
X      integer*4 i, errlen
X
X      i = error .and. '7fff'x
X      i = i / 8
X      if (i .le. 0 .or. i .gt. 65) then
X         temp = 'EUNKNOWN, Unknown Eunice error'
X      else
X         goto (1,2,3,4,5,6,7,8,9,10,
X     1         11,12,13,14,15,16,17,18,19,20,
X     2         21,22,23,24,25,26,27,28,29,30,
X     3         31,32,33,34,35,36,37,38,39,40,
X     4         41,42,43,44,45,46,47,48,49,50,
X     5         51,52,53,54,55,56,57,58,59,60,
X     6         61,62,63,64,65), i
X1        temp =`032
X     1   'EPERM, Not owner'
X         goto 100
X2        temp =`032
X     1   'ENOENT, No such file or directory'
X         goto 100
X3        temp =`032
X     1   'ESRCH, No such process'
X         goto 100
X4        temp =`032
X     1   'EINTR, Interrupted system call'
X         goto 100
X5        temp =`032
X     1   'EIO, I/O error'
X         goto 100
X6        temp =`032
X     1   'ENXIO, No such device or address'
X         goto 100
X7        temp =`032
X     1   'E2BIG, Arg list too long'
X         goto 100
X8        temp =`032
X     1   'ENOEXEC, Exec format error'
X         goto 100
X9        temp =`032
X     1   'EBADF, Bad file number'
X         goto 100
X10       temp =`032
X     1   'ECHILD, No children'
X         goto 100
X11       temp =`032
X     1   'EAGAIN, No more processes'
X         goto 100
X12       temp =`032
X     1   'ENOMEM, Not enough core'
X         goto 100
X13       temp =`032
X     1   'EACCES, Permission denied'
X         goto 100
X14       temp =`032
X     1   'EFAULT, Bad address'
X         goto 100
X15       temp =`032
X     1   'ENOTBLK, Block device required'
X         goto 100
X16       temp =`032
X     1   'EBUSY, Mount device busy'
X         goto 100
X17       temp =`032
X     1   'EEXIST, File exists'
X         goto 100
X18       temp =`032
X     1   'EXDEV, Cross-device link'
X         goto 100
X19       temp =`032
X     1   'ENODEV, No such device'
X         goto 100
X20       temp =`032
X     1   'ENOTDIR, Not a directory'
X         goto 100
X21       temp =`032
X     1   'EISDIR, Is a directory'
X         goto 100
X22       temp =`032
X     1   'EINVAL, Invalid argument'
X         goto 100
X23       temp =`032
X     1   'ENFILE, File table overflow'
X         goto 100
X24       temp =`032
X     1   'EMFILE, Too many open files'
X         goto 100
X25       temp =`032
X     1   'ENOTTY, Not a typewriter'
X         goto 100
X26       temp =`032
X     1   'ETXTBSY, Text file busy'
X         goto 100
X27       temp =`032
X     1   'EFBIG, File too large'
X         goto 100
X28       temp =`032
X     1   'ENOSPC, No space left on device'
X         goto 100
X29       temp =`032
X     1   'ESPIPE, Illegal seek'
X         goto 100
X30       temp =`032
X     1   'EROFS, Read-only file system'
X         goto 100
X31       temp =`032
X     1   'EMLINK, Too many links'
X         goto 100
X32       temp =`032
X     1   'EPIPE, Broken pipe'
X         goto 100
X33       temp =`032
X     1   'EDOM, Argument too large'
X         goto 100
X34       temp =`032
X     1   'ERANGE, Result too large'
X         goto 100
X35       temp =`032
X     1   'EWOULDBLOCK, Operation would block'
X         goto 100
X36       temp =`032
X     1   'EINPROGRESS, Operation now in progress'
X         goto 100
X37       temp =`032
X     1   'EALREADY, Operation already in progress'
X         goto 100
X38       temp =`032
X     1   'ENOTSOCK, Socket operation on non-socket'
X         goto 100
X39       temp =`032
X     1   'EDESTADDRREQ, Destination address required'
X         goto 100
X40       temp =`032
X     1   'EMSGSIZE, Message too long'
X         goto 100
X41       temp =`032
X     1   'EPROTOTYPE, Protocol wrong type for socket'
X         goto 100
X42       temp =`032
X     1   'ENOPROTOOPT, Protocol not available'
X         goto 100
X43       temp =`032
X     1   'EPROTONOSUPPORT, Protocol not supported'
X         goto 100
X44       temp =`032
X     1   'ESOCKTNOSUPPORT, Socket type not supported'
X         goto 100
X45       temp =`032
X     1   'EOPNOTSUPP, Operation not supported on socket'
X         goto 100
X46       temp =`032
X     1   'EPFNOSUPPORT, Protocol family not supported'
X         goto 100
X47       temp =`032
X     1   'EAFNOSUPPORT, Address family not supported by protocol family'
X         goto 100
X48       temp =`032
X     1   'EADDRINUSE, Address already in use'
X         goto 100
X49       temp =`032
X     1   'EADDRNOTAVAIL, Cannot assign requested address'
X         goto 100
X50       temp =`032
X     1   'ENETDOWN, Network is down'
X         goto 100
X51       temp =`032
X     1   'ENETUNREACH, Network is unreachable'
X         goto 100
X52       temp =`032
X     1   'ENETRESET, Network dropped connection on reset'
X         goto 100
X53       temp =`032
X     1   'ECONNABORTED, Software caused connection abort'
X         goto 100
X54       temp =`032
X     1   'ECONNRESET, Connection reset by peer'
X         goto 100
X55       temp =`032
X     1   'ENOBUFS, No buffer space available'
X         goto 100
X56       temp =`032
X     1   'EISCONN, Socket is already connected'
X         goto 100
X57       temp =`032
X     1   'ENOTCONN, Socket is not connected'
X         goto 100
X58       temp =`032
X     1   'ESHUTDOWN, Cannot send after socket shutdown'
X         goto 100
X59       temp =`032
X     1   'ETOOMANYREFS, Too many references: cannot splice'
X         goto 100
X60       temp =`032
X     1   'ETIMEDOUT, Connection timed out'
X         goto 100
X61       temp =`032
X     1   'ECONNREFUSED, Connection refused'
X         goto 100
X62       temp =`032
X     1   'ELOOP, Too many levels of symbolic links'
X         goto 100
X63       temp =`032
X     1   'ENAMETOOLONG, File name too long'
X         goto 100
X64       temp =`032
X     1   'EHOSTDOWN, Host is down'
X         goto 100
X65       temp =`032
X     1   'EHOSTUNREACH, No route to host'
X         goto 100
X      endif
X100   continue
X      errbuf = 'Eunice-E-' // temp
X      errlen = len(errbuf)
X      do while (errlen .gt. 0)
X         if (errbuf(errlen:errlen) .ne. ' ') then
X            goto 101
X         endif
X         errlen = errlen - 1
X      enddo
X101   continue
X
X      return
X      end
Xc  Fold character string to lower case - LOWER.INC
X
X        subroutine inet_lower(buf)
X
X        character*(*) buf
X        integer n, i, biga, bigz, diff, x
X
X        n = len(buf)
X        i = 1
X        biga = ichar('A')
X        bigz = ichar('Z')
X        diff = ichar('a') - biga
X        do while (i .le. n)
X          x = ichar(buf(i:i))
X          if (x .ge. biga .and. x .le. bigz) then
X            buf(i:i) = char(x+diff)
X          endif
X          i = i + 1
X        enddo
X
X        return
X        end
X`009subroutine bytetostr (bytary, max,string)
X`009byte bytary(max)
X`009integer max
X`009character*(*) string
X`009i = 1
X`009do while (i .le. max .and. bytary(i) .ne. 0)
-+-+-+-+-+ End of part 23 +-+-+-+-+-