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 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 lll=btrim(comm) if(lll.eq.1 .and. comm(1:1) .le. ' ') then tempcom = char(13)//char(10) else tempcom=comm(1:btrim(comm))//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='ETC:HOSTS.', type='OLD', READONLY, 1 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. 8) 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