	Integer Function TCP_Finger(Host,Comm,Finger_out_routine)

c  Outgoing finger for EUNICE TCP/IP
c  P. Lucas, CMU,  16-OCT-1984
c  This code borrows heavily form examples taken from Joe Sventek's primer
c	on how to do this stuff.
c
        include 'INETSYM.INC'
	External	Fing_Nonode, Fing_NoNet

        integer*4 bufsiz, sd,  errlen
	integer*4 btrim
        integer*2 sys$assign, sys$qiow
        logical*4 inet_gethost
        character*80 buffer
	logical*1 bytbuf(1024)
	character*132 tempcom, tempcom1
	Character	Network*20,	Get_Network*20
	character*(*)host,comm
        integer*2 iosb(4), s
        logical*4 error
        integer*2 swab
        character errbuf*256
	external  finger_out_routine
	external  Fing_Complete, Fing_Abort
c
c       FORTRAN equivalent of sockaddr_in
c
        integer*2 i2buf(8)
        logical*1 l1buf(16)
	Character	Flush /255/

        equivalence (i2buf(1), l1buf(1))
c  Default return status
	TCP_Finger = %Loc(Fing_Complete)
	call inet_lower(host)		!we need lower case host name

c   must terminate with cr/lf
	if (comm(1:6).eq.'FINGER') then
	  lll=index(comm,' ')
	  if ((lll.ne.0).and.(lll+1.le.len(comm))) then
	    tempcom1=comm(lll+1:)
	  else
	    tempcom1=' '
	  endif
	else
	  tempcom1=comm
	endif
	lll=btrim(tempcom1)
	if(lll.eq.1 .and. tempcom1(1:1) .le. ' ') then
		tempcom = char(13)//char(10)
	else
		tempcom=tempcom1(1:lll)//char(13)//char(10)
	endif
c
c
c       assign channel to device and create socket
c
        s = sys$assign('INET0:', sd,,)
        if (error(s, 1, errbuf, errlen)) then
		TCP_Finger = %Loc(Fing_NoNet)		!No TCP available
		return
        endif
        s = sys$qiow(%val(0), %val(sd), %val(IO$_SOCKET), %ref(iosb),
     1            ,, %val(AF_INET), %val(SOCK_STREAM),,,,)
        if (error(s, iosb(1), errbuf, errlen)) then
          call finger_out_routine(errbuf(1:errlen))
	  TCP_Finger = %loc(fing_abort)
	  return
        endif
c
c       fill in destination port and host address.  inet_gethost locates
c       the entry for the specified host in the file ETC:HOSTS.
c       and returns the internet address in the correct order
c
        i2buf(1) = AF_INET
        i2buf(2) = swab(79)
        if (.not. inet_gethost(host(1:btrim(host)), l1buf(5))) then
	  TCP_Finger = %Loc(Fing_NoNode)
	  return
        endif
