integer function tcp_finger(host,comm,finger_out_routine)

c  Outgoing finger for VMS/Ultrix Connection (UCX) TCP/IP
c  Terry Kennedy, SPC, 27-Aug-1991
c  Some functions derived from existing TCPFINGER.FOR

	implicit	none

	external	fing_nonode, fing_nonet
	external	fing_complete, fing_abort
	external	fing_noservice, fing_unreachable

	external	finger_out_routine

	integer*4	btrim, get_host, open_net, read_net
	character*20	network, get_network

	character*(*)	host,comm

	integer		blen, i, i1, i2, i3, i4, j, lll
	character*2	line, buffer*1024
	character*132	tempcom, tempcom1
	character*15	ctemp
	
c  Default return status

	tcp_finger = %loc(fing_complete)
	call inet_lower(host)

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

	call inet_lower(tempcom)

c	see if we know this host

	buffer = ' '
	i = get_host(host)
c	type *,'get_host status is'
c	type *,i
	if (i .ne. 1) then
	  tcp_finger = %loc(fing_nonode)
	  return
	endif

c	wonderful - now try an open

200	i = open_net(0)
c	type *,'open_net status is'
c	type *,i
	if (i .ne. 1) then
	  tcp_finger = %loc(fing_nonet)
	  if (i .eq. 660) then
	    tcp_finger = %loc(fing_noservice)
	  endif
	  if (i .eq. 8340) then
	    tcp_finger = %loc(fing_unreachable)
	  endif
	  return
	endif

c	get network name

c	Site-specific: Finger normally adds ".DECnet", ".BITNET", etc. to the
c	header line. For TCP/IP networks this is a bit silly these days, since
c	the domains end in ".EDU", etc. In the "old days" it made sense to add
c	a ".ARPA". If you want to still do this, fiddle the following lines...

c	network = get_network('T')
c	if (network .eq. '?') network = 'ARPA'
c	call finger_out_routine('.'//network(:btrim(network))//']'
c    1	//char(13)//char(10))

	call finger_out_routine(']')
	call finger_out_routine(char(13)//char(10)//char(255))

c	write the command to the network

	call write_net(%ref(tempcom), btrim(tempcom))
c	now read responses until it's done sending

300	i = read_net(%ref(buffer))
	if (i .ne. 0) then
	  call finger_out_routine(buffer(1:i))
	  call lib$wait(.25)
	  go to 300
	endif
	tcp_finger = %loc(fing_complete)
	return
	end

c	translate string to lower case

        subroutine inet_lower(buf)

        character*(*)	buf
	character*26	ucase/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
	character*26	lcase/'abcdefghijklmnopqrstuvwxyz'/
	call str$translate(buf,buf,lcase,ucase)
	return
	end