c
c       connect to server
c
        s = sys$qiow(%val(0), %val(sd), %val(IO$_CONNECT), %ref(iosb),
     1            ,, %ref(l1buf), %val(16),,,,)
        if (error(s, iosb(1), errbuf, errlen)) then
	  Call Finger_Out_Routine
     1		(': link failed]'// char(13)//char(10))
          call finger_out_routine(errbuf(1:errlen))
	  TCP_Finger = %loc(fing_abort)
	  return
        endif
c  Get network name
	Network = Get_Network('T')
	if (network .eq. '?')network = 'ARPA'	!default to arpa
c  Finish message
	Call Finger_Out_Routine('.'//Network(:Btrim(Network))//']'
     1		//char(13)//char(10))

c
c   send the request
          s = sys$qiow(%val(0), %val(sd), %val(IO$_SEND), %ref(iosb),,,
     1              %ref(tempcom), %val(btrim(tempcom)),,,,)
          if (error(s, iosb(1), errbuf, errlen)) then
            call finger_out_routine(errbuf(1:errlen))
	    TCP_Finger = %loc(fing_abort)
	    return
          endif
c       read on socket until 0 length read - seems to imply
c       that the partner has exited
c
2        s = sys$qiow(%val(0), %val(sd), %val(IO$_RECEIVE), %ref(iosb),
     1            ,, %ref(bytbuf), %val(1024),,,,)
        if (error(s, iosb(1), errbuf, errlen)) then
          call finger_out_routine(errbuf(1:errlen))
	  TCP_Finger = %loc(fing_abort)
	  return
        endif
        if (iosb(2) .eq. 0) goto 222
	nl = iosb(2)/80
	do ii = 1,nl
		call bytetostr(bytbuf((ii-1)*80+1),80,buffer)
		call finger_out_routine(buffer)
	enddo
	ilen=iosb(2)-nl*80
	if(ilen .gt. 0)then
		call bytetostr(bytbuf(nl*80+1),ilen,buffer)
		call finger_out_routine(buffer(1:ilen))
	endif
	goto 2
c
222	call sys$dassgn(%val(sd))
	return
        end
c
c
c
c
c   Find host in etc:hosts and return inet address - GETHOST.INC

        logical function inet_gethost(host, adrbuf)

        character*(*) host
        logical*1 adrbuf(4)
        integer*4 lun, hostlen, n, i, adrlen, m, j, k
        integer*4 lib$get_lun, inet_getword
        character buffer*256, address*40, nicknm*40

        integer*4 i4
        logical*1 l1

        equivalence (l1,i4)

        if (.not. lib$get_lun(lun)) then
          inet_gethost = .false.
          return
        endif
        open (unit=lun, file='TWG$ETC:[000000]HOSTS.', type='OLD', 
     1     READONLY, err=10)
        hostlen = len(host)
1       continue
        read (lun, 100, end=11) n, buffer
100     format(q, (a))
        if (buffer(1:1) .eq. '#') goto 1        ! have a comment
        i = index(buffer(1:n), '#')
        if (i .gt. 0) then
          n = i
        endif
        do 4 i = 1, n
          k = ichar(buffer(i:i))
          if (k .eq. 9) then
            buffer(i:i) = ' '           ! replace tabs by blanks
          endif
4       continue
        i = 1
        adrlen = inet_getword(buffer(1:n), i, address)
        adrlen = adrlen + 1
        address(adrlen:adrlen) = '.'
2       continue
        m = inet_getword(buffer(1:n), i, nicknm)
        if (m .le. 0) goto 1
        if (m .ne. hostlen) goto 2
        if (nicknm(1:m) .ne. host(1:m)) goto 2
        close(unit = lun)
        call lib$free_lun(lun)
        i = 1
        do 3 j = 1, 4
          k = i + index(address(i:adrlen), '.') - 2
          call ots$cvt_ti_l(address(i:k), i4)
          adrbuf(j) = l1
          i = k + 2
3       continue
        inet_gethost = .true.
        return
11      close (unit = lun)
10      call lib$free_lun(lun)
        inet_gethost = .false.
        return
        end


c    Swap bytes in short integer - SWAB.INC

        integer*2 function swab(short)

        integer*2 short, result
        logical*1 bytes(2), temp

        equivalence (result, bytes(1))

        result = short
        temp = bytes(1)
        bytes(1) = bytes(2)
        bytes(2) = temp
        swab = result

        return
        end



c   Translate error into printable string - ERROR.INC

      logical function error(first, second, errbuf, errlen)

      integer*2 first, second
      character*(*) errbuf
      integer*4 errlen
      integer*2 err

      errlen = 0
      if (first .and. second) then
         error = .false.
         return
      endif
      if (.not. first) then
        err = first
      else
        err = second
      endif
      if ((err .and. '8000'x) .eq. '8000'x) then
        call eunice_error(err, errbuf, errlen)
      else
        call sys$getmsg(%val(err), %ref(errlen), errbuf, %val(15),)
      endif
      error = .true.
      return

      end

c   Fetch next word from buffer - GETWORD.INC

      integer*4 function inet_getword(buf, i, out)

      character*(*) buf, out
      integer*4 i, n, j

      n = len(buf)
1     continue
        if (i .gt. n) then
          goto 2
        elseif (buf(i:i) .ne. ' ') then
          goto 2
        else
          i = i + 1
        endif
        goto 1
2     continue
      j = 1
3     continue
        if (i .gt. n) then
          goto 4
        elseif (buf(i:i) .eq. ' ') then
          goto 4
        else
          out(j:j) = buf(i:i)
          j = j + 1
          i = i + 1
        endif
        goto 3
4     continue

      inet_getword = j - 1

      return
      end



c  Translate Eunice error number into printable string - EUNICEERR.INC

      subroutine eunice_error(error, errbuf, errlen)

      integer*2 error
      character*(*) errbuf, temp*100
      integer*4 i, errlen

      i = error .and. '7fff'x
      i = i / 8
      if (i .le. 0 .or. i .gt. 65) then
         temp = 'EUNKNOWN, Unknown Eunice error'
      else
         goto (1,2,3,4,5,6,7,8,9,10,
     1         11,12,13,14,15,16,17,18,19,20,
     2         21,22,23,24,25,26,27,28,29,30,
     3         31,32,33,34,35,36,37,38,39,40,
     4         41,42,43,44,45,46,47,48,49,50,
     5         51,52,53,54,55,56,57,58,59,60,
     6         61,62,63,64,65), i
1        temp = 
     1   'EPERM, Not owner'
         goto 100
2        temp = 
     1   'ENOENT, No such file or directory'
         goto 100
3        temp = 
     1   'ESRCH, No such process'
         goto 100
4        temp = 
     1   'EINTR, Interrupted system call'
         goto 100
5        temp = 
     1   'EIO, I/O error'
         goto 100
6        temp = 
     1   'ENXIO, No such device or address'
         goto 100
7        temp = 
     1   'E2BIG, Arg list too long'
         goto 100
8        temp = 
     1   'ENOEXEC, Exec format error'
         goto 100
9        temp = 
     1   'EBADF, Bad file number'
         goto 100
10       temp = 
     1   'ECHILD, No children'
         goto 100
11       temp = 
     1   'EAGAIN, No more processes'
         goto 100
12       temp = 
     1   'ENOMEM, Not enough core'
         goto 100
13       temp = 
     1   'EACCES, Permission denied'
         goto 100
14       temp = 
     1   'EFAULT, Bad address'
         goto 100
15       temp = 
     1   'ENOTBLK, Block device required'
         goto 100
16       temp = 
     1   'EBUSY, Mount device busy'
         goto 100
17       temp = 
     1   'EEXIST, File exists'
         goto 100
18       temp = 
     1   'EXDEV, Cross-device link'
         goto 100
19       temp = 
     1   'ENODEV, No such device'
         goto 100
20       temp = 
     1   'ENOTDIR, Not a directory'
         goto 100
21       temp = 
     1   'EISDIR, Is a directory'
         goto 100
22       temp = 
     1   'EINVAL, Invalid argument'
         goto 100
23       temp = 
     1   'ENFILE, File table overflow'
         goto 100
24       temp = 
     1   'EMFILE, Too many open files'
         goto 100
25       temp = 
     1   'ENOTTY, Not a typewriter'
         goto 100
26       temp = 
     1   'ETXTBSY, Text file busy'
         goto 100
27       temp = 
     1   'EFBIG, File too large'
         goto 100
28       temp = 
     1   'ENOSPC, No space left on device'
         goto 100
29       temp = 
     1   'ESPIPE, Illegal seek'
         goto 100
30       temp = 
     1   'EROFS, Read-only file system'
         goto 100
31       temp = 
     1   'EMLINK, Too many links'
         goto 100
32       temp = 
     1   'EPIPE, Broken pipe'
         goto 100
33       temp = 
     1   'EDOM, Argument too large'
         goto 100
34       temp = 
     1   'ERANGE, Result too large'
         goto 100
35       temp = 
     1   'EWOULDBLOCK, Operation would block'
         goto 100
36       temp = 
     1   'EINPROGRESS, Operation now in progress'
         goto 100
37       temp = 
     1   'EALREADY, Operation already in progress'
         goto 100
38       temp = 
     1   'ENOTSOCK, Socket operation on non-socket'
         goto 100
39       temp = 
     1   'EDESTADDRREQ, Destination address required'
         goto 100
40       temp = 
     1   'EMSGSIZE, Message too long'
         goto 100
41       temp = 
     1   'EPROTOTYPE, Protocol wrong type for socket'
         goto 100
42       temp = 
     1   'ENOPROTOOPT, Protocol not available'
         goto 100
43       temp = 
     1   'EPROTONOSUPPORT, Protocol not supported'
         goto 100
44       temp = 
     1   'ESOCKTNOSUPPORT, Socket type not supported'
         goto 100
45       temp = 
     1   'EOPNOTSUPP, Operation not supported on socket'
         goto 100
46       temp = 
     1   'EPFNOSUPPORT, Protocol family not supported'
         goto 100
47       temp = 
     1   'EAFNOSUPPORT, Address family not supported by protocol family'
         goto 100
48       temp = 
     1   'EADDRINUSE, Address already in use'
         goto 100
49       temp = 
     1   'EADDRNOTAVAIL, Cannot assign requested address'
         goto 100
50       temp = 
     1   'ENETDOWN, Network is down'
         goto 100
51       temp = 
     1   'ENETUNREACH, Network is unreachable'
         goto 100
52       temp = 
     1   'ENETRESET, Network dropped connection on reset'
         goto 100
53       temp = 
     1   'ECONNABORTED, Software caused connection abort'
         goto 100
54       temp = 
     1   'ECONNRESET, Connection reset by peer'
         goto 100
55       temp = 
     1   'ENOBUFS, No buffer space available'
         goto 100
56       temp = 
     1   'EISCONN, Socket is already connected'
         goto 100
57       temp = 
     1   'ENOTCONN, Socket is not connected'
         goto 100
58       temp = 
     1   'ESHUTDOWN, Cannot send after socket shutdown'
         goto 100
59       temp = 
     1   'ETOOMANYREFS, Too many references: cannot splice'
         goto 100
60       temp = 
     1   'ETIMEDOUT, Connection timed out'
         goto 100
61       temp = 
     1   'ECONNREFUSED, Connection refused'
         goto 100
62       temp = 
     1   'ELOOP, Too many levels of symbolic links'
         goto 100
63       temp = 
     1   'ENAMETOOLONG, File name too long'
         goto 100
64       temp = 
     1   'EHOSTDOWN, Host is down'
         goto 100
65       temp = 
     1   'EHOSTUNREACH, No route to host'
         goto 100
      endif
100   continue
      errbuf = 'Eunice-E-' // temp
      errlen = len(errbuf)
      do while (errlen .gt. 0)
         if (errbuf(errlen:errlen) .ne. ' ') then
            goto 101
         endif
         errlen = errlen - 1
      enddo
101   continue

      return
      end
c  Fold character string to lower case - LOWER.INC

        subroutine inet_lower(buf)

        character*(*) buf
        integer n, i, biga, bigz, diff, x

        n = len(buf)
        i = 1
        biga = ichar('A')
        bigz = ichar('Z')
        diff = ichar('a') - biga
        do while (i .le. n)
          x = ichar(buf(i:i))
          if (x .ge. biga .and. x .le. bigz) then
            buf(i:i) = char(x+diff)
          endif
          i = i + 1
        enddo

        return
        end
	subroutine bytetostr (bytary, max,string)
	byte bytary(max)
	integer max
	character*(*) string
	i = 1
	do while (i .le. max .and. bytary(i) .ne. 0)
		string(i:i) = char(bytary(i))
		i = i + 1
	end do
	string(i:) = ' '
	return
	end
